diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss index 3506fb08c0..f67c58a9b9 100644 --- a/collects/syntax/private/stxparse/lib.ss +++ b/collects/syntax/private/stxparse/lib.ss @@ -40,10 +40,14 @@ (define-pred-stxclass identifier symbol?) (define-pred-stxclass boolean boolean?) -(define-pred-stxclass str string?) (define-pred-stxclass character char?) (define-pred-stxclass keyword keyword?) +(define-syntax-class str #:attributes () #:opaque + #:description "string" + (pattern x + #:fail-unless (string? (syntax-e #'x)) #f)) + (define-pred-stxclass number number?) (define-pred-stxclass integer integer?) (define-pred-stxclass exact-integer exact-integer?) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index c01a6fbf72..f38b30c5a7 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -46,20 +46,6 @@ ;; ---- -#| - -syntax-class protocol ---------------------- - -for syntax-class SC with args (P ...) - -if commit? = #t - parser : Stx P ... -> (U list expectation) -if commit? = #f - parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer - -|# - ;; (parse:rhs RHS (SAttr ...) (id ...) id boolean) ;; : expr[(values ParseFunction DescriptionFunction)] ;; Takes a list of the relevant attrs; order is significant! diff --git a/collects/syntax/private/stxparse/rep-data.ss b/collects/syntax/private/stxparse/rep-data.ss index 38b3cf900a..17469b36e6 100644 --- a/collects/syntax/private/stxparse/rep-data.ss +++ b/collects/syntax/private/stxparse/rep-data.ss @@ -21,6 +21,31 @@ (struct-out conventions) (struct-out literalset)) +#| + +NOTES + +syntax-class protocol +--------------------- + +Two kinds of syntax class: commit? = #t, commit? = #f + +let syntax-class SC have params (P ...) + if commit? = #t + parser : Stx P ... -> (U list expectation) + if commit? = #f + parser : Stx ((U list expect) FailFunction -> Answer) P ... -> Answer + + +conventions +----------- + +let conventions C have params (P ...) + get-procedures : + (P ... -> (values (listof ParserFun) (listof DescriptionFun))) + +|# + #| A stxclass is (make-sc symbol (listof symbol) (list-of SAttr) identifier identifier boolean boolean) @@ -60,10 +85,10 @@ A SideClause is one of #| A Conventions is - (make-conventions (listof ConventionRule)) + (make-conventions id (-> (listof ConventionRule))) A ConventionRule is (list regexp DeclEntry) |# -(define-struct conventions (rules) #:transparent) +(define-struct conventions (get-procedures get-rules) #:transparent) #| A LiteralSet is diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index e9b71a9798..8050721f7d 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -173,9 +173,11 @@ (define (get-decls+defs chunks strict? #:context [ctx (current-syntax-context)]) (parameterize ((current-syntax-context ctx)) - (decls-create-defs (get-decls chunks strict?)))) + (let*-values ([(decls defs1) (get-decls chunks strict?)] + [(decls defs2) (decls-create-defs decls)]) + (values decls (append defs1 defs2))))) -;; get-decls : chunks -> DeclEnv +;; get-decls : chunks -> (values DeclEnv (listof syntax)) (define (get-decls chunks strict?) (define lits (options-select-value chunks '#:literals #:default null)) (define litsets (options-select-value chunks '#:literal-sets #:default null)) @@ -184,8 +186,28 @@ (define literals (append-lits+litsets (check-literals-bound lits strict?) litsets)) - (define convention-rules (apply append (cons localconvs convs))) - (new-declenv literals #:conventions convention-rules)) + (define-values (convs-rules convs-defs) + (for/fold ([convs-rules null] [convs-defs null]) + ([conv-entry convs]) + (let* ([c (car conv-entry)] + [args (cdr conv-entry)] + [get-parser-id (conventions-get-procedures c)] + [rules ((conventions-get-rules c))]) + (values (append rules convs-rules) + (cons (make-conventions-def (map cadr rules) get-parser-id args) + convs-defs))))) + (define convention-rules (append localconvs convs-rules)) + (values (new-declenv literals #:conventions convention-rules) + (reverse convs-defs))) + +;; make-conventions-def : (listof den:delay) id (listof syntax) -> syntax +(define (make-conventions-def dens get-procedures-id args) + (with-syntax ([(parser ...) (map den:delayed-parser dens)] + [get-procedures get-procedures-id] + [(arg ...) args]) + #'(define-values (parser ...) + (let-values ([(parsers descriptions) (get-procedures arg ...)]) + (apply values parsers))))) (define (check-literals-bound lits strict?) (define phase (syntax-local-phase-level)) @@ -229,7 +251,7 @@ ;; to allow forward references (with-syntax ([parser (generate-temporary class)] [description (generate-temporary class)]) - (values (make den:delayed #'parser #'get-description class) + (values (make den:delayed #'parser #'description class) (list #`(define-values (parser description) (curried-stxclass-procedures #,class #,args)))))])] @@ -891,26 +913,26 @@ ;; grab-decls : (listof chunk) DeclEnv ;; -> (values DeclEnv (listof chunk)) -(define (grab-decls chunks decls) +(define (grab-decls chunks decls0) (define (add-decl stx decls) (syntax-case stx () [(#:declare name sc) (identifier? #'sc) - (add-decl* #'name #'sc null)] + (add-decl* decls #'name #'sc null)] [(#:declare name (sc expr ...)) (identifier? #'sc) - (add-decl* #'name #'sc (syntax->list #'(expr ...)))] + (add-decl* decls #'name #'sc (syntax->list #'(expr ...)))] [(#:declare name bad-sc) (wrong-syntax #'bad-sc "expected syntax class name (possibly with parameters)")])) - (define (add-decl* id sc-name args) + (define (add-decl* decls id sc-name args) (declenv-put-stxclass decls id sc-name args)) (define (loop chunks decls) (match chunks [(cons (cons '#:declare decl-stx) rest) (loop rest (add-decl decl-stx decls))] [_ (values decls chunks)])) - (loop chunks decls)) + (loop chunks decls0)) ;; ---- @@ -989,23 +1011,28 @@ (list (datum->syntax lctx (car entry) srcctx) (cadr entry)))) +;; returns (listof (cons Conventions (listof syntax))) (define (check-conventions-list stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected conventions list" ctx stx)) (for/list ([x (stx->list stx)]) (check-conventions x ctx))) +;; returns (cons Conventions (listof syntax)) (define (check-conventions stx ctx) - (define (elaborate conventions-id) + (define (elaborate conventions-id args) (let ([cs (syntax-local-value/catch conventions-id conventions?)]) (unless cs (raise-syntax-error #f "expected identifier defined as a conventions" ctx conventions-id)) - (conventions-rules cs))) + (cons cs args))) (syntax-case stx () + [(conventions arg ...) + (identifier? #'conventions) + (elaborate #'conventions (syntax->list #'(arg ...)))] [conventions (identifier? #'conventions) - (elaborate #'conventions)] + (elaborate #'conventions null)] [_ (raise-syntax-error "expected conventions entry" ctx stx)])) @@ -1019,9 +1046,12 @@ ;; returns (list regexp DeclEntry) (define (check-conventions-rule stx ctx) (define (check-conventions-pattern x blame) - (cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] + (cond [(symbol? x) + (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] [(regexp? x) x] - [else (raise-syntax-error #f "expected identifier convention pattern" ctx blame)])) + [else + (raise-syntax-error #f "expected identifier convention pattern" + ctx blame)])) (define (check-sc-expr x rx) (syntax-case x () [sc diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index 3d5407c753..37924ecf50 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/collects/syntax/private/stxparse/runtime.ss @@ -561,7 +561,7 @@ An Expectation is one of (define (frontier->sexpr dfc) (match (invert-dfc dfc) [(make dfc:empty _) '()] - [(make dfc:car p _) (cons 0 (frontier->sexpr p))] + [(make dfc:car p _) (cons 'car (frontier->sexpr p))] [(make dfc:cdr p n) (cons n (frontier->sexpr p))] [(make dfc:pre p _) (cons 'pre (frontier->sexpr p))] [(make dfc:post p _) (cons 'post (frontier->sexpr p))])) diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index 27520de727..824cb344bf 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -92,26 +92,52 @@ (define-syntax (define-conventions stx) (syntax-case stx () - [(define-conventions name rule ...) - (begin - (unless (identifier? #'name) - (raise-syntax-error #f "expected identifier" stx #'name)) - (with-syntax ([([entry (def ...)] ...) - (for/list ([line (check-conventions-rules #'(rule ...) stx)]) - (let ([rx (car line)] - [den (cadr line)]) - (let-values ([(den defs) (create-aux-def den)]) - (list #`(list (quote #,rx) - (make-den:delayed - (quote-syntax #,(den:delayed-parser den)) - (quote-syntax #,(den:delayed-description den)) - (quote-syntax #,(den:delayed-class den)))) - defs))))]) + [(define-conventions (name param ...) rule ...) + (let ([params (syntax->list #'(param ...))]) + (for ([x (syntax->list #'(name param ...))]) + (unless (identifier? x) + (raise-syntax-error #f "expected identifier" stx x))) + (let () + (define rules (check-conventions-rules #'(rule ...) stx)) + (define rxs (map car rules)) + (define dens0 (map cadr rules)) + (define den+defs-list + (for/list ([den0 dens0]) + (let-values ([(den defs) (create-aux-def den0)]) + (cons den defs)))) + (define dens (map car den+defs-list)) + (define defs (apply append (map cdr den+defs-list))) + + (define/with-syntax (rx ...) rxs) + (define/with-syntax (def ...) defs) + (define/with-syntax (parser ...) + (map den:delayed-parser dens)) + (define/with-syntax (description ...) + (map den:delayed-description dens)) + (define/with-syntax (class-name ...) + (map den:delayed-class dens)) + #'(begin - def ... ... (define-syntax name (make-conventions - (list entry ...))))))])) + (quote-syntax get-procedures) + (lambda () + (let ([class-names (list (quote-syntax class-name) ...)]) + (map list + (list 'rx ...) + (map make-den:delayed + (generate-temporaries class-names) + (generate-temporaries class-names) + class-names)))))) + (define get-procedures + (lambda (param ...) + def ... + (values (list parser ...) + (list description ...)))))))] + + [(define-conventions name rule ...) + (identifier? #'name) + #'(define-conventions (name) rule ...)])) (define-syntax (define-literal-set stx) (syntax-case stx () @@ -182,7 +208,7 @@ (define-syntax (debug-rhs stx) (syntax-case stx () [(debug-rhs rhs) - (let ([rhs (parse-rhs #'rhs #t #:context stx)]) + (let ([rhs (parse-rhs #'rhs #f #f #:context stx)]) #`(quote #,rhs))])) (define-syntax (debug-pattern stx)