diff --git a/collects/syntax/private/stxparse/rep-data.ss b/collects/syntax/private/stxparse/rep-data.ss index 1f2bf750f4..38b3cf900a 100644 --- a/collects/syntax/private/stxparse/rep-data.ss +++ b/collects/syntax/private/stxparse/rep-data.ss @@ -88,17 +88,22 @@ DeclEntry = (make-den:lit id id) (make-den:class id id (listof syntax) bool) (make-den:parser id id (listof SAttr) bool bool) + (make-den:delayed id id id) |# (define-struct declenv (table conventions)) (define-struct den:lit (internal external)) (define-struct den:class (name class args)) (define-struct den:parser (parser description attrs splicing? commit?)) +(define-struct den:delayed (parser description class)) (define (new-declenv literals #:conventions [conventions null]) - (for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)]) - ([literal literals]) - (declenv-put-literal decls (car literal) (cadr literal)))) + (make-declenv + (for/fold ([table (make-immutable-bound-id-table)]) + ([literal literals]) + (bound-id-table-set table (car literal) + (make den:lit (car literal) (cadr literal)))) + conventions)) (define (declenv-lookup env id #:use-conventions? [use-conventions? #t]) (or (bound-id-table-ref (declenv-table env) id #f) @@ -124,13 +129,6 @@ DeclEntry = (wrong-syntax id "(internal error) late unbound check")] ['#f (void)]))) -(define (declenv-put-literal env internal-id lit-id) - (declenv-check-unbound env internal-id) - (make-declenv - (bound-id-table-set (declenv-table env) internal-id - (make den:lit internal-id lit-id)) - (declenv-conventions env))) - (define (declenv-put-stxclass env id stxclass-name args) (declenv-check-unbound env id) (make-declenv @@ -138,13 +136,6 @@ DeclEntry = (make den:class id stxclass-name args)) (declenv-conventions env))) -(define (declenv-put-parser env id parser get-description attrs splicing? commit?) - ;; no unbound check, since replacing 'stxclass entry - (make-declenv - (bound-id-table-set (declenv-table env) id - (make den:parser parser get-description attrs splicing? commit?)) - (declenv-conventions env))) - ;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a ;; -> (values DeclEnv a) (define (declenv-update/fold env0 f acc0) @@ -183,14 +174,16 @@ DeclEntry = (flat-named-contract 'DeclEnv declenv?)) (define DeclEntry/c - (flat-named-contract 'DeclEntry (or/c den:lit? den:class? den:parser?))) + (flat-named-contract 'DeclEntry + (or/c den:lit? den:class? den:parser? den:delayed?))) (define SideClause/c (or/c clause:fail? clause:with? clause:attr?)) (provide (struct-out den:lit) (struct-out den:class) - (struct-out den:parser)) + (struct-out den:parser) + (struct-out den:delayed)) (provide/contract [DeclEnv/c contract?] @@ -209,12 +202,6 @@ DeclEntry = [declenv-put-stxclass (-> DeclEnv/c identifier? identifier? (listof syntax?) DeclEnv/c)] - [declenv-put-literal - (-> DeclEnv/c identifier? identifier? - DeclEnv/c)] - [declenv-put-parser - (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? boolean? - DeclEnv/c)] [declenv-domain-difference (-> DeclEnv/c (listof identifier?) (listof identifier?))] diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index f165d41096..6123aa654a 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -212,24 +212,31 @@ [(struct den:lit (_i _e)) (values entry null)] [(struct den:class (name class args)) - (let ([sc (get-stxclass/check-arg-count class (length args))]) - (with-syntax ([sc-parser (stxclass-parser-name sc)] - [sc-description (stxclass-description sc)]) - (if (pair? args) - (with-syntax ([x (generate-temporary 'x)] - [parser (generate-temporary class)] - [description (generate-temporary class)] - [(arg ...) args]) - (values (make den:parser #'parser #'description - (stxclass-attrs sc) (stxclass/h? sc) - (stxclass-commit? sc)) - (list #'(define (parser x) (sc-parser x arg ...)) - #'(define (description) (description arg ...))))) - (values (make den:parser #'sc-parser #'sc-description - (stxclass-attrs sc) (stxclass/h? sc) - (stxclass-commit? sc)) - null))))] + (cond [(identifier? name) + (let ([sc (get-stxclass/check-arg-count class (length args))]) + (with-syntax ([sc-parser (stxclass-parser-name sc)] + [sc-description (stxclass-description sc)]) + (with-syntax ([parser (generate-temporary class)] + [description (generate-temporary class)]) + (values (make den:parser #'parser #'description + (stxclass-attrs sc) (stxclass/h? sc) + (stxclass-commit? sc)) + (list #`(define-values (parser description) + (curried-stxclass-procedures + #,class #,args)))))))] + [(regexp? name) + ;; Conventions rule; delay class lookup until module/intdefs pass2 + ;; to allow forward references + (fprintf (current-error-port) "conventions aux def\n") + (with-syntax ([parser (generate-temporary class)] + [description (generate-temporary class)]) + (values (make den:delayed #'parser #'get-description class) + (list #`(define-values (parser description) + (curried-stxclass-procedures + #,class #,args)))))])] [(struct den:parser (_p _d _a _sp _c)) + (values entry null)] + [(struct den:delayed (_p _d _c)) (values entry null)])) (define (append-lits+litsets lits litsets) @@ -450,9 +457,29 @@ "(internal error) decls had leftover stxclass entry: ~s" entry)] [(struct den:parser (parser desc attrs splicing? commit?)) + ;; FIXME: why no allow-head? check??? (if splicing? - (parse-pat:id/h id parser null attrs commit?) + (begin + (unless allow-head? + (wrong-syntax id "splicing syntax class not allowed here")) + (parse-pat:id/h id parser null attrs commit?)) (parse-pat:id/s id parser null attrs commit?))] + [(struct den:delayed (parser desc class)) + (let ([sc (get-stxclass class)]) + (cond [(stxclass/s? sc) + (parse-pat:id/s id + parser + null + (stxclass-attrs sc) + (stxclass-commit? sc))] + [(stxclass/h? sc) + (unless allow-head? + (wrong-syntax id "splicing syntax class not allowed here")) + (parse-pat:id/h id + parser + null + (stxclass-attrs sc) + (stxclass-commit? sc))]))] ['#f (when #t ;; FIXME: right place??? (unless (safe-name? id) @@ -1007,8 +1034,9 @@ [_ (raise-syntax-error #f "expected syntax class use" ctx x)])) (syntax-case stx () [(rx sc) - (list (check-conventions-pattern (syntax-e #'rx) #'rx) - (check-sc-expr #'sc #'rx))])) + (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)]) + (list name-pattern + (check-sc-expr #'sc name-pattern)))])) ;; bind clauses (define (check-bind-clause-list stx ctx) diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index db5283ee20..3d5407c753 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/collects/syntax/private/stxparse/runtime.ss @@ -254,8 +254,8 @@ A Dynamic Frontier Context (DFC) is one of [(list (make dfc:car pa _) (make dfc:car pb _)) (compare-idfcs pa pb)] [(list (make dfc:cdr pa na) (make dfc:cdr pb nb)) - (cond [(< na nb) '<] - [(> na nb) '>] + (cond [(< na nb) (compare-idfcs pa (make dfc:cdr pb (- nb na)))] + [(> na nb) (compare-idfcs (make-dfc:cdr pa (- na nb)) pb)] [(= na nb) (compare-idfcs pa pb)])] [(list (make dfc:pre pa _) (make dfc:pre pb _)) ;; FIXME: possibly just '= here, treat all sides as equiv @@ -579,3 +579,21 @@ An Expectation is one of (define-struct parser (proc errors) #:property prop:procedure (struct-field-index proc)) + +;; + +(provide curried-stxclass-procedures) + +(define-syntax (curried-stxclass-procedures stx) + (syntax-case stx () + [(cp class (arg ...)) + (let* ([args (syntax->list #'(arg ...))] + [sc (get-stxclass/check-arg-count #'class (length args))]) + (with-syntax ([parser (stxclass-parser-name sc)] + [get-description (stxclass-description sc)] + [(extra ...) + (if (stxclass-commit? sc) + #'() + #'(k))]) + #'(values (lambda (x extra ...) (parser x extra ... arg ...)) + (lambda () (get-description arg ...)))))])) diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index f245c7fe99..27520de727 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -3,6 +3,7 @@ scheme/private/sc unstable/syntax unstable/struct + "minimatch.ss" "rep-data.ss" "rep.ss") scheme/list @@ -101,12 +102,10 @@ [den (cadr line)]) (let-values ([(den defs) (create-aux-def den)]) (list #`(list (quote #,rx) - (make-den:parser - (quote-syntax #,(den:parser-parser den)) - (quote-syntax #,(den:parser-description den)) - (quote #,(den:parser-attrs den)) - (quote #,(den:parser-splicing? den)) - (quote #,(den:parser-commit? den)))) + (make-den:delayed + (quote-syntax #,(den:delayed-parser den)) + (quote-syntax #,(den:delayed-description den)) + (quote-syntax #,(den:delayed-class den)))) defs))))]) #'(begin def ... ...