syntax/parse:

added parameterized conventions
  fixed description for "str" stxclass
  fixed bug in multiple #:declare directives

svn: r18439

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?)

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!

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

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)))
+  (define-values (convs-rules convs-defs)
-  (new-declenv literals #:conventions convention-rules))
+    (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

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))]))

collects/syntax/private/stxparse/sc.ss

@@ -92,26 +92,52 @@
 
 (define-syntax (define-conventions stx)
   (syntax-case stx ()
-    [(define-conventions name rule ...)
+    [(define-conventions (name param ...) rule ...)
-     (begin
+     (let ([params (syntax->list #'(param ...))])
-       (unless (identifier? #'name)
+       (for ([x (syntax->list #'(name param ...))])
-         (raise-syntax-error #f "expected identifier" stx #'name))
+         (unless (identifier? x)
-       (with-syntax ([([entry (def ...)] ...)
+           (raise-syntax-error #f "expected identifier" stx x)))
-                      (for/list ([line (check-conventions-rules #'(rule ...) stx)])
+       (let ()
-                        (let ([rx (car line)]
+         (define rules (check-conventions-rules #'(rule ...) stx))
-                              [den (cadr line)])
+         (define rxs (map car rules))
-                          (let-values ([(den defs) (create-aux-def den)])
+         (define dens0 (map cadr rules))
-                            (list #`(list (quote #,rx)
+         (define den+defs-list
-                                          (make-den:delayed
+           (for/list ([den0 dens0])
-                                           (quote-syntax #,(den:delayed-parser den))
+             (let-values ([(den defs) (create-aux-def den0)])
-                                           (quote-syntax #,(den:delayed-description den))
+               (cons den defs))))
-                                           (quote-syntax #,(den:delayed-class den))))
+         (define dens (map car den+defs-list))
-                                  defs))))])
+         (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)