updated syntax/parse/exp./splicing, updated honu use

fixed stress.rkt

collects/honu/private/parse.rkt

@@ -4,7 +4,7 @@
          "util.ss"
          (for-template "literals.ss")
          syntax/parse
-         syntax/parse/experimental
+         syntax/parse/experimental/splicing
          scheme/splicing
          syntax/stx
          (for-syntax "util.ss")
@@ -34,7 +34,7 @@
        [else (loop (stx-cdr start) (add1 count))]))))
 
 (define-primitive-splicing-syntax-class (honu-expr context)
-  #:attrs (result)
+  #:attributes (result)
   #:description "honu-expr"
   (lambda (stx fail)
     (cond
@@ -42,11 +42,11 @@
      [(get-transformer stx) => (lambda (transformer)
                                  (let-values ([(used rest)
                                                (transformer stx context)])
-                                   (list rest (syntax-object-position stx rest)
+                                   (list (syntax-object-position stx rest)
                                          used)))]
      
      [else (syntax-case stx ()
-                        [(f . rest) (list #'rest 1 #'f)])])))
+                        [(f . rest) (list 1 #'f)])])))
 
     #;
     (define-splicing-syntax-class expr

collects/syntax/parse/experimental.rkt

@@ -1,3 +0,0 @@
-#lang racket/base
-(require "experimental/splicing.rkt")
-(provide (all-from-out "experimental/splicing.rkt"))

collects/syntax/parse/experimental/splicing.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 (require (for-syntax racket/base
                      "../../parse.ss"
+                     "../private/rep-attrs.rkt"
                      "../private/rep-data.rkt"
                      "../private/kws.rkt")
          "../private/runtime-progress.rkt"
@@ -16,7 +17,7 @@
 
   (syntax-parse stx
     [(dssp (name:id param:id ...)
-       (~or (~once (~seq #:attrs (a:attr ...))
+       (~or (~once (~seq #:attributes (a:attr ...))
                    #:name "attributes declaration")
             (~once (~seq #:description description)
                    #:name "description declaration")) ...
@@ -25,6 +26,7 @@
          (define (get-description param ...)
            description)
          (define parser
+           (let ([permute (mk-permute '(a.name ...))])
              (lambda (x cx pr es fh cp success param ...)
                (let ([stx (datum->syntax cx x cx)])
                  (let ([result
@@ -36,36 +38,51 @@
                    (case (car result)
                      ((ok)
                       (apply success
-                           ((mk-check-result pr 'name '(a.name ...) x cx fh cp) (cdr result))))
+                             ((mk-check-result pr 'name (length '(a.name ...)) permute x cx fh cp)
+                              (cdr result))))
                      ((error)
                       (let ([es
                              (list* (cons (expect:thing (get-description param ...) #f) stx)
                                     (cons (expect:message (cadr result)) (caddr result))
                                     es)])
-                      (fh (failure pr es)))))))))
+                        (fh (failure pr es))))))))))
          (define-syntax name
-           (make-stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
+           (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
-                          '(#s(attr a.name a.depth #f) ...)
+                     (sort-sattrs '(#s(attr a.name a.depth #f) ...))
                      (quote-syntax parser)
                      #t
                      #s(options #t #t)
                      #f)))]))
 
-(define (mk-check-result pr name attr-names x cx fh cp)
+(define (mk-permute unsorted-attrs)
+  (let ([sorted-attrs
+         (sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)])
+    (if (equal? unsorted-attrs sorted-attrs)
+        values
+        (let* ([pos-table
+                (for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)])
+                  (values a i))]
+               [indexes
+                (for/vector ([a (in-list sorted-attrs)])
+                  (hash-ref pos-table a))])
+          (lambda (result)
+            (for/list ([index (in-vector indexes)])
+              (list-ref result index)))))))
+
+(define (mk-check-result pr name attr-count permute x cx fh cp)
   (lambda (result)
     (unless (list? result)
       (error name "parser returned non-list"))
     (let ([rlength (length result)])
-      (unless (= rlength (+ 2 (length attr-names)))
+      (unless (= rlength (+ 1 attr-count))
         (error name "parser returned list of wrong length; expected length ~s, got ~e"
-               (+ 2 (length attr-names))
+               (+ 1 attr-count)
                result))
-      ;; Ignore (car result), supposed to be rest-x
+      (let ([skip (car result)])
-      ;; Easier to recompute it and get rest-cx right, too.
+        ;; Compute rest-x & rest-cx from skip
-      (let ([skip (cadr result)])
         (unless (exact-nonnegative-integer? skip)
-          (error name "expected exact nonnegative integer for second element of result list, got ~e"
+          (error name "expected exact nonnegative integer for first element of result list, got ~e"
                  skip))
         (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
           (list* fh cp rest-x rest-cx (ps-add-cdr pr skip)
-                 (cddr result)))))))
+                 (permute (cdr result))))))))

collects/syntax/scribblings/parse/experimental.scrbl

@@ -176,17 +176,16 @@ Like @scheme[~reflect] but for reified splicing syntax classes.
            parser-expr)
           #:contracts ([parser (-> syntax?
                                    (->* () ((or/c string? #f) -> any))
-                                   (list syntax? exact-positive-integer? any/c ...))])]{
+                                   (cons/c exact-positive-integer? list?))])]{
 
 Defines a splicing syntax via a procedural parser.
 
 The parser procedure is given two arguments, the syntax to parse and a
 failure procedure. To signal a successful parse, the parser procedure
-returns a list of 2+@scheme[N] elements, where @scheme[N] is the
+returns a list of @scheme[N]+1 elements, where @scheme[N] is the
 number of attributes declared by the splicing syntax class. The first
-two elements are the unconsumed part of the syntax and the size of the
+element is the size of the prefix consumed. The rest of the list
-prefix consumed. The rest of the list contains the values of the
+contains the values of the attributes.
-attributes.
 
 To indicate failure, the parser calls the failure procedure with an
 optional message argument.

collects/tests/stxparse/stress.rkt

@@ -1,3 +1,5 @@
+#lang racket
+
 (begin
   (require syntax/parse)
   (define (mkstx n) (datum->syntax #f (for/list ([i (in-range n)]) #'hello)))
@@ -96,10 +98,11 @@ cpu time: 2908 real time: 2901 gc time: 12
 |#
 
 
-
+#|
 given pattern (E ...) where E = A _ | A
 the sequence (A A B A A B A A B ...)
 causes each E to backtrack
+|#
 
 (begin
   (define-syntax-class id/nat
@@ -132,6 +135,8 @@ causes each E to backtrack
 
 ;; (solve 35 _) and (solve 36 _) seem manageable
 
+#|
+
 #| before markparams |#
 
 > (time (parse/trip tripstx3 100))
@@ -246,3 +251,4 @@ cpu time: 588 real time: 588 gc time: 76
 cpu time: 580 real time: 584 gc time: 68
 > (time (solve 36 20))
 cpu time: 580 real time: 586 gc time: 56
+|#