syntax/parse:

allow forward references from conventions
  fix progress comparison bug

svn: r18019

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)])
+  (make-declenv
-      ([literal literals])
+   (for/fold ([table (make-immutable-bound-id-table)])
-    (declenv-put-literal decls (car literal) (cadr literal))))
+       ([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?))]

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))])
+     (cond [(identifier? name)
-       (with-syntax ([sc-parser (stxclass-parser-name sc)]
+            (let ([sc (get-stxclass/check-arg-count class (length args))])
-                     [sc-description (stxclass-description sc)])
+              (with-syntax ([sc-parser (stxclass-parser-name sc)]
-         (if (pair? args)
+                            [sc-description (stxclass-description sc)])
-             (with-syntax ([x (generate-temporary 'x)]
+                (with-syntax ([parser (generate-temporary class)]
-                           [parser (generate-temporary class)]
+                              [description (generate-temporary class)])
-                           [description (generate-temporary class)]
+                  (values (make den:parser #'parser #'description
-                           [(arg ...) args])
+                                (stxclass-attrs sc) (stxclass/h? sc)
-               (values (make den:parser #'parser #'description
+                                (stxclass-commit? sc))
-                             (stxclass-attrs sc) (stxclass/h? sc)
+                          (list #`(define-values (parser description)
-                             (stxclass-commit? sc))
+                                    (curried-stxclass-procedures
-                       (list #'(define (parser x) (sc-parser x arg ...))
+                                     #,class #,args)))))))]
-                             #'(define (description) (description arg ...)))))
+           [(regexp? name)
-             (values (make den:parser #'sc-parser #'sc-description
+            ;; Conventions rule; delay class lookup until module/intdefs pass2
-                           (stxclass-attrs sc) (stxclass/h? sc)
+            ;; to allow forward references
-                           (stxclass-commit? sc))
+            (fprintf (current-error-port) "conventions aux def\n")
-                     null))))]
+            (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)
+     (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)])
-           (check-sc-expr #'sc #'rx))]))
+       (list name-pattern
+             (check-sc-expr #'sc name-pattern)))]))
 
 ;; bind clauses
 (define (check-bind-clause-list stx ctx)

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) '<]
+     (cond [(< na nb) (compare-idfcs pa (make dfc:cdr pb (- nb na)))]
-           [(> na nb) '>]
+           [(> 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 ...)))))]))

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
+                                          (make-den:delayed
-                                           (quote-syntax #,(den:parser-parser den))
+                                           (quote-syntax #,(den:delayed-parser den))
-                                           (quote-syntax #,(den:parser-description den))
+                                           (quote-syntax #,(den:delayed-description den))
-                                           (quote #,(den:parser-attrs den))
+                                           (quote-syntax #,(den:delayed-class den))))
-                                           (quote #,(den:parser-splicing? den))
-                                           (quote #,(den:parser-commit? den))))
                                   defs))))])
          #'(begin
              def ... ...