suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse: add description-if-constant field to stxclass

Browse Source 
Also remove (inline) options, integrate structs and improve comments.
This commit is contained in:
Ryan Culpepper 2016-07-29 12:56:24 -04:00
parent 1f94c4ed3a
commit 22b5d6b2da
7 changed files with 67 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
racket/collects/syntax/parse/experimental/provide.rkt
View File

@ -61,7 +61,7 @@
(join-sep (map kw->string maxkws*) "," "and")
(join-sep (map kw->string maxkws) "," "and")))
(with-syntax ([scname scname]
[#s(stxclass name arity attrs parser splicing? options integrate)
[#s(stxclass name arity attrs parser splicing? commit? delimit? inline desc)
stxclass]
[#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
(opc ...) (okw ...) (okwc ...))
@ -100,8 +100,8 @@
'attrs
(quote-syntax contracted-parser)
'splicing?
'options
#f)) ;; must disable integration
'commit? 'delimit?
#f 'desc)) ;; must disable integration
(provide (rename-out [contracted-scname scname])))))))])))
(define-syntax (provide-syntax-class/contract stx)

8
racket/collects/syntax/parse/experimental/specialize.rkt
View File

@ -27,15 +27,17 @@
[splicing? (stxclass-splicing? target)]
[arity arity]
[attrs (stxclass-attrs target)]
[options (stxclass-options target)]
[commit? (stxclass-commit? target)]
[delimit-cut? (stxclass-delimit-cut? target)]
[target-parser (stxclass-parser target)]
[desc (stxclass-desc target)]
[argu argu])
#`(begin (define-syntax name
(stxclass 'name 'arity 'attrs
(quote-syntax parser)
'splicing?
options
#f))
'commit? 'delimit-cut?
#f 'desc))
(define-values (parser)
(lambda (x cx pr es fh0 cp0 rl success . formals)
(app-argu target-parser x cx pr es fh0 cp0 rl success argu))))))))])))

4
racket/collects/syntax/parse/experimental/splicing.rkt
View File

@ -58,8 +58,8 @@
(sort-sattrs '(#s(attr a.name a.depth #f) ...))
(quote-syntax parser)
#t
#s(options #t #t)
#f)))]))
#t #t
#f #f)))]))
(define (mk-permute unsorted-attrs)
(let ([sorted-attrs

31
racket/collects/syntax/parse/private/parse.rkt
View File

@ -34,6 +34,18 @@
(for-syntax rhs->parser))
(begin-for-syntax
;; constant-desc : Syntax -> String/#f
(define (constant-desc stx)
(syntax-case stx (quote)
[(quote datum)
(let ([d (syntax-e #'datum)])
(and (string? d) d))]
[expr
(let ([d (syntax-e #'expr)])
(and (string? d)
(free-identifier=? #'#%datum (datum->syntax #'expr '#%datum))
d))]))
(define (tx:define-*-syntax-class stx splicing?)
(syntax-case stx ()
[(_ header . rhss)
@ -44,17 +56,22 @@
(let ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)])
(with-syntax ([name name]
[formals formals]
[desc (cond [(rhs-description the-rhs) => constant-desc]
[else (symbol->string (syntax-e name))])]
[parser (generate-temporary (format-symbol "parse-~a" name))]
[arity arity]
[attrs (rhs-attrs the-rhs)]
[options (rhs-options the-rhs)])
[commit? (rhs-commit? the-rhs)]
[delimit-cut? (rhs-delimit-cut? the-rhs)])
#`(begin (define-syntax name
(stxclass 'name 'arity
'attrs
(quote-syntax parser)
'#,splicing?
options
#f))
'commit?
'delimit-cut?
#f
'desc))
(define-values (parser)
(parser/rhs name formals attrs rhss #,splicing? #,stx)))))))])))
@ -72,8 +89,10 @@
(stxclass 'name no-arity '()
(quote-syntax parser)
#f
'#s(options #t #t)
(integrate (quote-syntax predicate) 'description)))
#t
#t
(quote-syntax predicate)
'description))
(define (parser x cx pr es fh0 cp0 rl success)
(if (predicate x)
(success fh0)
@ -95,7 +114,7 @@
(define (rhs->parser name formals relsattrs the-rhs splicing?)
(define-values (transparent? description variants defs commit? delimit-cut?)
(match the-rhs
[(rhs _ _ transparent? description variants defs (options commit? delimit-cut?) _)
[(rhs _ transparent? description variants defs commit? delimit-cut? _)
(values transparent? description variants defs commit? delimit-cut?)]))
(define vdefss (map variant-definitions variants))
(define formals* (rewrite-formals formals #'x #'rl))

29
racket/collects/syntax/parse/private/rep-data.rkt
View File

@ -9,8 +9,6 @@
"kws.rkt")
;; from residual.rkt
(provide (struct-out stxclass)
(struct-out options)
(struct-out integrate)
(struct-out conventions)
(struct-out literalset)
(struct-out eh-alternative-set)
@ -18,8 +16,6 @@
;; from here
(provide stxclass/s?
stxclass/h?
stxclass-commit?
stxclass-delimit-cut?
(struct-out rhs)
(struct-out variant))
@ -28,18 +24,17 @@
(define (stxclass/h? x)
(and (stxclass? x) (stxclass-splicing? x)))
(define (stxclass-commit? x)
(options-commit? (stxclass-options x)))
(define (stxclass-delimit-cut? x)
(options-delimit-cut? (stxclass-options x)))
#|
An RHS is
#s(rhs stx (listof SAttr) bool stx/#f (listof Variant) (listof stx) Options Integrate/#f)
definitions: auxiliary definitions from #:declare
|#
(define-struct rhs (ostx attrs transparent? description variants definitions options integrate)
#:prefab)
;; An RHS is #s(rhs SAttrs Bool Stx/#f Variants Stxs Bool Bool Id/#f)
(define-struct rhs
(attrs ;; (Listof Sattr)
transparent? ;; Bool
description ;; Syntax/#f
variants ;; (Listof Variant)
definitions ;; (Listof Stx), aux definitions from txlifts, local conventions?, etc
commit? ;; Bool
delimit-cut? ;; Bool
pred ;; ???
) #:prefab)
#|
A Variant is
@ -50,7 +45,7 @@ A Variant is
;; make-dummy-stxclass : identifier -> SC
;; Dummy stxclass for calculating attributes of recursive stxclasses.
(define (make-dummy-stxclass name)
(make stxclass (syntax-e name) #f null #f #f #s(options #f #t) #f))
(make stxclass (syntax-e name) #f null #f #f #f #t #f #f))
;; Environments

18
racket/collects/syntax/parse/private/rep.rkt
View File

@ -164,7 +164,7 @@
(lambda ()
(parameterize ((current-syntax-context ctx))
(define-values (rest description transp? attributes auto-nested? colon-notation?
decls defs options)
decls defs commit? delimit-cut?)
(parse-rhs/part1 stx splicing? (and expected-attrs #t)))
(define variants
(parameterize ((stxclass-lookup-config
@ -176,9 +176,9 @@
(let ([sattrs
(or attributes
(intersect-sattrss (map variant-attrs variants)))])
(make rhs stx sattrs transp? description variants
(make rhs sattrs transp? description variants
(append (get-txlifts-as-definitions) defs)
options #f))))))
commit? delimit-cut? #f))))))
(define (parse-rhs/part1 stx splicing? strict?)
(define-values (chunks rest)
@ -199,7 +199,7 @@
(define attributes (options-select-value chunks '#:attributes #:default #f))
(define-values (decls defs) (get-decls+defs chunks strict?))
(values rest description transparent? attributes auto-nested? colon-notation?
decls defs (options commit? delimit-cut?)))
decls defs commit? delimit-cut?))
;; ----
@ -757,9 +757,9 @@
;; if parser* not #f, overrides sc parser
(check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
(cond [(and (stxclass/s? sc)
(stxclass-integrate sc)
(stxclass-inline sc)
(equal? argu no-arguments))
(parse-pat:id/s/integrate name (stxclass-integrate sc) role)]
(parse-pat:id/s/integrate name (stxclass-inline sc) (stxclass-desc sc) role)]
[(stxclass/s? sc)
(parse-pat:id/s name
(or parser* (stxclass-parser sc))
@ -784,11 +784,9 @@
(define bind (name->bind name))
(pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (parse-pat:id/s/integrate name integrate role)
(define (parse-pat:id/s/integrate name predicate description role)
(define bind (name->bind name))
(let ([predicate (integrate-predicate integrate)]
[description (integrate-description integrate)])
(pat:integrated bind predicate description role)))
(pat:integrated bind predicate description role))
(define (parse-pat:id/h name parser argu attrs commit? pfx role)
(define prefix (name->prefix name pfx))

28
racket/collects/syntax/parse/private/residual-ct.rkt
View File

@ -1,8 +1,6 @@
#lang racket/base
(provide (struct-out attr)
(struct-out stxclass)
(struct-out options)
(struct-out integrate)
(struct-out conventions)
(struct-out literalset)
(struct-out lse:lit)
@ -29,20 +27,18 @@
;; == from rep-data.rkt
#|
A stxclass is
#s(stxclass symbol (listof symbol) (list-of SAttr) identifier bool Options Integrate/#f)
where Options = #s(options boolean boolean)
Integrate = #s(integrate id string)
Arity is defined in kws.rkt
|#
(define-struct stxclass (name arity attrs parser splicing? options integrate)
#:prefab)
(define-struct options (commit? delimit-cut?)
#:prefab)
(define-struct integrate (predicate description)
#:prefab)
;; A stxclass is #s(stxclass Symbol Symbols SAttrs Id Bool Bool BoolOptions Id/#f String/#f)
(define-struct stxclass
(name ;; Symbol
arity ;; Arity (defined in kws.rkt)
attrs ;; (Listof SAttr)
parser ;; Id, reference to parser (see parse.rkt for parser signature)
splicing? ;; Bool
commit? ;; Bool
delimit-cut? ;; Bool
inline ;; Id/#f, reference to a predicate
desc ;; String/#f, String = known constant description
) #:prefab)
#|
A Conventions is