diff --git a/racket/collects/syntax/parse/experimental/provide.rkt b/racket/collects/syntax/parse/experimental/provide.rkt index 18b4815c75..859c9c6347 100644 --- a/racket/collects/syntax/parse/experimental/provide.rkt +++ b/racket/collects/syntax/parse/experimental/provide.rkt @@ -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) diff --git a/racket/collects/syntax/parse/experimental/specialize.rkt b/racket/collects/syntax/parse/experimental/specialize.rkt index f7609a6fb2..8ef61a2dc0 100644 --- a/racket/collects/syntax/parse/experimental/specialize.rkt +++ b/racket/collects/syntax/parse/experimental/specialize.rkt @@ -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))))))))]))) diff --git a/racket/collects/syntax/parse/experimental/splicing.rkt b/racket/collects/syntax/parse/experimental/splicing.rkt index a32f68ee02..848c8e8947 100644 --- a/racket/collects/syntax/parse/experimental/splicing.rkt +++ b/racket/collects/syntax/parse/experimental/splicing.rkt @@ -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 diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index aa22f75ceb..55b5d58514 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -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)) diff --git a/racket/collects/syntax/parse/private/rep-data.rkt b/racket/collects/syntax/parse/private/rep-data.rkt index 51fe7128d8..6946f2d1b4 100644 --- a/racket/collects/syntax/parse/private/rep-data.rkt +++ b/racket/collects/syntax/parse/private/rep-data.rkt @@ -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 diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index fe51a1647a..2ee4b63141 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -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)) diff --git a/racket/collects/syntax/parse/private/residual-ct.rkt b/racket/collects/syntax/parse/private/residual-ct.rkt index ab681a6cda..794d816586 100644 --- a/racket/collects/syntax/parse/private/residual-ct.rkt +++ b/racket/collects/syntax/parse/private/residual-ct.rkt @@ -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