fixed includes & paths

6-11/racket/collects/syntax/parse/define.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     stxparse-info/parse
+                     "private/sc.rkt"))
+(provide define-simple-macro
+         define-syntax-parser
+         (for-syntax (all-from-out stxparse-info/parse)))
+
+(define-syntax (define-simple-macro stx)
+  (syntax-parse stx
+    [(define-simple-macro (~and (macro:id . _) pattern) . body)
+     #`(define-syntax macro
+         (syntax-parser/template
+          #,((make-syntax-introducer) stx)
+          [pattern . body]))]))
+
+(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
+  (define-syntax macro
+    (syntax-parser option-or-clause ...)))
+

6-11/racket/collects/syntax/parse/experimental/dset.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+;; A dset is an `equal?`-based set, but it preserves order based on
+;; the history of additions, so that if items are added in a
+;; deterministic order, they come back out in a deterministic order.
+
+(provide dset
+         dset-empty?
+         dset->list
+         dset-add
+         dset-union
+         dset-subtract
+         dset-filter)
+
+(define dset
+  (case-lambda
+    [() (hash)]
+    [(e) (hash e 0)]))
+
+(define (dset-empty? ds)
+  (zero? (hash-count ds)))
+
+(define (dset->list ds)
+  (map cdr
+       (sort (for/list ([(k v) (in-hash ds)])
+               (cons v k))
+             <
+             #:key car)))
+
+(define (dset-add ds e)
+  (if (hash-ref ds e #f)
+      ds
+      (hash-set ds e (hash-count ds))))
+
+(define (dset-union ds1 ds2)
+  (cond
+   [((hash-count ds1) . > . (hash-count ds2))
+    (dset-union ds2 ds1)]
+   [else
+    (for/fold ([ds2 ds2]) ([e (dset->list ds1)])
+      (dset-add ds2 e))]))
+
+(define (dset-subtract ds1 ds2)
+  ;; ! takes O(size(ds2)) time !
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
+    (if (hash-ref ds2 e #f)
+        r
+        (dset-add r e))))
+
+(define (dset-filter ds pred)
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
+    (if (pred e)
+        (dset-add r e)
+        r)))

6-11/racket/collects/syntax/parse/experimental/eh.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require "../private/sc.rkt"
+         syntax/parse/private/keywords)
+(provide ~eh-var
+         define-eh-alternative-set)

6-11/racket/collects/syntax/parse/lib/function-header.rkt

@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require "../../parse.rkt"
+         "../experimental/template.rkt"
+         racket/dict)
+
+(provide function-header formal formals)
+
+(define-syntax-class function-header
+  (pattern ((~or header:function-header name:id) . args:formals)
+           #:attr params
+           (template ((?@ . (?? header.params ()))
+                      . args.params))))
+
+(define-syntax-class formals
+  #:attributes (params)
+  (pattern (arg:formal ...)
+           #:attr params #'(arg.name ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing")
+  (pattern (arg:formal ... . rest:id)
+           #:attr params #'(arg.name ... rest)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing"))
+
+(define-splicing-syntax-class formal
+  #:attributes (name kw default)
+  (pattern name:id
+           #:attr kw #f
+           #:attr default #f)
+  (pattern [name:id default]
+           #:attr kw #f)
+  (pattern (~seq kw:keyword name:id)
+           #:attr default #f)
+  (pattern (~seq kw:keyword [name:id default])))
+
+;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
+;; Checks for mandatory argument after optional argument; if found, returns
+;; identifier of mandatory argument.
+(define (invalid-option-placement names defaults)
+  ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
+  ;; Finds first name w/o corresponding default.
+  (define (find-mandatory names defaults)
+    (for/first ([name (in-list names)]
+                [default (in-list defaults)]
+                #:when (not default))
+      name))
+  ;; Skip through mandatory args until first optional found, then search
+  ;; for another mandatory.
+  (let loop ([names names] [defaults defaults])
+    (cond [(or (null? names) (null? defaults))
+           #f]
+          [(eq? (car defaults) #f) ;; mandatory
+           (loop (cdr names) (cdr defaults))]
+          [else ;; found optional
+           (find-mandatory (cdr names) (cdr defaults))])))
+
+;; Copied from unstable/list
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))

6-11/racket/collects/syntax/parse/private/3d-stx.rkt

@@ -0,0 +1,250 @@
+#lang racket/base
+(require (only-in '#%flfxnum flvector? fxvector?)
+         (only-in '#%extfl extflonum? extflvector?))
+(provide 2d-stx?
+         check-datum)
+
+;; Checks for 3D syntax (syntax that contains unwritable values, etc)
+
+(define INIT-FUEL #e1e6)
+
+;; TO DO:
+;; - extension via proc (any -> list/#f),
+;;   value considered good if result is list, all values in list are good
+
+;; --
+
+#|
+Some other predicates one might like to have:
+ - would (read (write x)) succeed and be equal/similar to x?
+ - would (datum->syntax #f x) succeed?
+ - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
+ - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
+
+where equal/similar could mean one of the following:
+ - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
+ - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
+ - equal? but also requiring same mutability at every point
+
+Some aux definitions:
+
+(define (rt x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (read in))
+
+(define (wrsd x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (syntax->datum (read-syntax #f in)))
+
+(define (dsd x)
+  (syntax->datum (datum->syntax #f x)))
+
+(define (evalc x) ;; mimics compiled zo-file constraints
+  (eval (rt (compile `(quote ,x)))))
+
+How mutability behaves:
+ - for vectors, boxes:
+   - read always mutable
+   - read-syntax always immutable
+   - (dsd x) always immutable
+   - (evalc x) always immutable
+ - for hashes:
+   - read always immutable
+   - (dsd x) same as x
+   - (evalc x) always immutable (!!!)
+ - for prefab structs:
+   - read same as x
+   - read-syntax same as x
+   - (dsd x) same as x
+   - (evalc x) same as x
+
+Symbols
+ - (dsd x) same as x
+ - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
+
+Chaperones allow the lazy generation of infinite trees of data
+undetectable by eq?-based cycle detection.  Might be helpful to have
+chaperone-eq? (not recursive, just chaperones of same object) and
+chaperone-eq?-hash-code, to use with make-custom-hash.)
+
+Impersonators allow the lazy generation of infinite trees of data,
+period.
+
+|#
+
+;; ----
+
+;; 2d-stx? : any ... -> boolean
+;; Would (write (compile `(quote-syntax ,x))) succeed?
+;; If traverse-syntax? is #t, recurs into existing syntax
+;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
+;; checks if *new* 3d syntax would be created.
+(define (2d-stx? x
+                 #:traverse-syntax? [traverse-syntax? #t]
+                 #:irritant [irritant-box #f])
+  (check-datum x
+               #:syntax-mode (if traverse-syntax? 'compound 'atomic)
+               #:allow-impersonators? #f
+               #:allow-mutable? 'no-hash/prefab
+               #:allow-unreadable-symbols? #t
+               #:allow-cycles? #t
+               #:irritant irritant-box))
+
+;; ----
+
+;; check-datum : any ... -> boolean
+;; where StxMode = (U 'atomic 'compound #f)
+;; Returns nat if x is "good", #f if "bad"
+;; If irritant-b is a box, the first bad subvalue found is put in the box.
+;; If visited-t is a hash, it is used to detect cycles.
+(define (check-datum x
+                     #:syntax-mode [stx-mode #f]
+                     #:allow-impersonators? [allow-impersonators? #f]
+                     #:allow-mutable? [allow-mutable? #f]
+                     #:allow-unreadable-symbols? [allow-unreadable? #f]
+                     #:allow-cycles? [allow-cycles? #f]
+                     #:irritant [irritant-b #f])
+  ;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
+  (define (run fuel visited-t)
+    (check* x fuel visited-t
+            stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+            irritant-b))
+  (let ([result (run INIT-FUEL #f)])
+    (cond [(not (equal? result 0)) ;; nat>0 or #f
+           (and result #t)]
+          [else
+           ;; (eprintf "out of fuel, restarting\n")
+           (and (run +inf.0 (make-hasheq)) #t)])))
+
+;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
+;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
+;; If bad, places bad subvalue in irritant-b, if box
+(define (check* x0 fuel0 visited-t
+                stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+                irritant-b)
+  (define no-mutable? (not allow-mutable?))
+  (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
+  (define no-cycle? (not allow-cycles?))
+  (define no-impersonator? (not allow-impersonators?))
+  (define (loop x fuel)
+    (if (and fuel (not (zero? fuel)))
+        (loop* x fuel)
+        fuel))
+  (define (loop* x fuel)
+    (define (bad) (when irritant-b (set-box! irritant-b x)) #f)
+    (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
+      (cond [(and no-mutable? mutable?)
+             (bad)]
+            [else
+             body ...]))
+    (define-syntax-rule (with-cycle-check body ...)
+      (cond [(and visited-t (hash-ref visited-t x #f))
+             => (lambda (status)
+                  (cond [(and no-cycle? (eq? status 'traversing))
+                         (bad)]
+                        [else
+                         fuel]))]
+            [else
+             (when visited-t
+               (hash-set! visited-t x 'traversing))
+             (begin0 (begin body ...)
+               (when visited-t
+                 (hash-remove! visited-t x)))]))
+    ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
+    (cond
+     ;; Immutable compound
+     [(and visited-t (list? x))
+      ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
+      ;; don't do unless visited-t present, else expands fuel by arbitrary factors
+      (with-cycle-check
+       (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
+         (loop e fuel)))]
+     [(pair? x)
+      (with-cycle-check
+       (let ([fuel (loop (car x) (sub1 fuel))])
+         (loop (cdr x) fuel)))]
+     ;; Atomic
+     [(or (null? x)
+          (boolean? x)
+          (number? x)
+          (char? x)
+          (keyword? x)
+          (regexp? x)
+          (byte-regexp? x)
+          (extflonum? x))
+      fuel]
+     [(symbol? x)
+      (cond [(symbol-interned? x)
+             fuel]
+            [(symbol-unreadable? x)
+             (if allow-unreadable? fuel (bad))]
+            [else ;; uninterned
+             (if (eq? allow-unreadable? #t) fuel (bad))])]
+     ;; Mutable flat
+     [(or (string? x)
+          (bytes? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     [(or (fxvector? x)
+          (flvector? x)
+          (extflvector? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     ;; Syntax
+     [(syntax? x)
+      (case stx-mode
+        ((atomic) fuel)
+        ((compound) (loop (syntax-e x) fuel))
+        (else (bad)))]
+     ;; Impersonators and chaperones
+     [(and no-impersonator? (impersonator? x))  ;; else continue to chaperoned type
+      (bad)]
+     [(and no-impersonator? (chaperone? x))  ;; else continue to impersonated type
+      (bad)]
+     [else
+      (with-cycle-check
+       (cond
+        ;; Mutable (maybe) compound
+        [(vector? x)
+         (with-mutable-check (not (immutable? x))
+           (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
+             (loop e fuel)))]
+        [(box? x)
+         (with-mutable-check (not (immutable? x))
+           (loop (unbox x) (sub1 fuel)))]
+        [(prefab-struct-key x)
+         => (lambda (key)
+              (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
+                     (bad)]
+                    [else
+                     ;; traverse key, since contains arbitrary auto-value
+                     (let ([fuel (loop key fuel)])
+                       (loop (struct->vector x) fuel))]))]
+        [(hash? x)
+         (cond [(and no-mutable-hash/prefab? (not (immutable? x)))
+                (bad)]
+               [else
+                (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
+                  (let ([fuel (loop k fuel)])
+                    (loop v fuel)))])]
+        ;; Bad
+        [else
+         (bad)]))]))
+  (loop x0 fuel0))
+
+;; mutable-prefab-key? : prefab-key -> boolean
+(define (mutable-prefab-key? key)
+  ;; A prefab-key is either
+  ;;  - symbol
+  ;;  - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
+  ;; where mutable fields indicated by vector
+  ;; This code is probably overly general; racket seems to normalize keys.
+  (let loop ([k key])
+    (and (pair? k)
+         (or (and (vector? (car k))
+                  (positive? (vector-length (car k))))
+             (loop (cdr k))))))

6-11/racket/collects/syntax/parse/private/litconv.rkt

@@ -0,0 +1,284 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/lazy-require
+                     "sc.rkt"
+                     "lib.rkt"
+                     syntax/parse/private/kws
+                     racket/syntax)
+         syntax/parse/private/residual-ct ;; keep abs. path
+         stxparse-info/parse/private/residual)   ;; keep abs. path
+(begin-for-syntax
+ (lazy-require
+  [syntax/private/keyword (options-select-value parse-keyword-options)]
+  [stxparse-info/parse/private/rep ;; keep abs. path
+   (parse-kw-formals
+    check-conventions-rules
+    check-datum-literals-list
+    create-aux-def)]))
+;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
+;; Without this, dependencies don't get collected.
+(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
+
+(provide define-conventions
+         define-literal-set
+         literal-set->predicate
+         kernel-literals)
+
+(define-syntax (define-conventions stx)
+
+  (define-syntax-class header
+    #:description "name or name with formal parameters"
+    #:commit
+    (pattern name:id
+             #:with formals #'()
+             #:attr arity (arity 0 0 null null))
+    (pattern (name:id . formals)
+             #:attr arity (parse-kw-formals #'formals #:context stx)))
+
+  (syntax-parse stx
+    [(define-conventions h:header rule ...)
+     (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 (in-list 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 (class-name ...)
+         (map den:delayed-class dens))
+
+       ;; FIXME: could move make-den:delayed to user of conventions
+       ;; and eliminate from residual.rkt
+       #'(begin
+           (define-syntax h.name
+             (make-conventions
+              (quote-syntax get-parsers)
+              (lambda ()
+                (let ([class-names (list (quote-syntax class-name) ...)])
+                  (map list
+                       (list 'rx ...)
+                       (map make-den:delayed
+                            (generate-temporaries class-names)
+                            class-names))))))
+           (define get-parsers
+             (lambda formals
+               def ...
+               (list parser ...)))))]))
+
+(define-for-syntax (check-phase-level stx ctx)
+  (unless (or (exact-integer? (syntax-e stx))
+              (eq? #f (syntax-e stx)))
+    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
+  stx)
+
+;; check-litset-list : stx stx -> (listof (cons id literalset))
+(define-for-syntax (check-litset-list stx ctx)
+  (syntax-case stx ()
+    [(litset-id ...)
+     (for/list ([litset-id (syntax->list #'(litset-id ...))])
+       (let* ([val (and (identifier? litset-id)
+                        (syntax-local-value/record litset-id literalset?))])
+         (if val
+             (cons litset-id val)
+             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
+    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
+
+;; check-literal-entry/litset : stx stx -> (list id id)
+(define-for-syntax (check-literal-entry/litset stx ctx)
+  (syntax-case stx ()
+    [(internal external)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external)]
+    [id
+     (identifier? #'id)
+     (list #'id #'id)]
+    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits)
+  (let ([lit-t (make-hasheq)]) ;; sym => #t
+    (define (check+enter! key blame-stx)
+      (when (hash-ref lit-t key #f)
+        (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx))
+      (hash-set! lit-t key #t))
+    (for ([id+litset (in-list imports)])
+      (let ([litset-id (car id+litset)]
+            [litset (cdr id+litset)])
+        (for ([entry (in-list (literalset-literals litset))])
+          (cond [(lse:lit? entry)
+                 (check+enter! (lse:lit-internal entry) litset-id)]
+                [(lse:datum-lit? entry)
+                 (check+enter! (lse:datum-lit-internal entry) litset-id)]))))
+    (for ([datum-lit (in-list datum-lits)])
+      (let ([internal (den:datum-lit-internal datum-lit)])
+        (check+enter! (syntax-e internal) internal)))
+    (for ([lit (in-list lits)])
+      (check+enter! (syntax-e (car lit)) (car lit)))))
+
+(define-syntax (define-literal-set stx)
+  (syntax-case stx ()
+    [(define-literal-set name . rest)
+     (let-values ([(chunks rest)
+                   (parse-keyword-options
+                    #'rest
+                    `((#:literal-sets ,check-litset-list)
+                      (#:datum-literals ,check-datum-literals-list)
+                      (#:phase ,check-phase-level)
+                      (#:for-template)
+                      (#:for-syntax)
+                      (#:for-label))
+                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
+                    #:context stx
+                    #:no-duplicates? #t)])
+       (unless (identifier? #'name)
+         (raise-syntax-error #f "expected identifier" stx #'name))
+       (let ([relphase
+              (cond [(assq '#:for-template chunks) -1]
+                    [(assq '#:for-syntax chunks) 1]
+                    [(assq '#:for-label chunks) #f]
+                    [else (options-select-value chunks '#:phase #:default 0)])]
+             [datum-lits
+              (options-select-value chunks '#:datum-literals #:default null)]
+             [lits (syntax-case rest ()
+                     [( (lit ...) )
+                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
+                        (check-literal-entry/litset lit stx))]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [imports (options-select-value chunks '#:literal-sets #:default null)])
+         (check-duplicate-literals stx imports lits datum-lits)
+         (with-syntax ([((internal external) ...) lits]
+                       [(datum-internal ...) (map den:datum-lit-internal datum-lits)]
+                       [(datum-external ...) (map den:datum-lit-external datum-lits)]
+                       [(litset-id ...) (map car imports)]
+                       [relphase relphase])
+           #`(begin
+               (define phase-of-literals
+                 (and 'relphase
+                      (+ (variable-reference->module-base-phase (#%variable-reference))
+                         'relphase)))
+               (define-syntax name
+                 (make-literalset
+                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
+                          ...
+                          (list (make-lse:lit 'internal
+                                              (quote-syntax external)
+                                              (quote-syntax phase-of-literals))
+                                ...
+                                (make-lse:datum-lit 'datum-internal
+                                                    'datum-external)
+                                ...))))
+               (begin-for-syntax/once
+                (for ([x (in-list (syntax->list #'(external ...)))])
+                  (unless (identifier-binding x 'relphase)
+                    (raise-syntax-error #f
+                                        (format "literal is unbound in phase ~a~a~a"
+                                                'relphase
+                                                (case 'relphase
+                                                  ((1) " (for-syntax)")
+                                                  ((-1) " (for-template)")
+                                                  ((#f) " (for-label)")
+                                                  (else ""))
+                                                " relative to the enclosing module")
+                                        (quote-syntax #,stx) x))))))))]))
+
+#|
+NOTES ON PHASES AND BINDINGS
+
+(module M ....
+  .... (define-literal-set LS #:phase PL ....)
+  ....)
+
+For the expansion of the define-literal-set form, the bindings of the literals
+can be accessed by (identifier-binding lit PL), because the phase of the enclosing
+module (M) is 0.
+
+LS may be used, however, in a context where the phase of the enclosing
+module is not 0, so each instantiation of LS needs to calculate the
+phase of M and add that to PL.
+
+--
+
+Normally, literal sets that define the same name conflict. But it
+would be nice to allow them to both be imported in the case where they
+refer to the same binding.
+
+Problem: Can't do the check eagerly, because the binding of L may
+change between when define-literal-set is compiled and the comparison
+involving L. For example:
+
+  (module M racket
+    (require stxparse-info/parse)
+    (define-literal-set LS (lambda))
+    (require (only-in some-other-lang lambda))
+    .... LS ....)
+
+The expansion of the LS definition sees a different lambda than the
+one that the literal in LS actually refers to.
+
+Similarly, a literal in LS might not be defined when the expander
+runs, but might get defined later. (Although I think that will already
+cause an error, so don't worry about that case.)
+|#
+
+;; FIXME: keep one copy of each identifier (?)
+
+(define-syntax (literal-set->predicate stx)
+  (syntax-case stx ()
+    [(literal-set->predicate litset-id)
+     (let ([val (and (identifier? #'litset-id)
+                     (syntax-local-value/record #'litset-id literalset?))])
+       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
+       (let ([lits (literalset-literals val)])
+         (with-syntax ([((lit phase-var) ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:lit? lit))
+                          (list (lse:lit-external lit) (lse:lit-phase lit)))]
+                       [(datum-lit ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:datum-lit? lit))
+                          (lse:datum-lit-external lit))])
+           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
+                                         '(datum-lit ...)))))]))
+
+(define (make-literal-set-predicate lits datum-lits)
+  (lambda (x [phase (syntax-local-phase-level)])
+    (or (for/or ([lit (in-list lits)])
+          (let ([lit-id (car lit)]
+                [lit-phase (cadr lit)])
+            (free-identifier=? x lit-id phase lit-phase)))
+        (and (memq (syntax-e x) datum-lits) #t))))
+
+;; Literal sets
+
+(define-literal-set kernel-literals
+  (begin
+   begin0
+   define-values
+   define-syntaxes
+   define-values-for-syntax ;; kept for compat.
+   begin-for-syntax
+   set!
+   let-values
+   letrec-values
+   #%plain-lambda
+   case-lambda
+   if
+   quote
+   quote-syntax
+   letrec-syntaxes+values
+   with-continuation-mark
+   #%expression
+   #%plain-app
+   #%top
+   #%datum
+   #%variable-reference
+   module module* #%provide #%require #%declare
+   #%plain-module-begin))

6-11/racket/collects/syntax/parse/private/make.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/struct-info))
+(provide make)
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
+
+;; (make struct-name field-expr ...)
+;; Checks that correct number of fields given.
+(define-syntax (make stx)
+  (syntax-case stx ()
+    [(make S expr ...)
+     (let ()
+       (define info (get-struct-info #'S stx))
+       (define constructor (list-ref info 1))
+       (define accessors (list-ref info 3))
+       (unless (identifier? #'constructor)
+         (raise-syntax-error #f "constructor not available for struct" stx #'S))
+       (unless (andmap identifier? accessors)
+         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
+       (let ([num-slots (length accessors)]
+             [num-provided (length (syntax->list #'(expr ...)))])
+         (unless (= num-provided num-slots)
+           (raise-syntax-error
+            #f
+            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
+                    (syntax-e #'S)
+                    num-slots
+                    num-provided)
+            stx)))
+       (with-syntax ([constructor constructor])
+         (syntax-property #'(constructor expr ...)
+                          'disappeared-use
+                          #'S)))]))

6-11/racket/collects/syntax/parse/private/runtime-progress.rkt

@@ -0,0 +1,257 @@
+#lang racket/base
+(require racket/list
+         syntax/parse/private/minimatch)
+(provide ps-empty
+         ps-add-car
+         ps-add-cdr
+         ps-add-stx
+         ps-add-unbox
+         ps-add-unvector
+         ps-add-unpstruct
+         ps-add-opaque
+         ps-add-post
+         ps-add
+         (struct-out ord)
+
+         ps-pop-opaque
+         ps-pop-ord
+         ps-pop-post
+         ps-context-syntax
+         ps-difference
+
+         (struct-out failure)
+         failure*
+
+         expect?
+         (struct-out expect:thing)
+         (struct-out expect:atom)
+         (struct-out expect:literal)
+         (struct-out expect:message)
+         (struct-out expect:disj)
+         (struct-out expect:proper-pair)
+
+         es-add-thing
+         es-add-message
+         es-add-atom
+         es-add-literal
+         es-add-proper-pair)
+
+;; FIXME: add phase to expect:literal
+
+;; == Failure ==
+
+#|
+A Failure is (failure PS ExpectStack)
+
+A FailureSet is one of
+  - Failure
+  - (cons FailureSet FailureSet)
+
+A FailFunction = (FailureSet -> Answer)
+|#
+(define-struct failure (progress expectstack) #:prefab)
+
+;; failure* : PS ExpectStack/#f -> Failure/#t
+(define (failure* ps es) (if es (failure ps es) #t))
+
+;; == Progress ==
+
+#|
+Progress (PS) is a non-empty list of Progress Frames (PF).
+
+A Progress Frame (PF) is one of
+  - stx     ;; "Base" frame, or ~parse/#:with term
+  - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
+  - nat     ;; Represents that many repeated cdrs
+  - 'post   ;; late/post-traversal check
+  - #s(ord group index) ;; ~and subpattern, only comparable w/in group
+  - 'opaque
+
+The error-reporting context (ie, syntax-parse #:context arg) is always
+the final frame.
+
+All non-stx frames (eg car, cdr) interpreted as applying to nearest following
+stx frame.
+
+A stx frame is introduced
+  - always at base (that is, by syntax-parse)
+    - if syntax-parse has #:context arg, then two stx frames at bottom:
+      (list to-match-stx context-stx)
+  - by #:with/~parse
+  - by #:fail-*/#:when/~fail & stx
+
+Interpretation: later frames are applied first.
+ eg, (list 'car 1 stx)
+      means ( car of ( cdr once of stx ) )
+      NOT apply car, then apply cdr once, then stop
+|#
+(define-struct ord (group index) #:prefab)
+
+(define (ps-empty stx ctx)
+  (if (eq? stx ctx)
+      (list stx)
+      (list stx ctx)))
+(define (ps-add-car parent)
+  (cons 'car parent))
+(define (ps-add-cdr parent [times 1])
+  (if (zero? times)
+      parent
+      (match (car parent)
+        [(? exact-positive-integer? n)
+         (cons (+ times n) (cdr parent))]
+        [_
+         (cons times parent)])))
+(define (ps-add-stx parent stx)
+  (cons stx parent))
+(define (ps-add-unbox parent)
+  (ps-add-car parent))
+(define (ps-add-unvector parent)
+  (ps-add-car parent))
+(define (ps-add-unpstruct parent)
+  (ps-add-car parent))
+(define (ps-add-opaque parent)
+  (cons 'opaque parent))
+(define (ps-add parent frame)
+  (cons frame parent))
+(define (ps-add-post parent)
+  (cons 'post parent))
+
+;; ps-context-syntax : Progress -> syntax
+(define (ps-context-syntax ps)
+  ;; Bottom frame is always syntax
+  (last ps))
+
+;; ps-difference : PS PS -> nat
+;; Returns N s.t. B = (ps-add-cdr^N A)
+(define (ps-difference a b)
+  (define-values (a-cdrs a-base)
+    (match a
+      [(cons (? exact-positive-integer? a-cdrs) a-base)
+       (values a-cdrs a-base)]
+      [_ (values 0 a)]))
+  (define-values (b-cdrs b-base)
+    (match b
+      [(cons (? exact-positive-integer? b-cdrs) b-base)
+       (values b-cdrs b-base)]
+      [_ (values 0 b)]))
+  (unless (eq? a-base b-base)
+    (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
+  (- b-cdrs a-cdrs))
+
+;; ps-pop-opaque : PS -> PS
+;; Used to continue with progress from opaque head pattern.
+(define (ps-pop-opaque ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'opaque ps*)
+     ps*]
+    [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
+
+;; ps-pop-ord : PS -> PS
+(define (ps-pop-ord ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
+     (ps-add-cdr ps* n)]
+    [(cons (? ord?) ps*)
+     ps*]
+    [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
+
+;; ps-pop-post : PS -> PS
+(define (ps-pop-post ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'post ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'post ps*)
+     ps*]
+    [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
+
+
+;; == Expectations ==
+
+#|
+There are multiple types that use the same structures, optimized for
+different purposes.
+
+-- During parsing, the goal is to minimize/consolidate allocations.
+
+An ExpectStack (during parsing) is one of
+  - (expect:thing Progress String Boolean String/#f ExpectStack)
+  * (expect:message String ExpectStack)
+  * (expect:atom Datum ExpectStack)
+  * (expect:literal Identifier ExpectStack)
+  * (expect:proper-pair FirstDesc ExpectStack)
+  * #t
+
+The *-marked variants can only occur at the top of the stack (ie, not
+in the next field of another Expect). The top of the stack contains
+the most specific information.
+
+An ExpectStack can also be #f, which means no failure tracking is
+requested (and thus no more ExpectStacks should be allocated).
+
+-- During reporting, the goal is ease of manipulation.
+
+An ExpectList (during reporting) is (listof Expect).
+
+An Expect is one of
+  - (expect:thing #f String #t String/#f StxIdx)
+  * (expect:message String StxIdx)
+  * (expect:atom Datum StxIdx)
+  * (expect:literal Identifier StxIdx)
+  * (expect:proper-pair FirstDesc StxIdx)
+  * (expect:disj (NEListof Expect) StxIdx)
+  - '...
+
+A StxIdx is (cons Syntax Nat)
+
+That is, the next link is replaced with the syntax+index of the term
+being complained about. An expect:thing's progress is replaced with #f.
+
+An expect:disj never contains a '... or another expect:disj.
+
+We write ExpectList when the most specific information comes first and
+RExpectList when the most specific information comes last.
+|#
+(struct expect:thing (term description transparent? role next) #:prefab)
+(struct expect:message (message next) #:prefab)
+(struct expect:atom (atom next) #:prefab)
+(struct expect:literal (literal next) #:prefab)
+(struct expect:disj (expects next) #:prefab)
+(struct expect:proper-pair (first-desc next) #:prefab)
+
+(define (expect? x)
+  (or (expect:thing? x)
+      (expect:message? x)
+      (expect:atom? x)
+      (expect:literal? x)
+      (expect:disj? x)
+      (expect:proper-pair? x)))
+
+(define (es-add-thing ps description transparent? role next)
+  (if (and next description)
+      (expect:thing ps description transparent? role next)
+      next))
+
+(define (es-add-message message next)
+  (if (and next message)
+      (expect:message message next)
+      next))
+
+(define (es-add-atom atom next)
+  (and next (expect:atom atom next)))
+
+(define (es-add-literal literal next)
+  (and next (expect:literal literal next)))
+
+(define (es-add-proper-pair first-desc next)
+  (and next (expect:proper-pair first-desc next)))
+
+#|
+A FirstDesc is one of
+ - #f                   -- unknown, multiple possible, etc
+ - string               -- description
+ - (list 'any)
+ - (list 'literal symbol)
+ - (list 'datum datum)
+|#

6-11/racket/collects/syntax/parse/private/txlift.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+(require (for-template racket/base))
+(provide txlift
+         get-txlifts-as-definitions
+         with-txlifts
+         call/txlifts)
+
+;; Like lifting definitions, but within a single transformer.
+
+;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))]
+(define current-liftbox (make-parameter #f))
+
+(define (call/txlifts proc)
+  (parameterize ((current-liftbox (box null)))
+    (proc)))
+
+(define (txlift expr)
+  (let ([liftbox (current-liftbox)])
+    (check 'txlift liftbox)
+    (let ([var (car (generate-temporaries '(txlift)))])
+      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
+      var)))
+
+(define (get-txlifts)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts liftbox)
+    (reverse (unbox liftbox))))
+
+(define (get-txlifts-as-definitions)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts-as-definitions liftbox)
+    (map (lambda (p)
+           #`(define #,@p))
+         (reverse (unbox liftbox)))))
+
+(define (check who lb)
+  (unless (box? lb)
+    (error who "not in a txlift-catching context")))
+
+(define (with-txlifts proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([((var rhs) ...) (get-txlifts)])
+         #`(let* ([var rhs] ...) #,v))))))

6-12/racket/collects/syntax/parse/define.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     stxparse-info/parse
+                     "private/sc.rkt"))
+(provide define-simple-macro
+         define-syntax-parser
+         (for-syntax (all-from-out stxparse-info/parse)))
+
+(define-syntax (define-simple-macro stx)
+  (syntax-parse stx
+    [(define-simple-macro (~and (macro:id . _) pattern) . body)
+     #`(define-syntax macro
+         (syntax-parser/template
+          #,((make-syntax-introducer) stx)
+          [pattern . body]))]))
+
+(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
+  (define-syntax macro
+    (syntax-parser option-or-clause ...)))
+

6-12/racket/collects/syntax/parse/experimental/dset.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+;; A dset is an `equal?`-based set, but it preserves order based on
+;; the history of additions, so that if items are added in a
+;; deterministic order, they come back out in a deterministic order.
+
+(provide dset
+         dset-empty?
+         dset->list
+         dset-add
+         dset-union
+         dset-subtract
+         dset-filter)
+
+(define dset
+  (case-lambda
+    [() (hash)]
+    [(e) (hash e 0)]))
+
+(define (dset-empty? ds)
+  (zero? (hash-count ds)))
+
+(define (dset->list ds)
+  (map cdr
+       (sort (for/list ([(k v) (in-hash ds)])
+               (cons v k))
+             <
+             #:key car)))
+
+(define (dset-add ds e)
+  (if (hash-ref ds e #f)
+      ds
+      (hash-set ds e (hash-count ds))))
+
+(define (dset-union ds1 ds2)
+  (cond
+   [((hash-count ds1) . > . (hash-count ds2))
+    (dset-union ds2 ds1)]
+   [else
+    (for/fold ([ds2 ds2]) ([e (dset->list ds1)])
+      (dset-add ds2 e))]))
+
+(define (dset-subtract ds1 ds2)
+  ;; ! takes O(size(ds2)) time !
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
+    (if (hash-ref ds2 e #f)
+        r
+        (dset-add r e))))
+
+(define (dset-filter ds pred)
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
+    (if (pred e)
+        (dset-add r e)
+        r)))

6-12/racket/collects/syntax/parse/experimental/eh.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require "../private/sc.rkt"
+         syntax/parse/private/keywords)
+(provide ~eh-var
+         define-eh-alternative-set)

6-12/racket/collects/syntax/parse/lib/function-header.rkt

@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require "../../parse.rkt"
+         "../experimental/template.rkt"
+         racket/dict)
+
+(provide function-header formal formals)
+
+(define-syntax-class function-header
+  (pattern ((~or header:function-header name:id) . args:formals)
+           #:attr params
+           (template ((?@ . (?? header.params ()))
+                      . args.params))))
+
+(define-syntax-class formals
+  #:attributes (params)
+  (pattern (arg:formal ...)
+           #:attr params #'(arg.name ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing")
+  (pattern (arg:formal ... . rest:id)
+           #:attr params #'(arg.name ... rest)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing"))
+
+(define-splicing-syntax-class formal
+  #:attributes (name kw default)
+  (pattern name:id
+           #:attr kw #f
+           #:attr default #f)
+  (pattern [name:id default]
+           #:attr kw #f)
+  (pattern (~seq kw:keyword name:id)
+           #:attr default #f)
+  (pattern (~seq kw:keyword [name:id default])))
+
+;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
+;; Checks for mandatory argument after optional argument; if found, returns
+;; identifier of mandatory argument.
+(define (invalid-option-placement names defaults)
+  ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
+  ;; Finds first name w/o corresponding default.
+  (define (find-mandatory names defaults)
+    (for/first ([name (in-list names)]
+                [default (in-list defaults)]
+                #:when (not default))
+      name))
+  ;; Skip through mandatory args until first optional found, then search
+  ;; for another mandatory.
+  (let loop ([names names] [defaults defaults])
+    (cond [(or (null? names) (null? defaults))
+           #f]
+          [(eq? (car defaults) #f) ;; mandatory
+           (loop (cdr names) (cdr defaults))]
+          [else ;; found optional
+           (find-mandatory (cdr names) (cdr defaults))])))
+
+;; Copied from unstable/list
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))

6-12/racket/collects/syntax/parse/private/3d-stx.rkt

@@ -0,0 +1,250 @@
+#lang racket/base
+(require (only-in '#%flfxnum flvector? fxvector?)
+         (only-in '#%extfl extflonum? extflvector?))
+(provide 2d-stx?
+         check-datum)
+
+;; Checks for 3D syntax (syntax that contains unwritable values, etc)
+
+(define INIT-FUEL #e1e6)
+
+;; TO DO:
+;; - extension via proc (any -> list/#f),
+;;   value considered good if result is list, all values in list are good
+
+;; --
+
+#|
+Some other predicates one might like to have:
+ - would (read (write x)) succeed and be equal/similar to x?
+ - would (datum->syntax #f x) succeed?
+ - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
+ - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
+
+where equal/similar could mean one of the following:
+ - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
+ - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
+ - equal? but also requiring same mutability at every point
+
+Some aux definitions:
+
+(define (rt x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (read in))
+
+(define (wrsd x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (syntax->datum (read-syntax #f in)))
+
+(define (dsd x)
+  (syntax->datum (datum->syntax #f x)))
+
+(define (evalc x) ;; mimics compiled zo-file constraints
+  (eval (rt (compile `(quote ,x)))))
+
+How mutability behaves:
+ - for vectors, boxes:
+   - read always mutable
+   - read-syntax always immutable
+   - (dsd x) always immutable
+   - (evalc x) always immutable
+ - for hashes:
+   - read always immutable
+   - (dsd x) same as x
+   - (evalc x) always immutable (!!!)
+ - for prefab structs:
+   - read same as x
+   - read-syntax same as x
+   - (dsd x) same as x
+   - (evalc x) same as x
+
+Symbols
+ - (dsd x) same as x
+ - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
+
+Chaperones allow the lazy generation of infinite trees of data
+undetectable by eq?-based cycle detection.  Might be helpful to have
+chaperone-eq? (not recursive, just chaperones of same object) and
+chaperone-eq?-hash-code, to use with make-custom-hash.)
+
+Impersonators allow the lazy generation of infinite trees of data,
+period.
+
+|#
+
+;; ----
+
+;; 2d-stx? : any ... -> boolean
+;; Would (write (compile `(quote-syntax ,x))) succeed?
+;; If traverse-syntax? is #t, recurs into existing syntax
+;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
+;; checks if *new* 3d syntax would be created.
+(define (2d-stx? x
+                 #:traverse-syntax? [traverse-syntax? #t]
+                 #:irritant [irritant-box #f])
+  (check-datum x
+               #:syntax-mode (if traverse-syntax? 'compound 'atomic)
+               #:allow-impersonators? #f
+               #:allow-mutable? 'no-hash/prefab
+               #:allow-unreadable-symbols? #t
+               #:allow-cycles? #t
+               #:irritant irritant-box))
+
+;; ----
+
+;; check-datum : any ... -> boolean
+;; where StxMode = (U 'atomic 'compound #f)
+;; Returns nat if x is "good", #f if "bad"
+;; If irritant-b is a box, the first bad subvalue found is put in the box.
+;; If visited-t is a hash, it is used to detect cycles.
+(define (check-datum x
+                     #:syntax-mode [stx-mode #f]
+                     #:allow-impersonators? [allow-impersonators? #f]
+                     #:allow-mutable? [allow-mutable? #f]
+                     #:allow-unreadable-symbols? [allow-unreadable? #f]
+                     #:allow-cycles? [allow-cycles? #f]
+                     #:irritant [irritant-b #f])
+  ;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
+  (define (run fuel visited-t)
+    (check* x fuel visited-t
+            stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+            irritant-b))
+  (let ([result (run INIT-FUEL #f)])
+    (cond [(not (equal? result 0)) ;; nat>0 or #f
+           (and result #t)]
+          [else
+           ;; (eprintf "out of fuel, restarting\n")
+           (and (run +inf.0 (make-hasheq)) #t)])))
+
+;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
+;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
+;; If bad, places bad subvalue in irritant-b, if box
+(define (check* x0 fuel0 visited-t
+                stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+                irritant-b)
+  (define no-mutable? (not allow-mutable?))
+  (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
+  (define no-cycle? (not allow-cycles?))
+  (define no-impersonator? (not allow-impersonators?))
+  (define (loop x fuel)
+    (if (and fuel (not (zero? fuel)))
+        (loop* x fuel)
+        fuel))
+  (define (loop* x fuel)
+    (define (bad) (when irritant-b (set-box! irritant-b x)) #f)
+    (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
+      (cond [(and no-mutable? mutable?)
+             (bad)]
+            [else
+             body ...]))
+    (define-syntax-rule (with-cycle-check body ...)
+      (cond [(and visited-t (hash-ref visited-t x #f))
+             => (lambda (status)
+                  (cond [(and no-cycle? (eq? status 'traversing))
+                         (bad)]
+                        [else
+                         fuel]))]
+            [else
+             (when visited-t
+               (hash-set! visited-t x 'traversing))
+             (begin0 (begin body ...)
+               (when visited-t
+                 (hash-remove! visited-t x)))]))
+    ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
+    (cond
+     ;; Immutable compound
+     [(and visited-t (list? x))
+      ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
+      ;; don't do unless visited-t present, else expands fuel by arbitrary factors
+      (with-cycle-check
+       (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
+         (loop e fuel)))]
+     [(pair? x)
+      (with-cycle-check
+       (let ([fuel (loop (car x) (sub1 fuel))])
+         (loop (cdr x) fuel)))]
+     ;; Atomic
+     [(or (null? x)
+          (boolean? x)
+          (number? x)
+          (char? x)
+          (keyword? x)
+          (regexp? x)
+          (byte-regexp? x)
+          (extflonum? x))
+      fuel]
+     [(symbol? x)
+      (cond [(symbol-interned? x)
+             fuel]
+            [(symbol-unreadable? x)
+             (if allow-unreadable? fuel (bad))]
+            [else ;; uninterned
+             (if (eq? allow-unreadable? #t) fuel (bad))])]
+     ;; Mutable flat
+     [(or (string? x)
+          (bytes? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     [(or (fxvector? x)
+          (flvector? x)
+          (extflvector? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     ;; Syntax
+     [(syntax? x)
+      (case stx-mode
+        ((atomic) fuel)
+        ((compound) (loop (syntax-e x) fuel))
+        (else (bad)))]
+     ;; Impersonators and chaperones
+     [(and no-impersonator? (impersonator? x))  ;; else continue to chaperoned type
+      (bad)]
+     [(and no-impersonator? (chaperone? x))  ;; else continue to impersonated type
+      (bad)]
+     [else
+      (with-cycle-check
+       (cond
+        ;; Mutable (maybe) compound
+        [(vector? x)
+         (with-mutable-check (not (immutable? x))
+           (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
+             (loop e fuel)))]
+        [(box? x)
+         (with-mutable-check (not (immutable? x))
+           (loop (unbox x) (sub1 fuel)))]
+        [(prefab-struct-key x)
+         => (lambda (key)
+              (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
+                     (bad)]
+                    [else
+                     ;; traverse key, since contains arbitrary auto-value
+                     (let ([fuel (loop key fuel)])
+                       (loop (struct->vector x) fuel))]))]
+        [(hash? x)
+         (cond [(and no-mutable-hash/prefab? (not (immutable? x)))
+                (bad)]
+               [else
+                (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
+                  (let ([fuel (loop k fuel)])
+                    (loop v fuel)))])]
+        ;; Bad
+        [else
+         (bad)]))]))
+  (loop x0 fuel0))
+
+;; mutable-prefab-key? : prefab-key -> boolean
+(define (mutable-prefab-key? key)
+  ;; A prefab-key is either
+  ;;  - symbol
+  ;;  - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
+  ;; where mutable fields indicated by vector
+  ;; This code is probably overly general; racket seems to normalize keys.
+  (let loop ([k key])
+    (and (pair? k)
+         (or (and (vector? (car k))
+                  (positive? (vector-length (car k))))
+             (loop (cdr k))))))

6-12/racket/collects/syntax/parse/private/litconv.rkt

@@ -0,0 +1,284 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/lazy-require
+                     "sc.rkt"
+                     "lib.rkt"
+                     syntax/parse/private/kws
+                     racket/syntax)
+         syntax/parse/private/residual-ct ;; keep abs. path
+         stxparse-info/parse/private/residual)   ;; keep abs. path
+(begin-for-syntax
+ (lazy-require
+  [syntax/private/keyword (options-select-value parse-keyword-options)]
+  [stxparse-info/parse/private/rep ;; keep abs. path
+   (parse-kw-formals
+    check-conventions-rules
+    check-datum-literals-list
+    create-aux-def)]))
+;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
+;; Without this, dependencies don't get collected.
+(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
+
+(provide define-conventions
+         define-literal-set
+         literal-set->predicate
+         kernel-literals)
+
+(define-syntax (define-conventions stx)
+
+  (define-syntax-class header
+    #:description "name or name with formal parameters"
+    #:commit
+    (pattern name:id
+             #:with formals #'()
+             #:attr arity (arity 0 0 null null))
+    (pattern (name:id . formals)
+             #:attr arity (parse-kw-formals #'formals #:context stx)))
+
+  (syntax-parse stx
+    [(define-conventions h:header rule ...)
+     (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 (in-list 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 (class-name ...)
+         (map den:delayed-class dens))
+
+       ;; FIXME: could move make-den:delayed to user of conventions
+       ;; and eliminate from residual.rkt
+       #'(begin
+           (define-syntax h.name
+             (make-conventions
+              (quote-syntax get-parsers)
+              (lambda ()
+                (let ([class-names (list (quote-syntax class-name) ...)])
+                  (map list
+                       (list 'rx ...)
+                       (map make-den:delayed
+                            (generate-temporaries class-names)
+                            class-names))))))
+           (define get-parsers
+             (lambda formals
+               def ...
+               (list parser ...)))))]))
+
+(define-for-syntax (check-phase-level stx ctx)
+  (unless (or (exact-integer? (syntax-e stx))
+              (eq? #f (syntax-e stx)))
+    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
+  stx)
+
+;; check-litset-list : stx stx -> (listof (cons id literalset))
+(define-for-syntax (check-litset-list stx ctx)
+  (syntax-case stx ()
+    [(litset-id ...)
+     (for/list ([litset-id (syntax->list #'(litset-id ...))])
+       (let* ([val (and (identifier? litset-id)
+                        (syntax-local-value/record litset-id literalset?))])
+         (if val
+             (cons litset-id val)
+             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
+    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
+
+;; check-literal-entry/litset : stx stx -> (list id id)
+(define-for-syntax (check-literal-entry/litset stx ctx)
+  (syntax-case stx ()
+    [(internal external)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external)]
+    [id
+     (identifier? #'id)
+     (list #'id #'id)]
+    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits)
+  (let ([lit-t (make-hasheq)]) ;; sym => #t
+    (define (check+enter! key blame-stx)
+      (when (hash-ref lit-t key #f)
+        (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx))
+      (hash-set! lit-t key #t))
+    (for ([id+litset (in-list imports)])
+      (let ([litset-id (car id+litset)]
+            [litset (cdr id+litset)])
+        (for ([entry (in-list (literalset-literals litset))])
+          (cond [(lse:lit? entry)
+                 (check+enter! (lse:lit-internal entry) litset-id)]
+                [(lse:datum-lit? entry)
+                 (check+enter! (lse:datum-lit-internal entry) litset-id)]))))
+    (for ([datum-lit (in-list datum-lits)])
+      (let ([internal (den:datum-lit-internal datum-lit)])
+        (check+enter! (syntax-e internal) internal)))
+    (for ([lit (in-list lits)])
+      (check+enter! (syntax-e (car lit)) (car lit)))))
+
+(define-syntax (define-literal-set stx)
+  (syntax-case stx ()
+    [(define-literal-set name . rest)
+     (let-values ([(chunks rest)
+                   (parse-keyword-options
+                    #'rest
+                    `((#:literal-sets ,check-litset-list)
+                      (#:datum-literals ,check-datum-literals-list)
+                      (#:phase ,check-phase-level)
+                      (#:for-template)
+                      (#:for-syntax)
+                      (#:for-label))
+                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
+                    #:context stx
+                    #:no-duplicates? #t)])
+       (unless (identifier? #'name)
+         (raise-syntax-error #f "expected identifier" stx #'name))
+       (let ([relphase
+              (cond [(assq '#:for-template chunks) -1]
+                    [(assq '#:for-syntax chunks) 1]
+                    [(assq '#:for-label chunks) #f]
+                    [else (options-select-value chunks '#:phase #:default 0)])]
+             [datum-lits
+              (options-select-value chunks '#:datum-literals #:default null)]
+             [lits (syntax-case rest ()
+                     [( (lit ...) )
+                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
+                        (check-literal-entry/litset lit stx))]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [imports (options-select-value chunks '#:literal-sets #:default null)])
+         (check-duplicate-literals stx imports lits datum-lits)
+         (with-syntax ([((internal external) ...) lits]
+                       [(datum-internal ...) (map den:datum-lit-internal datum-lits)]
+                       [(datum-external ...) (map den:datum-lit-external datum-lits)]
+                       [(litset-id ...) (map car imports)]
+                       [relphase relphase])
+           #`(begin
+               (define phase-of-literals
+                 (and 'relphase
+                      (+ (variable-reference->module-base-phase (#%variable-reference))
+                         'relphase)))
+               (define-syntax name
+                 (make-literalset
+                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
+                          ...
+                          (list (make-lse:lit 'internal
+                                              (quote-syntax external)
+                                              (quote-syntax phase-of-literals))
+                                ...
+                                (make-lse:datum-lit 'datum-internal
+                                                    'datum-external)
+                                ...))))
+               (begin-for-syntax/once
+                (for ([x (in-list (syntax->list #'(external ...)))])
+                  (unless (identifier-binding x 'relphase)
+                    (raise-syntax-error #f
+                                        (format "literal is unbound in phase ~a~a~a"
+                                                'relphase
+                                                (case 'relphase
+                                                  ((1) " (for-syntax)")
+                                                  ((-1) " (for-template)")
+                                                  ((#f) " (for-label)")
+                                                  (else ""))
+                                                " relative to the enclosing module")
+                                        (quote-syntax #,stx) x))))))))]))
+
+#|
+NOTES ON PHASES AND BINDINGS
+
+(module M ....
+  .... (define-literal-set LS #:phase PL ....)
+  ....)
+
+For the expansion of the define-literal-set form, the bindings of the literals
+can be accessed by (identifier-binding lit PL), because the phase of the enclosing
+module (M) is 0.
+
+LS may be used, however, in a context where the phase of the enclosing
+module is not 0, so each instantiation of LS needs to calculate the
+phase of M and add that to PL.
+
+--
+
+Normally, literal sets that define the same name conflict. But it
+would be nice to allow them to both be imported in the case where they
+refer to the same binding.
+
+Problem: Can't do the check eagerly, because the binding of L may
+change between when define-literal-set is compiled and the comparison
+involving L. For example:
+
+  (module M racket
+    (require stxparse-info/parse)
+    (define-literal-set LS (lambda))
+    (require (only-in some-other-lang lambda))
+    .... LS ....)
+
+The expansion of the LS definition sees a different lambda than the
+one that the literal in LS actually refers to.
+
+Similarly, a literal in LS might not be defined when the expander
+runs, but might get defined later. (Although I think that will already
+cause an error, so don't worry about that case.)
+|#
+
+;; FIXME: keep one copy of each identifier (?)
+
+(define-syntax (literal-set->predicate stx)
+  (syntax-case stx ()
+    [(literal-set->predicate litset-id)
+     (let ([val (and (identifier? #'litset-id)
+                     (syntax-local-value/record #'litset-id literalset?))])
+       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
+       (let ([lits (literalset-literals val)])
+         (with-syntax ([((lit phase-var) ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:lit? lit))
+                          (list (lse:lit-external lit) (lse:lit-phase lit)))]
+                       [(datum-lit ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:datum-lit? lit))
+                          (lse:datum-lit-external lit))])
+           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
+                                         '(datum-lit ...)))))]))
+
+(define (make-literal-set-predicate lits datum-lits)
+  (lambda (x [phase (syntax-local-phase-level)])
+    (or (for/or ([lit (in-list lits)])
+          (let ([lit-id (car lit)]
+                [lit-phase (cadr lit)])
+            (free-identifier=? x lit-id phase lit-phase)))
+        (and (memq (syntax-e x) datum-lits) #t))))
+
+;; Literal sets
+
+(define-literal-set kernel-literals
+  (begin
+   begin0
+   define-values
+   define-syntaxes
+   define-values-for-syntax ;; kept for compat.
+   begin-for-syntax
+   set!
+   let-values
+   letrec-values
+   #%plain-lambda
+   case-lambda
+   if
+   quote
+   quote-syntax
+   letrec-syntaxes+values
+   with-continuation-mark
+   #%expression
+   #%plain-app
+   #%top
+   #%datum
+   #%variable-reference
+   module module* #%provide #%require #%declare
+   #%plain-module-begin))

6-12/racket/collects/syntax/parse/private/make.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/struct-info))
+(provide make)
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
+
+;; (make struct-name field-expr ...)
+;; Checks that correct number of fields given.
+(define-syntax (make stx)
+  (syntax-case stx ()
+    [(make S expr ...)
+     (let ()
+       (define info (get-struct-info #'S stx))
+       (define constructor (list-ref info 1))
+       (define accessors (list-ref info 3))
+       (unless (identifier? #'constructor)
+         (raise-syntax-error #f "constructor not available for struct" stx #'S))
+       (unless (andmap identifier? accessors)
+         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
+       (let ([num-slots (length accessors)]
+             [num-provided (length (syntax->list #'(expr ...)))])
+         (unless (= num-provided num-slots)
+           (raise-syntax-error
+            #f
+            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
+                    (syntax-e #'S)
+                    num-slots
+                    num-provided)
+            stx)))
+       (with-syntax ([constructor constructor])
+         (syntax-property #'(constructor expr ...)
+                          'disappeared-use
+                          #'S)))]))

6-12/racket/collects/syntax/parse/private/runtime-progress.rkt

@@ -0,0 +1,257 @@
+#lang racket/base
+(require racket/list
+         syntax/parse/private/minimatch)
+(provide ps-empty
+         ps-add-car
+         ps-add-cdr
+         ps-add-stx
+         ps-add-unbox
+         ps-add-unvector
+         ps-add-unpstruct
+         ps-add-opaque
+         ps-add-post
+         ps-add
+         (struct-out ord)
+
+         ps-pop-opaque
+         ps-pop-ord
+         ps-pop-post
+         ps-context-syntax
+         ps-difference
+
+         (struct-out failure)
+         failure*
+
+         expect?
+         (struct-out expect:thing)
+         (struct-out expect:atom)
+         (struct-out expect:literal)
+         (struct-out expect:message)
+         (struct-out expect:disj)
+         (struct-out expect:proper-pair)
+
+         es-add-thing
+         es-add-message
+         es-add-atom
+         es-add-literal
+         es-add-proper-pair)
+
+;; FIXME: add phase to expect:literal
+
+;; == Failure ==
+
+#|
+A Failure is (failure PS ExpectStack)
+
+A FailureSet is one of
+  - Failure
+  - (cons FailureSet FailureSet)
+
+A FailFunction = (FailureSet -> Answer)
+|#
+(define-struct failure (progress expectstack) #:prefab)
+
+;; failure* : PS ExpectStack/#f -> Failure/#t
+(define (failure* ps es) (if es (failure ps es) #t))
+
+;; == Progress ==
+
+#|
+Progress (PS) is a non-empty list of Progress Frames (PF).
+
+A Progress Frame (PF) is one of
+  - stx     ;; "Base" frame, or ~parse/#:with term
+  - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
+  - nat     ;; Represents that many repeated cdrs
+  - 'post   ;; late/post-traversal check
+  - #s(ord group index) ;; ~and subpattern, only comparable w/in group
+  - 'opaque
+
+The error-reporting context (ie, syntax-parse #:context arg) is always
+the final frame.
+
+All non-stx frames (eg car, cdr) interpreted as applying to nearest following
+stx frame.
+
+A stx frame is introduced
+  - always at base (that is, by syntax-parse)
+    - if syntax-parse has #:context arg, then two stx frames at bottom:
+      (list to-match-stx context-stx)
+  - by #:with/~parse
+  - by #:fail-*/#:when/~fail & stx
+
+Interpretation: later frames are applied first.
+ eg, (list 'car 1 stx)
+      means ( car of ( cdr once of stx ) )
+      NOT apply car, then apply cdr once, then stop
+|#
+(define-struct ord (group index) #:prefab)
+
+(define (ps-empty stx ctx)
+  (if (eq? stx ctx)
+      (list stx)
+      (list stx ctx)))
+(define (ps-add-car parent)
+  (cons 'car parent))
+(define (ps-add-cdr parent [times 1])
+  (if (zero? times)
+      parent
+      (match (car parent)
+        [(? exact-positive-integer? n)
+         (cons (+ times n) (cdr parent))]
+        [_
+         (cons times parent)])))
+(define (ps-add-stx parent stx)
+  (cons stx parent))
+(define (ps-add-unbox parent)
+  (ps-add-car parent))
+(define (ps-add-unvector parent)
+  (ps-add-car parent))
+(define (ps-add-unpstruct parent)
+  (ps-add-car parent))
+(define (ps-add-opaque parent)
+  (cons 'opaque parent))
+(define (ps-add parent frame)
+  (cons frame parent))
+(define (ps-add-post parent)
+  (cons 'post parent))
+
+;; ps-context-syntax : Progress -> syntax
+(define (ps-context-syntax ps)
+  ;; Bottom frame is always syntax
+  (last ps))
+
+;; ps-difference : PS PS -> nat
+;; Returns N s.t. B = (ps-add-cdr^N A)
+(define (ps-difference a b)
+  (define-values (a-cdrs a-base)
+    (match a
+      [(cons (? exact-positive-integer? a-cdrs) a-base)
+       (values a-cdrs a-base)]
+      [_ (values 0 a)]))
+  (define-values (b-cdrs b-base)
+    (match b
+      [(cons (? exact-positive-integer? b-cdrs) b-base)
+       (values b-cdrs b-base)]
+      [_ (values 0 b)]))
+  (unless (eq? a-base b-base)
+    (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
+  (- b-cdrs a-cdrs))
+
+;; ps-pop-opaque : PS -> PS
+;; Used to continue with progress from opaque head pattern.
+(define (ps-pop-opaque ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'opaque ps*)
+     ps*]
+    [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
+
+;; ps-pop-ord : PS -> PS
+(define (ps-pop-ord ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
+     (ps-add-cdr ps* n)]
+    [(cons (? ord?) ps*)
+     ps*]
+    [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
+
+;; ps-pop-post : PS -> PS
+(define (ps-pop-post ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'post ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'post ps*)
+     ps*]
+    [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
+
+
+;; == Expectations ==
+
+#|
+There are multiple types that use the same structures, optimized for
+different purposes.
+
+-- During parsing, the goal is to minimize/consolidate allocations.
+
+An ExpectStack (during parsing) is one of
+  - (expect:thing Progress String Boolean String/#f ExpectStack)
+  * (expect:message String ExpectStack)
+  * (expect:atom Datum ExpectStack)
+  * (expect:literal Identifier ExpectStack)
+  * (expect:proper-pair FirstDesc ExpectStack)
+  * #t
+
+The *-marked variants can only occur at the top of the stack (ie, not
+in the next field of another Expect). The top of the stack contains
+the most specific information.
+
+An ExpectStack can also be #f, which means no failure tracking is
+requested (and thus no more ExpectStacks should be allocated).
+
+-- During reporting, the goal is ease of manipulation.
+
+An ExpectList (during reporting) is (listof Expect).
+
+An Expect is one of
+  - (expect:thing #f String #t String/#f StxIdx)
+  * (expect:message String StxIdx)
+  * (expect:atom Datum StxIdx)
+  * (expect:literal Identifier StxIdx)
+  * (expect:proper-pair FirstDesc StxIdx)
+  * (expect:disj (NEListof Expect) StxIdx)
+  - '...
+
+A StxIdx is (cons Syntax Nat)
+
+That is, the next link is replaced with the syntax+index of the term
+being complained about. An expect:thing's progress is replaced with #f.
+
+An expect:disj never contains a '... or another expect:disj.
+
+We write ExpectList when the most specific information comes first and
+RExpectList when the most specific information comes last.
+|#
+(struct expect:thing (term description transparent? role next) #:prefab)
+(struct expect:message (message next) #:prefab)
+(struct expect:atom (atom next) #:prefab)
+(struct expect:literal (literal next) #:prefab)
+(struct expect:disj (expects next) #:prefab)
+(struct expect:proper-pair (first-desc next) #:prefab)
+
+(define (expect? x)
+  (or (expect:thing? x)
+      (expect:message? x)
+      (expect:atom? x)
+      (expect:literal? x)
+      (expect:disj? x)
+      (expect:proper-pair? x)))
+
+(define (es-add-thing ps description transparent? role next)
+  (if (and next description)
+      (expect:thing ps description transparent? role next)
+      next))
+
+(define (es-add-message message next)
+  (if (and next message)
+      (expect:message message next)
+      next))
+
+(define (es-add-atom atom next)
+  (and next (expect:atom atom next)))
+
+(define (es-add-literal literal next)
+  (and next (expect:literal literal next)))
+
+(define (es-add-proper-pair first-desc next)
+  (and next (expect:proper-pair first-desc next)))
+
+#|
+A FirstDesc is one of
+ - #f                   -- unknown, multiple possible, etc
+ - string               -- description
+ - (list 'any)
+ - (list 'literal symbol)
+ - (list 'datum datum)
+|#

6-12/racket/collects/syntax/parse/private/txlift.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+(require (for-template racket/base))
+(provide txlift
+         get-txlifts-as-definitions
+         with-txlifts
+         call/txlifts)
+
+;; Like lifting definitions, but within a single transformer.
+
+;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))]
+(define current-liftbox (make-parameter #f))
+
+(define (call/txlifts proc)
+  (parameterize ((current-liftbox (box null)))
+    (proc)))
+
+(define (txlift expr)
+  (let ([liftbox (current-liftbox)])
+    (check 'txlift liftbox)
+    (let ([var (car (generate-temporaries '(txlift)))])
+      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
+      var)))
+
+(define (get-txlifts)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts liftbox)
+    (reverse (unbox liftbox))))
+
+(define (get-txlifts-as-definitions)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts-as-definitions liftbox)
+    (map (lambda (p)
+           #`(define #,@p))
+         (reverse (unbox liftbox)))))
+
+(define (check who lb)
+  (unless (box? lb)
+    (error who "not in a txlift-catching context")))
+
+(define (with-txlifts proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([((var rhs) ...) (get-txlifts)])
+         #`(let* ([var rhs] ...) #,v))))))

6-90-0-29/racket/collects/syntax/parse/define.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     stxparse-info/parse
+                     "private/sc.rkt"))
+(provide define-simple-macro
+         define-syntax-parser
+         (for-syntax (all-from-out stxparse-info/parse)))
+
+(define-syntax (define-simple-macro stx)
+  (syntax-parse stx
+    [(define-simple-macro (~and (macro:id . _) pattern) . body)
+     #`(define-syntax macro
+         (syntax-parser/template
+          #,((make-syntax-introducer) stx)
+          [pattern . body]))]))
+
+(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
+  (define-syntax macro
+    (syntax-parser option-or-clause ...)))
+

6-90-0-29/racket/collects/syntax/parse/experimental/dset.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+;; A dset is an `equal?`-based set, but it preserves order based on
+;; the history of additions, so that if items are added in a
+;; deterministic order, they come back out in a deterministic order.
+
+(provide dset
+         dset-empty?
+         dset->list
+         dset-add
+         dset-union
+         dset-subtract
+         dset-filter)
+
+(define dset
+  (case-lambda
+    [() (hash)]
+    [(e) (hash e 0)]))
+
+(define (dset-empty? ds)
+  (zero? (hash-count ds)))
+
+(define (dset->list ds)
+  (map cdr
+       (sort (for/list ([(k v) (in-hash ds)])
+               (cons v k))
+             <
+             #:key car)))
+
+(define (dset-add ds e)
+  (if (hash-ref ds e #f)
+      ds
+      (hash-set ds e (hash-count ds))))
+
+(define (dset-union ds1 ds2)
+  (cond
+   [((hash-count ds1) . > . (hash-count ds2))
+    (dset-union ds2 ds1)]
+   [else
+    (for/fold ([ds2 ds2]) ([e (dset->list ds1)])
+      (dset-add ds2 e))]))
+
+(define (dset-subtract ds1 ds2)
+  ;; ! takes O(size(ds2)) time !
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
+    (if (hash-ref ds2 e #f)
+        r
+        (dset-add r e))))
+
+(define (dset-filter ds pred)
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
+    (if (pred e)
+        (dset-add r e)
+        r)))

6-90-0-29/racket/collects/syntax/parse/experimental/eh.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require "../private/sc.rkt"
+         syntax/parse/private/keywords)
+(provide ~eh-var
+         define-eh-alternative-set)

6-90-0-29/racket/collects/syntax/parse/lib/function-header.rkt

@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require "../../parse.rkt"
+         "../experimental/template.rkt"
+         racket/dict)
+
+(provide function-header formal formals)
+
+(define-syntax-class function-header
+  (pattern ((~or header:function-header name:id) . args:formals)
+           #:attr params
+           (template ((?@ . (?? header.params ()))
+                      . args.params))))
+
+(define-syntax-class formals
+  #:attributes (params)
+  (pattern (arg:formal ...)
+           #:attr params #'(arg.name ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing")
+  (pattern (arg:formal ... . rest:id)
+           #:attr params #'(arg.name ... rest)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing"))
+
+(define-splicing-syntax-class formal
+  #:attributes (name kw default)
+  (pattern name:id
+           #:attr kw #f
+           #:attr default #f)
+  (pattern [name:id default]
+           #:attr kw #f)
+  (pattern (~seq kw:keyword name:id)
+           #:attr default #f)
+  (pattern (~seq kw:keyword [name:id default])))
+
+;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
+;; Checks for mandatory argument after optional argument; if found, returns
+;; identifier of mandatory argument.
+(define (invalid-option-placement names defaults)
+  ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
+  ;; Finds first name w/o corresponding default.
+  (define (find-mandatory names defaults)
+    (for/first ([name (in-list names)]
+                [default (in-list defaults)]
+                #:when (not default))
+      name))
+  ;; Skip through mandatory args until first optional found, then search
+  ;; for another mandatory.
+  (let loop ([names names] [defaults defaults])
+    (cond [(or (null? names) (null? defaults))
+           #f]
+          [(eq? (car defaults) #f) ;; mandatory
+           (loop (cdr names) (cdr defaults))]
+          [else ;; found optional
+           (find-mandatory (cdr names) (cdr defaults))])))
+
+;; Copied from unstable/list
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))

6-90-0-29/racket/collects/syntax/parse/private/3d-stx.rkt

@@ -0,0 +1,250 @@
+#lang racket/base
+(require (only-in '#%flfxnum flvector? fxvector?)
+         (only-in '#%extfl extflonum? extflvector?))
+(provide 2d-stx?
+         check-datum)
+
+;; Checks for 3D syntax (syntax that contains unwritable values, etc)
+
+(define INIT-FUEL #e1e6)
+
+;; TO DO:
+;; - extension via proc (any -> list/#f),
+;;   value considered good if result is list, all values in list are good
+
+;; --
+
+#|
+Some other predicates one might like to have:
+ - would (read (write x)) succeed and be equal/similar to x?
+ - would (datum->syntax #f x) succeed?
+ - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
+ - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
+
+where equal/similar could mean one of the following:
+ - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
+ - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
+ - equal? but also requiring same mutability at every point
+
+Some aux definitions:
+
+(define (rt x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (read in))
+
+(define (wrsd x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (syntax->datum (read-syntax #f in)))
+
+(define (dsd x)
+  (syntax->datum (datum->syntax #f x)))
+
+(define (evalc x) ;; mimics compiled zo-file constraints
+  (eval (rt (compile `(quote ,x)))))
+
+How mutability behaves:
+ - for vectors, boxes:
+   - read always mutable
+   - read-syntax always immutable
+   - (dsd x) always immutable
+   - (evalc x) always immutable
+ - for hashes:
+   - read always immutable
+   - (dsd x) same as x
+   - (evalc x) always immutable (!!!)
+ - for prefab structs:
+   - read same as x
+   - read-syntax same as x
+   - (dsd x) same as x
+   - (evalc x) same as x
+
+Symbols
+ - (dsd x) same as x
+ - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
+
+Chaperones allow the lazy generation of infinite trees of data
+undetectable by eq?-based cycle detection.  Might be helpful to have
+chaperone-eq? (not recursive, just chaperones of same object) and
+chaperone-eq?-hash-code, to use with make-custom-hash.)
+
+Impersonators allow the lazy generation of infinite trees of data,
+period.
+
+|#
+
+;; ----
+
+;; 2d-stx? : any ... -> boolean
+;; Would (write (compile `(quote-syntax ,x))) succeed?
+;; If traverse-syntax? is #t, recurs into existing syntax
+;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
+;; checks if *new* 3d syntax would be created.
+(define (2d-stx? x
+                 #:traverse-syntax? [traverse-syntax? #t]
+                 #:irritant [irritant-box #f])
+  (check-datum x
+               #:syntax-mode (if traverse-syntax? 'compound 'atomic)
+               #:allow-impersonators? #f
+               #:allow-mutable? 'no-hash/prefab
+               #:allow-unreadable-symbols? #t
+               #:allow-cycles? #t
+               #:irritant irritant-box))
+
+;; ----
+
+;; check-datum : any ... -> boolean
+;; where StxMode = (U 'atomic 'compound #f)
+;; Returns nat if x is "good", #f if "bad"
+;; If irritant-b is a box, the first bad subvalue found is put in the box.
+;; If visited-t is a hash, it is used to detect cycles.
+(define (check-datum x
+                     #:syntax-mode [stx-mode #f]
+                     #:allow-impersonators? [allow-impersonators? #f]
+                     #:allow-mutable? [allow-mutable? #f]
+                     #:allow-unreadable-symbols? [allow-unreadable? #f]
+                     #:allow-cycles? [allow-cycles? #f]
+                     #:irritant [irritant-b #f])
+  ;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
+  (define (run fuel visited-t)
+    (check* x fuel visited-t
+            stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+            irritant-b))
+  (let ([result (run INIT-FUEL #f)])
+    (cond [(not (equal? result 0)) ;; nat>0 or #f
+           (and result #t)]
+          [else
+           ;; (eprintf "out of fuel, restarting\n")
+           (and (run +inf.0 (make-hasheq)) #t)])))
+
+;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
+;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
+;; If bad, places bad subvalue in irritant-b, if box
+(define (check* x0 fuel0 visited-t
+                stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+                irritant-b)
+  (define no-mutable? (not allow-mutable?))
+  (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
+  (define no-cycle? (not allow-cycles?))
+  (define no-impersonator? (not allow-impersonators?))
+  (define (loop x fuel)
+    (if (and fuel (not (zero? fuel)))
+        (loop* x fuel)
+        fuel))
+  (define (loop* x fuel)
+    (define (bad) (when irritant-b (set-box! irritant-b x)) #f)
+    (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
+      (cond [(and no-mutable? mutable?)
+             (bad)]
+            [else
+             body ...]))
+    (define-syntax-rule (with-cycle-check body ...)
+      (cond [(and visited-t (hash-ref visited-t x #f))
+             => (lambda (status)
+                  (cond [(and no-cycle? (eq? status 'traversing))
+                         (bad)]
+                        [else
+                         fuel]))]
+            [else
+             (when visited-t
+               (hash-set! visited-t x 'traversing))
+             (begin0 (begin body ...)
+               (when visited-t
+                 (hash-remove! visited-t x)))]))
+    ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
+    (cond
+     ;; Immutable compound
+     [(and visited-t (list? x))
+      ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
+      ;; don't do unless visited-t present, else expands fuel by arbitrary factors
+      (with-cycle-check
+       (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
+         (loop e fuel)))]
+     [(pair? x)
+      (with-cycle-check
+       (let ([fuel (loop (car x) (sub1 fuel))])
+         (loop (cdr x) fuel)))]
+     ;; Atomic
+     [(or (null? x)
+          (boolean? x)
+          (number? x)
+          (char? x)
+          (keyword? x)
+          (regexp? x)
+          (byte-regexp? x)
+          (extflonum? x))
+      fuel]
+     [(symbol? x)
+      (cond [(symbol-interned? x)
+             fuel]
+            [(symbol-unreadable? x)
+             (if allow-unreadable? fuel (bad))]
+            [else ;; uninterned
+             (if (eq? allow-unreadable? #t) fuel (bad))])]
+     ;; Mutable flat
+     [(or (string? x)
+          (bytes? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     [(or (fxvector? x)
+          (flvector? x)
+          (extflvector? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     ;; Syntax
+     [(syntax? x)
+      (case stx-mode
+        ((atomic) fuel)
+        ((compound) (loop (syntax-e x) fuel))
+        (else (bad)))]
+     ;; Impersonators and chaperones
+     [(and no-impersonator? (impersonator? x))  ;; else continue to chaperoned type
+      (bad)]
+     [(and no-impersonator? (chaperone? x))  ;; else continue to impersonated type
+      (bad)]
+     [else
+      (with-cycle-check
+       (cond
+        ;; Mutable (maybe) compound
+        [(vector? x)
+         (with-mutable-check (not (immutable? x))
+           (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
+             (loop e fuel)))]
+        [(box? x)
+         (with-mutable-check (not (immutable? x))
+           (loop (unbox x) (sub1 fuel)))]
+        [(prefab-struct-key x)
+         => (lambda (key)
+              (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
+                     (bad)]
+                    [else
+                     ;; traverse key, since contains arbitrary auto-value
+                     (let ([fuel (loop key fuel)])
+                       (loop (struct->vector x) fuel))]))]
+        [(hash? x)
+         (cond [(and no-mutable-hash/prefab? (not (immutable? x)))
+                (bad)]
+               [else
+                (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
+                  (let ([fuel (loop k fuel)])
+                    (loop v fuel)))])]
+        ;; Bad
+        [else
+         (bad)]))]))
+  (loop x0 fuel0))
+
+;; mutable-prefab-key? : prefab-key -> boolean
+(define (mutable-prefab-key? key)
+  ;; A prefab-key is either
+  ;;  - symbol
+  ;;  - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
+  ;; where mutable fields indicated by vector
+  ;; This code is probably overly general; racket seems to normalize keys.
+  (let loop ([k key])
+    (and (pair? k)
+         (or (and (vector? (car k))
+                  (positive? (vector-length (car k))))
+             (loop (cdr k))))))

6-90-0-29/racket/collects/syntax/parse/private/litconv.rkt

@@ -0,0 +1,284 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/lazy-require
+                     "sc.rkt"
+                     "lib.rkt"
+                     syntax/parse/private/kws
+                     racket/syntax)
+         syntax/parse/private/residual-ct ;; keep abs. path
+         stxparse-info/parse/private/residual)   ;; keep abs. path
+(begin-for-syntax
+ (lazy-require
+  [syntax/private/keyword (options-select-value parse-keyword-options)]
+  [stxparse-info/parse/private/rep ;; keep abs. path
+   (parse-kw-formals
+    check-conventions-rules
+    check-datum-literals-list
+    create-aux-def)]))
+;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
+;; Without this, dependencies don't get collected.
+(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
+
+(provide define-conventions
+         define-literal-set
+         literal-set->predicate
+         kernel-literals)
+
+(define-syntax (define-conventions stx)
+
+  (define-syntax-class header
+    #:description "name or name with formal parameters"
+    #:commit
+    (pattern name:id
+             #:with formals #'()
+             #:attr arity (arity 0 0 null null))
+    (pattern (name:id . formals)
+             #:attr arity (parse-kw-formals #'formals #:context stx)))
+
+  (syntax-parse stx
+    [(define-conventions h:header rule ...)
+     (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 (in-list 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 (class-name ...)
+         (map den:delayed-class dens))
+
+       ;; FIXME: could move make-den:delayed to user of conventions
+       ;; and eliminate from residual.rkt
+       #'(begin
+           (define-syntax h.name
+             (make-conventions
+              (quote-syntax get-parsers)
+              (lambda ()
+                (let ([class-names (list (quote-syntax class-name) ...)])
+                  (map list
+                       (list 'rx ...)
+                       (map make-den:delayed
+                            (generate-temporaries class-names)
+                            class-names))))))
+           (define get-parsers
+             (lambda formals
+               def ...
+               (list parser ...)))))]))
+
+(define-for-syntax (check-phase-level stx ctx)
+  (unless (or (exact-integer? (syntax-e stx))
+              (eq? #f (syntax-e stx)))
+    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
+  stx)
+
+;; check-litset-list : stx stx -> (listof (cons id literalset))
+(define-for-syntax (check-litset-list stx ctx)
+  (syntax-case stx ()
+    [(litset-id ...)
+     (for/list ([litset-id (syntax->list #'(litset-id ...))])
+       (let* ([val (and (identifier? litset-id)
+                        (syntax-local-value/record litset-id literalset?))])
+         (if val
+             (cons litset-id val)
+             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
+    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
+
+;; check-literal-entry/litset : stx stx -> (list id id)
+(define-for-syntax (check-literal-entry/litset stx ctx)
+  (syntax-case stx ()
+    [(internal external)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external)]
+    [id
+     (identifier? #'id)
+     (list #'id #'id)]
+    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits)
+  (let ([lit-t (make-hasheq)]) ;; sym => #t
+    (define (check+enter! key blame-stx)
+      (when (hash-ref lit-t key #f)
+        (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx))
+      (hash-set! lit-t key #t))
+    (for ([id+litset (in-list imports)])
+      (let ([litset-id (car id+litset)]
+            [litset (cdr id+litset)])
+        (for ([entry (in-list (literalset-literals litset))])
+          (cond [(lse:lit? entry)
+                 (check+enter! (lse:lit-internal entry) litset-id)]
+                [(lse:datum-lit? entry)
+                 (check+enter! (lse:datum-lit-internal entry) litset-id)]))))
+    (for ([datum-lit (in-list datum-lits)])
+      (let ([internal (den:datum-lit-internal datum-lit)])
+        (check+enter! (syntax-e internal) internal)))
+    (for ([lit (in-list lits)])
+      (check+enter! (syntax-e (car lit)) (car lit)))))
+
+(define-syntax (define-literal-set stx)
+  (syntax-case stx ()
+    [(define-literal-set name . rest)
+     (let-values ([(chunks rest)
+                   (parse-keyword-options
+                    #'rest
+                    `((#:literal-sets ,check-litset-list)
+                      (#:datum-literals ,check-datum-literals-list)
+                      (#:phase ,check-phase-level)
+                      (#:for-template)
+                      (#:for-syntax)
+                      (#:for-label))
+                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
+                    #:context stx
+                    #:no-duplicates? #t)])
+       (unless (identifier? #'name)
+         (raise-syntax-error #f "expected identifier" stx #'name))
+       (let ([relphase
+              (cond [(assq '#:for-template chunks) -1]
+                    [(assq '#:for-syntax chunks) 1]
+                    [(assq '#:for-label chunks) #f]
+                    [else (options-select-value chunks '#:phase #:default 0)])]
+             [datum-lits
+              (options-select-value chunks '#:datum-literals #:default null)]
+             [lits (syntax-case rest ()
+                     [( (lit ...) )
+                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
+                        (check-literal-entry/litset lit stx))]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [imports (options-select-value chunks '#:literal-sets #:default null)])
+         (check-duplicate-literals stx imports lits datum-lits)
+         (with-syntax ([((internal external) ...) lits]
+                       [(datum-internal ...) (map den:datum-lit-internal datum-lits)]
+                       [(datum-external ...) (map den:datum-lit-external datum-lits)]
+                       [(litset-id ...) (map car imports)]
+                       [relphase relphase])
+           #`(begin
+               (define phase-of-literals
+                 (and 'relphase
+                      (+ (variable-reference->module-base-phase (#%variable-reference))
+                         'relphase)))
+               (define-syntax name
+                 (make-literalset
+                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
+                          ...
+                          (list (make-lse:lit 'internal
+                                              (quote-syntax external)
+                                              (quote-syntax phase-of-literals))
+                                ...
+                                (make-lse:datum-lit 'datum-internal
+                                                    'datum-external)
+                                ...))))
+               (begin-for-syntax/once
+                (for ([x (in-list (syntax->list #'(external ...)))])
+                  (unless (identifier-binding x 'relphase)
+                    (raise-syntax-error #f
+                                        (format "literal is unbound in phase ~a~a~a"
+                                                'relphase
+                                                (case 'relphase
+                                                  ((1) " (for-syntax)")
+                                                  ((-1) " (for-template)")
+                                                  ((#f) " (for-label)")
+                                                  (else ""))
+                                                " relative to the enclosing module")
+                                        (quote-syntax #,stx) x))))))))]))
+
+#|
+NOTES ON PHASES AND BINDINGS
+
+(module M ....
+  .... (define-literal-set LS #:phase PL ....)
+  ....)
+
+For the expansion of the define-literal-set form, the bindings of the literals
+can be accessed by (identifier-binding lit PL), because the phase of the enclosing
+module (M) is 0.
+
+LS may be used, however, in a context where the phase of the enclosing
+module is not 0, so each instantiation of LS needs to calculate the
+phase of M and add that to PL.
+
+--
+
+Normally, literal sets that define the same name conflict. But it
+would be nice to allow them to both be imported in the case where they
+refer to the same binding.
+
+Problem: Can't do the check eagerly, because the binding of L may
+change between when define-literal-set is compiled and the comparison
+involving L. For example:
+
+  (module M racket
+    (require stxparse-info/parse)
+    (define-literal-set LS (lambda))
+    (require (only-in some-other-lang lambda))
+    .... LS ....)
+
+The expansion of the LS definition sees a different lambda than the
+one that the literal in LS actually refers to.
+
+Similarly, a literal in LS might not be defined when the expander
+runs, but might get defined later. (Although I think that will already
+cause an error, so don't worry about that case.)
+|#
+
+;; FIXME: keep one copy of each identifier (?)
+
+(define-syntax (literal-set->predicate stx)
+  (syntax-case stx ()
+    [(literal-set->predicate litset-id)
+     (let ([val (and (identifier? #'litset-id)
+                     (syntax-local-value/record #'litset-id literalset?))])
+       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
+       (let ([lits (literalset-literals val)])
+         (with-syntax ([((lit phase-var) ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:lit? lit))
+                          (list (lse:lit-external lit) (lse:lit-phase lit)))]
+                       [(datum-lit ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:datum-lit? lit))
+                          (lse:datum-lit-external lit))])
+           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
+                                         '(datum-lit ...)))))]))
+
+(define (make-literal-set-predicate lits datum-lits)
+  (lambda (x [phase (syntax-local-phase-level)])
+    (or (for/or ([lit (in-list lits)])
+          (let ([lit-id (car lit)]
+                [lit-phase (cadr lit)])
+            (free-identifier=? x lit-id phase lit-phase)))
+        (and (memq (syntax-e x) datum-lits) #t))))
+
+;; Literal sets
+
+(define-literal-set kernel-literals
+  (begin
+   begin0
+   define-values
+   define-syntaxes
+   define-values-for-syntax ;; kept for compat.
+   begin-for-syntax
+   set!
+   let-values
+   letrec-values
+   #%plain-lambda
+   case-lambda
+   if
+   quote
+   quote-syntax
+   letrec-syntaxes+values
+   with-continuation-mark
+   #%expression
+   #%plain-app
+   #%top
+   #%datum
+   #%variable-reference
+   module module* #%provide #%require #%declare
+   #%plain-module-begin))

6-90-0-29/racket/collects/syntax/parse/private/make.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/struct-info))
+(provide make)
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
+
+;; (make struct-name field-expr ...)
+;; Checks that correct number of fields given.
+(define-syntax (make stx)
+  (syntax-case stx ()
+    [(make S expr ...)
+     (let ()
+       (define info (get-struct-info #'S stx))
+       (define constructor (list-ref info 1))
+       (define accessors (list-ref info 3))
+       (unless (identifier? #'constructor)
+         (raise-syntax-error #f "constructor not available for struct" stx #'S))
+       (unless (andmap identifier? accessors)
+         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
+       (let ([num-slots (length accessors)]
+             [num-provided (length (syntax->list #'(expr ...)))])
+         (unless (= num-provided num-slots)
+           (raise-syntax-error
+            #f
+            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
+                    (syntax-e #'S)
+                    num-slots
+                    num-provided)
+            stx)))
+       (with-syntax ([constructor constructor])
+         (syntax-property #'(constructor expr ...)
+                          'disappeared-use
+                          #'S)))]))

6-90-0-29/racket/collects/syntax/parse/private/runtime-progress.rkt

@@ -0,0 +1,257 @@
+#lang racket/base
+(require racket/list
+         syntax/parse/private/minimatch)
+(provide ps-empty
+         ps-add-car
+         ps-add-cdr
+         ps-add-stx
+         ps-add-unbox
+         ps-add-unvector
+         ps-add-unpstruct
+         ps-add-opaque
+         ps-add-post
+         ps-add
+         (struct-out ord)
+
+         ps-pop-opaque
+         ps-pop-ord
+         ps-pop-post
+         ps-context-syntax
+         ps-difference
+
+         (struct-out failure)
+         failure*
+
+         expect?
+         (struct-out expect:thing)
+         (struct-out expect:atom)
+         (struct-out expect:literal)
+         (struct-out expect:message)
+         (struct-out expect:disj)
+         (struct-out expect:proper-pair)
+
+         es-add-thing
+         es-add-message
+         es-add-atom
+         es-add-literal
+         es-add-proper-pair)
+
+;; FIXME: add phase to expect:literal
+
+;; == Failure ==
+
+#|
+A Failure is (failure PS ExpectStack)
+
+A FailureSet is one of
+  - Failure
+  - (cons FailureSet FailureSet)
+
+A FailFunction = (FailureSet -> Answer)
+|#
+(define-struct failure (progress expectstack) #:prefab)
+
+;; failure* : PS ExpectStack/#f -> Failure/#t
+(define (failure* ps es) (if es (failure ps es) #t))
+
+;; == Progress ==
+
+#|
+Progress (PS) is a non-empty list of Progress Frames (PF).
+
+A Progress Frame (PF) is one of
+  - stx     ;; "Base" frame, or ~parse/#:with term
+  - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
+  - nat     ;; Represents that many repeated cdrs
+  - 'post   ;; late/post-traversal check
+  - #s(ord group index) ;; ~and subpattern, only comparable w/in group
+  - 'opaque
+
+The error-reporting context (ie, syntax-parse #:context arg) is always
+the final frame.
+
+All non-stx frames (eg car, cdr) interpreted as applying to nearest following
+stx frame.
+
+A stx frame is introduced
+  - always at base (that is, by syntax-parse)
+    - if syntax-parse has #:context arg, then two stx frames at bottom:
+      (list to-match-stx context-stx)
+  - by #:with/~parse
+  - by #:fail-*/#:when/~fail & stx
+
+Interpretation: later frames are applied first.
+ eg, (list 'car 1 stx)
+      means ( car of ( cdr once of stx ) )
+      NOT apply car, then apply cdr once, then stop
+|#
+(define-struct ord (group index) #:prefab)
+
+(define (ps-empty stx ctx)
+  (if (eq? stx ctx)
+      (list stx)
+      (list stx ctx)))
+(define (ps-add-car parent)
+  (cons 'car parent))
+(define (ps-add-cdr parent [times 1])
+  (if (zero? times)
+      parent
+      (match (car parent)
+        [(? exact-positive-integer? n)
+         (cons (+ times n) (cdr parent))]
+        [_
+         (cons times parent)])))
+(define (ps-add-stx parent stx)
+  (cons stx parent))
+(define (ps-add-unbox parent)
+  (ps-add-car parent))
+(define (ps-add-unvector parent)
+  (ps-add-car parent))
+(define (ps-add-unpstruct parent)
+  (ps-add-car parent))
+(define (ps-add-opaque parent)
+  (cons 'opaque parent))
+(define (ps-add parent frame)
+  (cons frame parent))
+(define (ps-add-post parent)
+  (cons 'post parent))
+
+;; ps-context-syntax : Progress -> syntax
+(define (ps-context-syntax ps)
+  ;; Bottom frame is always syntax
+  (last ps))
+
+;; ps-difference : PS PS -> nat
+;; Returns N s.t. B = (ps-add-cdr^N A)
+(define (ps-difference a b)
+  (define-values (a-cdrs a-base)
+    (match a
+      [(cons (? exact-positive-integer? a-cdrs) a-base)
+       (values a-cdrs a-base)]
+      [_ (values 0 a)]))
+  (define-values (b-cdrs b-base)
+    (match b
+      [(cons (? exact-positive-integer? b-cdrs) b-base)
+       (values b-cdrs b-base)]
+      [_ (values 0 b)]))
+  (unless (eq? a-base b-base)
+    (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
+  (- b-cdrs a-cdrs))
+
+;; ps-pop-opaque : PS -> PS
+;; Used to continue with progress from opaque head pattern.
+(define (ps-pop-opaque ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'opaque ps*)
+     ps*]
+    [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
+
+;; ps-pop-ord : PS -> PS
+(define (ps-pop-ord ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
+     (ps-add-cdr ps* n)]
+    [(cons (? ord?) ps*)
+     ps*]
+    [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
+
+;; ps-pop-post : PS -> PS
+(define (ps-pop-post ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'post ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'post ps*)
+     ps*]
+    [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
+
+
+;; == Expectations ==
+
+#|
+There are multiple types that use the same structures, optimized for
+different purposes.
+
+-- During parsing, the goal is to minimize/consolidate allocations.
+
+An ExpectStack (during parsing) is one of
+  - (expect:thing Progress String Boolean String/#f ExpectStack)
+  * (expect:message String ExpectStack)
+  * (expect:atom Datum ExpectStack)
+  * (expect:literal Identifier ExpectStack)
+  * (expect:proper-pair FirstDesc ExpectStack)
+  * #t
+
+The *-marked variants can only occur at the top of the stack (ie, not
+in the next field of another Expect). The top of the stack contains
+the most specific information.
+
+An ExpectStack can also be #f, which means no failure tracking is
+requested (and thus no more ExpectStacks should be allocated).
+
+-- During reporting, the goal is ease of manipulation.
+
+An ExpectList (during reporting) is (listof Expect).
+
+An Expect is one of
+  - (expect:thing #f String #t String/#f StxIdx)
+  * (expect:message String StxIdx)
+  * (expect:atom Datum StxIdx)
+  * (expect:literal Identifier StxIdx)
+  * (expect:proper-pair FirstDesc StxIdx)
+  * (expect:disj (NEListof Expect) StxIdx)
+  - '...
+
+A StxIdx is (cons Syntax Nat)
+
+That is, the next link is replaced with the syntax+index of the term
+being complained about. An expect:thing's progress is replaced with #f.
+
+An expect:disj never contains a '... or another expect:disj.
+
+We write ExpectList when the most specific information comes first and
+RExpectList when the most specific information comes last.
+|#
+(struct expect:thing (term description transparent? role next) #:prefab)
+(struct expect:message (message next) #:prefab)
+(struct expect:atom (atom next) #:prefab)
+(struct expect:literal (literal next) #:prefab)
+(struct expect:disj (expects next) #:prefab)
+(struct expect:proper-pair (first-desc next) #:prefab)
+
+(define (expect? x)
+  (or (expect:thing? x)
+      (expect:message? x)
+      (expect:atom? x)
+      (expect:literal? x)
+      (expect:disj? x)
+      (expect:proper-pair? x)))
+
+(define (es-add-thing ps description transparent? role next)
+  (if (and next description)
+      (expect:thing ps description transparent? role next)
+      next))
+
+(define (es-add-message message next)
+  (if (and next message)
+      (expect:message message next)
+      next))
+
+(define (es-add-atom atom next)
+  (and next (expect:atom atom next)))
+
+(define (es-add-literal literal next)
+  (and next (expect:literal literal next)))
+
+(define (es-add-proper-pair first-desc next)
+  (and next (expect:proper-pair first-desc next)))
+
+#|
+A FirstDesc is one of
+ - #f                   -- unknown, multiple possible, etc
+ - string               -- description
+ - (list 'any)
+ - (list 'literal symbol)
+ - (list 'datum datum)
+|#

6-90-0-29/racket/collects/syntax/parse/private/txlift.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+(require (for-template racket/base))
+(provide txlift
+         get-txlifts-as-definitions
+         with-txlifts
+         call/txlifts)
+
+;; Like lifting definitions, but within a single transformer.
+
+;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))]
+(define current-liftbox (make-parameter #f))
+
+(define (call/txlifts proc)
+  (parameterize ((current-liftbox (box null)))
+    (proc)))
+
+(define (txlift expr)
+  (let ([liftbox (current-liftbox)])
+    (check 'txlift liftbox)
+    (let ([var (car (generate-temporaries '(txlift)))])
+      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
+      var)))
+
+(define (get-txlifts)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts liftbox)
+    (reverse (unbox liftbox))))
+
+(define (get-txlifts-as-definitions)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts-as-definitions liftbox)
+    (map (lambda (p)
+           #`(define #,@p))
+         (reverse (unbox liftbox)))))
+
+(define (check who lb)
+  (unless (box? lb)
+    (error who "not in a txlift-catching context")))
+
+(define (with-txlifts proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([((var rhs) ...) (get-txlifts)])
+         #`(let* ([var rhs] ...) #,v))))))

7-0-0-20/racket/collects/syntax/parse/define.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     stxparse-info/parse
+                     "private/sc.rkt"))
+(provide define-simple-macro
+         define-syntax-parser
+         (for-syntax (all-from-out stxparse-info/parse)))
+
+(define-syntax (define-simple-macro stx)
+  (syntax-parse stx
+    [(define-simple-macro (~and (macro:id . _) pattern) . body)
+     #`(define-syntax macro
+         (syntax-parser/template
+          #,((make-syntax-introducer) stx)
+          [pattern . body]))]))
+
+(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
+  (define-syntax macro
+    (syntax-parser option-or-clause ...)))
+

7-0-0-20/racket/collects/syntax/parse/experimental/dset.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+;; A dset is an `equal?`-based set, but it preserves order based on
+;; the history of additions, so that if items are added in a
+;; deterministic order, they come back out in a deterministic order.
+
+(provide dset
+         dset-empty?
+         dset->list
+         dset-add
+         dset-union
+         dset-subtract
+         dset-filter)
+
+(define dset
+  (case-lambda
+    [() (hash)]
+    [(e) (hash e 0)]))
+
+(define (dset-empty? ds)
+  (zero? (hash-count ds)))
+
+(define (dset->list ds)
+  (map cdr
+       (sort (for/list ([(k v) (in-hash ds)])
+               (cons v k))
+             <
+             #:key car)))
+
+(define (dset-add ds e)
+  (if (hash-ref ds e #f)
+      ds
+      (hash-set ds e (hash-count ds))))
+
+(define (dset-union ds1 ds2)
+  (cond
+   [((hash-count ds1) . > . (hash-count ds2))
+    (dset-union ds2 ds1)]
+   [else
+    (for/fold ([ds2 ds2]) ([e (dset->list ds1)])
+      (dset-add ds2 e))]))
+
+(define (dset-subtract ds1 ds2)
+  ;; ! takes O(size(ds2)) time !
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
+    (if (hash-ref ds2 e #f)
+        r
+        (dset-add r e))))
+
+(define (dset-filter ds pred)
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
+    (if (pred e)
+        (dset-add r e)
+        r)))

7-0-0-20/racket/collects/syntax/parse/experimental/eh.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require "../private/sc.rkt"
+         syntax/parse/private/keywords)
+(provide ~eh-var
+         define-eh-alternative-set)

7-0-0-20/racket/collects/syntax/parse/lib/function-header.rkt

@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require "../../parse.rkt"
+         "../experimental/template.rkt"
+         racket/dict)
+
+(provide function-header formal formals)
+
+(define-syntax-class function-header
+  (pattern ((~or header:function-header name:id) . args:formals)
+           #:attr params
+           (template ((?@ . (?? header.params ()))
+                      . args.params))))
+
+(define-syntax-class formals
+  #:attributes (params)
+  (pattern (arg:formal ...)
+           #:attr params #'(arg.name ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing")
+  (pattern (arg:formal ... . rest:id)
+           #:attr params #'(arg.name ... rest)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing"))
+
+(define-splicing-syntax-class formal
+  #:attributes (name kw default)
+  (pattern name:id
+           #:attr kw #f
+           #:attr default #f)
+  (pattern [name:id default]
+           #:attr kw #f)
+  (pattern (~seq kw:keyword name:id)
+           #:attr default #f)
+  (pattern (~seq kw:keyword [name:id default])))
+
+;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
+;; Checks for mandatory argument after optional argument; if found, returns
+;; identifier of mandatory argument.
+(define (invalid-option-placement names defaults)
+  ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
+  ;; Finds first name w/o corresponding default.
+  (define (find-mandatory names defaults)
+    (for/first ([name (in-list names)]
+                [default (in-list defaults)]
+                #:when (not default))
+      name))
+  ;; Skip through mandatory args until first optional found, then search
+  ;; for another mandatory.
+  (let loop ([names names] [defaults defaults])
+    (cond [(or (null? names) (null? defaults))
+           #f]
+          [(eq? (car defaults) #f) ;; mandatory
+           (loop (cdr names) (cdr defaults))]
+          [else ;; found optional
+           (find-mandatory (cdr names) (cdr defaults))])))
+
+;; Copied from unstable/list
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))

7-0-0-20/racket/collects/syntax/parse/private/3d-stx.rkt

@@ -0,0 +1,250 @@
+#lang racket/base
+(require (only-in '#%flfxnum flvector? fxvector?)
+         (only-in '#%extfl extflonum? extflvector?))
+(provide 2d-stx?
+         check-datum)
+
+;; Checks for 3D syntax (syntax that contains unwritable values, etc)
+
+(define INIT-FUEL #e1e6)
+
+;; TO DO:
+;; - extension via proc (any -> list/#f),
+;;   value considered good if result is list, all values in list are good
+
+;; --
+
+#|
+Some other predicates one might like to have:
+ - would (read (write x)) succeed and be equal/similar to x?
+ - would (datum->syntax #f x) succeed?
+ - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
+ - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
+
+where equal/similar could mean one of the following:
+ - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
+ - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
+ - equal? but also requiring same mutability at every point
+
+Some aux definitions:
+
+(define (rt x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (read in))
+
+(define (wrsd x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (syntax->datum (read-syntax #f in)))
+
+(define (dsd x)
+  (syntax->datum (datum->syntax #f x)))
+
+(define (evalc x) ;; mimics compiled zo-file constraints
+  (eval (rt (compile `(quote ,x)))))
+
+How mutability behaves:
+ - for vectors, boxes:
+   - read always mutable
+   - read-syntax always immutable
+   - (dsd x) always immutable
+   - (evalc x) always immutable
+ - for hashes:
+   - read always immutable
+   - (dsd x) same as x
+   - (evalc x) always immutable (!!!)
+ - for prefab structs:
+   - read same as x
+   - read-syntax same as x
+   - (dsd x) same as x
+   - (evalc x) same as x
+
+Symbols
+ - (dsd x) same as x
+ - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
+
+Chaperones allow the lazy generation of infinite trees of data
+undetectable by eq?-based cycle detection.  Might be helpful to have
+chaperone-eq? (not recursive, just chaperones of same object) and
+chaperone-eq?-hash-code, to use with make-custom-hash.)
+
+Impersonators allow the lazy generation of infinite trees of data,
+period.
+
+|#
+
+;; ----
+
+;; 2d-stx? : any ... -> boolean
+;; Would (write (compile `(quote-syntax ,x))) succeed?
+;; If traverse-syntax? is #t, recurs into existing syntax
+;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
+;; checks if *new* 3d syntax would be created.
+(define (2d-stx? x
+                 #:traverse-syntax? [traverse-syntax? #t]
+                 #:irritant [irritant-box #f])
+  (check-datum x
+               #:syntax-mode (if traverse-syntax? 'compound 'atomic)
+               #:allow-impersonators? #f
+               #:allow-mutable? 'no-hash/prefab
+               #:allow-unreadable-symbols? #t
+               #:allow-cycles? #t
+               #:irritant irritant-box))
+
+;; ----
+
+;; check-datum : any ... -> boolean
+;; where StxMode = (U 'atomic 'compound #f)
+;; Returns nat if x is "good", #f if "bad"
+;; If irritant-b is a box, the first bad subvalue found is put in the box.
+;; If visited-t is a hash, it is used to detect cycles.
+(define (check-datum x
+                     #:syntax-mode [stx-mode #f]
+                     #:allow-impersonators? [allow-impersonators? #f]
+                     #:allow-mutable? [allow-mutable? #f]
+                     #:allow-unreadable-symbols? [allow-unreadable? #f]
+                     #:allow-cycles? [allow-cycles? #f]
+                     #:irritant [irritant-b #f])
+  ;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
+  (define (run fuel visited-t)
+    (check* x fuel visited-t
+            stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+            irritant-b))
+  (let ([result (run INIT-FUEL #f)])
+    (cond [(not (equal? result 0)) ;; nat>0 or #f
+           (and result #t)]
+          [else
+           ;; (eprintf "out of fuel, restarting\n")
+           (and (run +inf.0 (make-hasheq)) #t)])))
+
+;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
+;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
+;; If bad, places bad subvalue in irritant-b, if box
+(define (check* x0 fuel0 visited-t
+                stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+                irritant-b)
+  (define no-mutable? (not allow-mutable?))
+  (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
+  (define no-cycle? (not allow-cycles?))
+  (define no-impersonator? (not allow-impersonators?))
+  (define (loop x fuel)
+    (if (and fuel (not (zero? fuel)))
+        (loop* x fuel)
+        fuel))
+  (define (loop* x fuel)
+    (define (bad) (when irritant-b (set-box! irritant-b x)) #f)
+    (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
+      (cond [(and no-mutable? mutable?)
+             (bad)]
+            [else
+             body ...]))
+    (define-syntax-rule (with-cycle-check body ...)
+      (cond [(and visited-t (hash-ref visited-t x #f))
+             => (lambda (status)
+                  (cond [(and no-cycle? (eq? status 'traversing))
+                         (bad)]
+                        [else
+                         fuel]))]
+            [else
+             (when visited-t
+               (hash-set! visited-t x 'traversing))
+             (begin0 (begin body ...)
+               (when visited-t
+                 (hash-remove! visited-t x)))]))
+    ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
+    (cond
+     ;; Immutable compound
+     [(and visited-t (list? x))
+      ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
+      ;; don't do unless visited-t present, else expands fuel by arbitrary factors
+      (with-cycle-check
+       (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
+         (loop e fuel)))]
+     [(pair? x)
+      (with-cycle-check
+       (let ([fuel (loop (car x) (sub1 fuel))])
+         (loop (cdr x) fuel)))]
+     ;; Atomic
+     [(or (null? x)
+          (boolean? x)
+          (number? x)
+          (char? x)
+          (keyword? x)
+          (regexp? x)
+          (byte-regexp? x)
+          (extflonum? x))
+      fuel]
+     [(symbol? x)
+      (cond [(symbol-interned? x)
+             fuel]
+            [(symbol-unreadable? x)
+             (if allow-unreadable? fuel (bad))]
+            [else ;; uninterned
+             (if (eq? allow-unreadable? #t) fuel (bad))])]
+     ;; Mutable flat
+     [(or (string? x)
+          (bytes? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     [(or (fxvector? x)
+          (flvector? x)
+          (extflvector? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     ;; Syntax
+     [(syntax? x)
+      (case stx-mode
+        ((atomic) fuel)
+        ((compound) (loop (syntax-e x) fuel))
+        (else (bad)))]
+     ;; Impersonators and chaperones
+     [(and no-impersonator? (impersonator? x))  ;; else continue to chaperoned type
+      (bad)]
+     [(and no-impersonator? (chaperone? x))  ;; else continue to impersonated type
+      (bad)]
+     [else
+      (with-cycle-check
+       (cond
+        ;; Mutable (maybe) compound
+        [(vector? x)
+         (with-mutable-check (not (immutable? x))
+           (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
+             (loop e fuel)))]
+        [(box? x)
+         (with-mutable-check (not (immutable? x))
+           (loop (unbox x) (sub1 fuel)))]
+        [(prefab-struct-key x)
+         => (lambda (key)
+              (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
+                     (bad)]
+                    [else
+                     ;; traverse key, since contains arbitrary auto-value
+                     (let ([fuel (loop key fuel)])
+                       (loop (struct->vector x) fuel))]))]
+        [(hash? x)
+         (cond [(and no-mutable-hash/prefab? (not (immutable? x)))
+                (bad)]
+               [else
+                (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
+                  (let ([fuel (loop k fuel)])
+                    (loop v fuel)))])]
+        ;; Bad
+        [else
+         (bad)]))]))
+  (loop x0 fuel0))
+
+;; mutable-prefab-key? : prefab-key -> boolean
+(define (mutable-prefab-key? key)
+  ;; A prefab-key is either
+  ;;  - symbol
+  ;;  - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
+  ;; where mutable fields indicated by vector
+  ;; This code is probably overly general; racket seems to normalize keys.
+  (let loop ([k key])
+    (and (pair? k)
+         (or (and (vector? (car k))
+                  (positive? (vector-length (car k))))
+             (loop (cdr k))))))

7-0-0-20/racket/collects/syntax/parse/private/litconv.rkt

@@ -0,0 +1,284 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/lazy-require
+                     "sc.rkt"
+                     "lib.rkt"
+                     syntax/parse/private/kws
+                     racket/syntax)
+         syntax/parse/private/residual-ct ;; keep abs. path
+         stxparse-info/parse/private/residual)   ;; keep abs. path
+(begin-for-syntax
+ (lazy-require
+  [syntax/private/keyword (options-select-value parse-keyword-options)]
+  [stxparse-info/parse/private/rep ;; keep abs. path
+   (parse-kw-formals
+    check-conventions-rules
+    check-datum-literals-list
+    create-aux-def)]))
+;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
+;; Without this, dependencies don't get collected.
+(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
+
+(provide define-conventions
+         define-literal-set
+         literal-set->predicate
+         kernel-literals)
+
+(define-syntax (define-conventions stx)
+
+  (define-syntax-class header
+    #:description "name or name with formal parameters"
+    #:commit
+    (pattern name:id
+             #:with formals #'()
+             #:attr arity (arity 0 0 null null))
+    (pattern (name:id . formals)
+             #:attr arity (parse-kw-formals #'formals #:context stx)))
+
+  (syntax-parse stx
+    [(define-conventions h:header rule ...)
+     (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 (in-list 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 (class-name ...)
+         (map den:delayed-class dens))
+
+       ;; FIXME: could move make-den:delayed to user of conventions
+       ;; and eliminate from residual.rkt
+       #'(begin
+           (define-syntax h.name
+             (make-conventions
+              (quote-syntax get-parsers)
+              (lambda ()
+                (let ([class-names (list (quote-syntax class-name) ...)])
+                  (map list
+                       (list 'rx ...)
+                       (map make-den:delayed
+                            (generate-temporaries class-names)
+                            class-names))))))
+           (define get-parsers
+             (lambda formals
+               def ...
+               (list parser ...)))))]))
+
+(define-for-syntax (check-phase-level stx ctx)
+  (unless (or (exact-integer? (syntax-e stx))
+              (eq? #f (syntax-e stx)))
+    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
+  stx)
+
+;; check-litset-list : stx stx -> (listof (cons id literalset))
+(define-for-syntax (check-litset-list stx ctx)
+  (syntax-case stx ()
+    [(litset-id ...)
+     (for/list ([litset-id (syntax->list #'(litset-id ...))])
+       (let* ([val (and (identifier? litset-id)
+                        (syntax-local-value/record litset-id literalset?))])
+         (if val
+             (cons litset-id val)
+             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
+    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
+
+;; check-literal-entry/litset : stx stx -> (list id id)
+(define-for-syntax (check-literal-entry/litset stx ctx)
+  (syntax-case stx ()
+    [(internal external)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external)]
+    [id
+     (identifier? #'id)
+     (list #'id #'id)]
+    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits)
+  (let ([lit-t (make-hasheq)]) ;; sym => #t
+    (define (check+enter! key blame-stx)
+      (when (hash-ref lit-t key #f)
+        (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx))
+      (hash-set! lit-t key #t))
+    (for ([id+litset (in-list imports)])
+      (let ([litset-id (car id+litset)]
+            [litset (cdr id+litset)])
+        (for ([entry (in-list (literalset-literals litset))])
+          (cond [(lse:lit? entry)
+                 (check+enter! (lse:lit-internal entry) litset-id)]
+                [(lse:datum-lit? entry)
+                 (check+enter! (lse:datum-lit-internal entry) litset-id)]))))
+    (for ([datum-lit (in-list datum-lits)])
+      (let ([internal (den:datum-lit-internal datum-lit)])
+        (check+enter! (syntax-e internal) internal)))
+    (for ([lit (in-list lits)])
+      (check+enter! (syntax-e (car lit)) (car lit)))))
+
+(define-syntax (define-literal-set stx)
+  (syntax-case stx ()
+    [(define-literal-set name . rest)
+     (let-values ([(chunks rest)
+                   (parse-keyword-options
+                    #'rest
+                    `((#:literal-sets ,check-litset-list)
+                      (#:datum-literals ,check-datum-literals-list)
+                      (#:phase ,check-phase-level)
+                      (#:for-template)
+                      (#:for-syntax)
+                      (#:for-label))
+                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
+                    #:context stx
+                    #:no-duplicates? #t)])
+       (unless (identifier? #'name)
+         (raise-syntax-error #f "expected identifier" stx #'name))
+       (let ([relphase
+              (cond [(assq '#:for-template chunks) -1]
+                    [(assq '#:for-syntax chunks) 1]
+                    [(assq '#:for-label chunks) #f]
+                    [else (options-select-value chunks '#:phase #:default 0)])]
+             [datum-lits
+              (options-select-value chunks '#:datum-literals #:default null)]
+             [lits (syntax-case rest ()
+                     [( (lit ...) )
+                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
+                        (check-literal-entry/litset lit stx))]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [imports (options-select-value chunks '#:literal-sets #:default null)])
+         (check-duplicate-literals stx imports lits datum-lits)
+         (with-syntax ([((internal external) ...) lits]
+                       [(datum-internal ...) (map den:datum-lit-internal datum-lits)]
+                       [(datum-external ...) (map den:datum-lit-external datum-lits)]
+                       [(litset-id ...) (map car imports)]
+                       [relphase relphase])
+           #`(begin
+               (define phase-of-literals
+                 (and 'relphase
+                      (+ (variable-reference->module-base-phase (#%variable-reference))
+                         'relphase)))
+               (define-syntax name
+                 (make-literalset
+                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
+                          ...
+                          (list (make-lse:lit 'internal
+                                              (quote-syntax external)
+                                              (quote-syntax phase-of-literals))
+                                ...
+                                (make-lse:datum-lit 'datum-internal
+                                                    'datum-external)
+                                ...))))
+               (begin-for-syntax/once
+                (for ([x (in-list (syntax->list #'(external ...)))])
+                  (unless (identifier-binding x 'relphase)
+                    (raise-syntax-error #f
+                                        (format "literal is unbound in phase ~a~a~a"
+                                                'relphase
+                                                (case 'relphase
+                                                  ((1) " (for-syntax)")
+                                                  ((-1) " (for-template)")
+                                                  ((#f) " (for-label)")
+                                                  (else ""))
+                                                " relative to the enclosing module")
+                                        (quote-syntax #,stx) x))))))))]))
+
+#|
+NOTES ON PHASES AND BINDINGS
+
+(module M ....
+  .... (define-literal-set LS #:phase PL ....)
+  ....)
+
+For the expansion of the define-literal-set form, the bindings of the literals
+can be accessed by (identifier-binding lit PL), because the phase of the enclosing
+module (M) is 0.
+
+LS may be used, however, in a context where the phase of the enclosing
+module is not 0, so each instantiation of LS needs to calculate the
+phase of M and add that to PL.
+
+--
+
+Normally, literal sets that define the same name conflict. But it
+would be nice to allow them to both be imported in the case where they
+refer to the same binding.
+
+Problem: Can't do the check eagerly, because the binding of L may
+change between when define-literal-set is compiled and the comparison
+involving L. For example:
+
+  (module M racket
+    (require stxparse-info/parse)
+    (define-literal-set LS (lambda))
+    (require (only-in some-other-lang lambda))
+    .... LS ....)
+
+The expansion of the LS definition sees a different lambda than the
+one that the literal in LS actually refers to.
+
+Similarly, a literal in LS might not be defined when the expander
+runs, but might get defined later. (Although I think that will already
+cause an error, so don't worry about that case.)
+|#
+
+;; FIXME: keep one copy of each identifier (?)
+
+(define-syntax (literal-set->predicate stx)
+  (syntax-case stx ()
+    [(literal-set->predicate litset-id)
+     (let ([val (and (identifier? #'litset-id)
+                     (syntax-local-value/record #'litset-id literalset?))])
+       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
+       (let ([lits (literalset-literals val)])
+         (with-syntax ([((lit phase-var) ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:lit? lit))
+                          (list (lse:lit-external lit) (lse:lit-phase lit)))]
+                       [(datum-lit ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:datum-lit? lit))
+                          (lse:datum-lit-external lit))])
+           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
+                                         '(datum-lit ...)))))]))
+
+(define (make-literal-set-predicate lits datum-lits)
+  (lambda (x [phase (syntax-local-phase-level)])
+    (or (for/or ([lit (in-list lits)])
+          (let ([lit-id (car lit)]
+                [lit-phase (cadr lit)])
+            (free-identifier=? x lit-id phase lit-phase)))
+        (and (memq (syntax-e x) datum-lits) #t))))
+
+;; Literal sets
+
+(define-literal-set kernel-literals
+  (begin
+   begin0
+   define-values
+   define-syntaxes
+   define-values-for-syntax ;; kept for compat.
+   begin-for-syntax
+   set!
+   let-values
+   letrec-values
+   #%plain-lambda
+   case-lambda
+   if
+   quote
+   quote-syntax
+   letrec-syntaxes+values
+   with-continuation-mark
+   #%expression
+   #%plain-app
+   #%top
+   #%datum
+   #%variable-reference
+   module module* #%provide #%require #%declare
+   #%plain-module-begin))

7-0-0-20/racket/collects/syntax/parse/private/make.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/struct-info))
+(provide make)
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
+
+;; (make struct-name field-expr ...)
+;; Checks that correct number of fields given.
+(define-syntax (make stx)
+  (syntax-case stx ()
+    [(make S expr ...)
+     (let ()
+       (define info (get-struct-info #'S stx))
+       (define constructor (list-ref info 1))
+       (define accessors (list-ref info 3))
+       (unless (identifier? #'constructor)
+         (raise-syntax-error #f "constructor not available for struct" stx #'S))
+       (unless (andmap identifier? accessors)
+         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
+       (let ([num-slots (length accessors)]
+             [num-provided (length (syntax->list #'(expr ...)))])
+         (unless (= num-provided num-slots)
+           (raise-syntax-error
+            #f
+            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
+                    (syntax-e #'S)
+                    num-slots
+                    num-provided)
+            stx)))
+       (with-syntax ([constructor constructor])
+         (syntax-property #'(constructor expr ...)
+                          'disappeared-use
+                          #'S)))]))

7-0-0-20/racket/collects/syntax/parse/private/runtime-progress.rkt

@@ -0,0 +1,257 @@
+#lang racket/base
+(require racket/list
+         syntax/parse/private/minimatch)
+(provide ps-empty
+         ps-add-car
+         ps-add-cdr
+         ps-add-stx
+         ps-add-unbox
+         ps-add-unvector
+         ps-add-unpstruct
+         ps-add-opaque
+         ps-add-post
+         ps-add
+         (struct-out ord)
+
+         ps-pop-opaque
+         ps-pop-ord
+         ps-pop-post
+         ps-context-syntax
+         ps-difference
+
+         (struct-out failure)
+         failure*
+
+         expect?
+         (struct-out expect:thing)
+         (struct-out expect:atom)
+         (struct-out expect:literal)
+         (struct-out expect:message)
+         (struct-out expect:disj)
+         (struct-out expect:proper-pair)
+
+         es-add-thing
+         es-add-message
+         es-add-atom
+         es-add-literal
+         es-add-proper-pair)
+
+;; FIXME: add phase to expect:literal
+
+;; == Failure ==
+
+#|
+A Failure is (failure PS ExpectStack)
+
+A FailureSet is one of
+  - Failure
+  - (cons FailureSet FailureSet)
+
+A FailFunction = (FailureSet -> Answer)
+|#
+(define-struct failure (progress expectstack) #:prefab)
+
+;; failure* : PS ExpectStack/#f -> Failure/#t
+(define (failure* ps es) (if es (failure ps es) #t))
+
+;; == Progress ==
+
+#|
+Progress (PS) is a non-empty list of Progress Frames (PF).
+
+A Progress Frame (PF) is one of
+  - stx     ;; "Base" frame, or ~parse/#:with term
+  - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
+  - nat     ;; Represents that many repeated cdrs
+  - 'post   ;; late/post-traversal check
+  - #s(ord group index) ;; ~and subpattern, only comparable w/in group
+  - 'opaque
+
+The error-reporting context (ie, syntax-parse #:context arg) is always
+the final frame.
+
+All non-stx frames (eg car, cdr) interpreted as applying to nearest following
+stx frame.
+
+A stx frame is introduced
+  - always at base (that is, by syntax-parse)
+    - if syntax-parse has #:context arg, then two stx frames at bottom:
+      (list to-match-stx context-stx)
+  - by #:with/~parse
+  - by #:fail-*/#:when/~fail & stx
+
+Interpretation: later frames are applied first.
+ eg, (list 'car 1 stx)
+      means ( car of ( cdr once of stx ) )
+      NOT apply car, then apply cdr once, then stop
+|#
+(define-struct ord (group index) #:prefab)
+
+(define (ps-empty stx ctx)
+  (if (eq? stx ctx)
+      (list stx)
+      (list stx ctx)))
+(define (ps-add-car parent)
+  (cons 'car parent))
+(define (ps-add-cdr parent [times 1])
+  (if (zero? times)
+      parent
+      (match (car parent)
+        [(? exact-positive-integer? n)
+         (cons (+ times n) (cdr parent))]
+        [_
+         (cons times parent)])))
+(define (ps-add-stx parent stx)
+  (cons stx parent))
+(define (ps-add-unbox parent)
+  (ps-add-car parent))
+(define (ps-add-unvector parent)
+  (ps-add-car parent))
+(define (ps-add-unpstruct parent)
+  (ps-add-car parent))
+(define (ps-add-opaque parent)
+  (cons 'opaque parent))
+(define (ps-add parent frame)
+  (cons frame parent))
+(define (ps-add-post parent)
+  (cons 'post parent))
+
+;; ps-context-syntax : Progress -> syntax
+(define (ps-context-syntax ps)
+  ;; Bottom frame is always syntax
+  (last ps))
+
+;; ps-difference : PS PS -> nat
+;; Returns N s.t. B = (ps-add-cdr^N A)
+(define (ps-difference a b)
+  (define-values (a-cdrs a-base)
+    (match a
+      [(cons (? exact-positive-integer? a-cdrs) a-base)
+       (values a-cdrs a-base)]
+      [_ (values 0 a)]))
+  (define-values (b-cdrs b-base)
+    (match b
+      [(cons (? exact-positive-integer? b-cdrs) b-base)
+       (values b-cdrs b-base)]
+      [_ (values 0 b)]))
+  (unless (eq? a-base b-base)
+    (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
+  (- b-cdrs a-cdrs))
+
+;; ps-pop-opaque : PS -> PS
+;; Used to continue with progress from opaque head pattern.
+(define (ps-pop-opaque ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'opaque ps*)
+     ps*]
+    [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
+
+;; ps-pop-ord : PS -> PS
+(define (ps-pop-ord ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
+     (ps-add-cdr ps* n)]
+    [(cons (? ord?) ps*)
+     ps*]
+    [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
+
+;; ps-pop-post : PS -> PS
+(define (ps-pop-post ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'post ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'post ps*)
+     ps*]
+    [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
+
+
+;; == Expectations ==
+
+#|
+There are multiple types that use the same structures, optimized for
+different purposes.
+
+-- During parsing, the goal is to minimize/consolidate allocations.
+
+An ExpectStack (during parsing) is one of
+  - (expect:thing Progress String Boolean String/#f ExpectStack)
+  * (expect:message String ExpectStack)
+  * (expect:atom Datum ExpectStack)
+  * (expect:literal Identifier ExpectStack)
+  * (expect:proper-pair FirstDesc ExpectStack)
+  * #t
+
+The *-marked variants can only occur at the top of the stack (ie, not
+in the next field of another Expect). The top of the stack contains
+the most specific information.
+
+An ExpectStack can also be #f, which means no failure tracking is
+requested (and thus no more ExpectStacks should be allocated).
+
+-- During reporting, the goal is ease of manipulation.
+
+An ExpectList (during reporting) is (listof Expect).
+
+An Expect is one of
+  - (expect:thing #f String #t String/#f StxIdx)
+  * (expect:message String StxIdx)
+  * (expect:atom Datum StxIdx)
+  * (expect:literal Identifier StxIdx)
+  * (expect:proper-pair FirstDesc StxIdx)
+  * (expect:disj (NEListof Expect) StxIdx)
+  - '...
+
+A StxIdx is (cons Syntax Nat)
+
+That is, the next link is replaced with the syntax+index of the term
+being complained about. An expect:thing's progress is replaced with #f.
+
+An expect:disj never contains a '... or another expect:disj.
+
+We write ExpectList when the most specific information comes first and
+RExpectList when the most specific information comes last.
+|#
+(struct expect:thing (term description transparent? role next) #:prefab)
+(struct expect:message (message next) #:prefab)
+(struct expect:atom (atom next) #:prefab)
+(struct expect:literal (literal next) #:prefab)
+(struct expect:disj (expects next) #:prefab)
+(struct expect:proper-pair (first-desc next) #:prefab)
+
+(define (expect? x)
+  (or (expect:thing? x)
+      (expect:message? x)
+      (expect:atom? x)
+      (expect:literal? x)
+      (expect:disj? x)
+      (expect:proper-pair? x)))
+
+(define (es-add-thing ps description transparent? role next)
+  (if (and next description)
+      (expect:thing ps description transparent? role next)
+      next))
+
+(define (es-add-message message next)
+  (if (and next message)
+      (expect:message message next)
+      next))
+
+(define (es-add-atom atom next)
+  (and next (expect:atom atom next)))
+
+(define (es-add-literal literal next)
+  (and next (expect:literal literal next)))
+
+(define (es-add-proper-pair first-desc next)
+  (and next (expect:proper-pair first-desc next)))
+
+#|
+A FirstDesc is one of
+ - #f                   -- unknown, multiple possible, etc
+ - string               -- description
+ - (list 'any)
+ - (list 'literal symbol)
+ - (list 'datum datum)
+|#

7-0-0-20/racket/collects/syntax/parse/private/txlift.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+(require (for-template racket/base))
+(provide txlift
+         get-txlifts-as-definitions
+         with-txlifts
+         call/txlifts)
+
+;; Like lifting definitions, but within a single transformer.
+
+;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))]
+(define current-liftbox (make-parameter #f))
+
+(define (call/txlifts proc)
+  (parameterize ((current-liftbox (box null)))
+    (proc)))
+
+(define (txlift expr)
+  (let ([liftbox (current-liftbox)])
+    (check 'txlift liftbox)
+    (let ([var (car (generate-temporaries '(txlift)))])
+      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
+      var)))
+
+(define (get-txlifts)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts liftbox)
+    (reverse (unbox liftbox))))
+
+(define (get-txlifts-as-definitions)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts-as-definitions liftbox)
+    (map (lambda (p)
+           #`(define #,@p))
+         (reverse (unbox liftbox)))))
+
+(define (check who lb)
+  (unless (box? lb)
+    (error who "not in a txlift-catching context")))
+
+(define (with-txlifts proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([((var rhs) ...) (get-txlifts)])
+         #`(let* ([var rhs] ...) #,v))))))

7-0-0-20/stxparse-info.scrbl

@@ -0,0 +1,356 @@
+#lang scribble/manual
+@require[racket/require
+         @for-label[stxparse-info/parse
+                    stxparse-info/parse/experimental/template
+                    stxparse-info/case
+                    stxparse-info/current-pvars
+                    (subtract-in racket/syntax stxparse-info/case)
+                    (subtract-in racket/base stxparse-info/case)]
+         version-case
+         @for-syntax[racket/base]
+         "ovl.rkt"]
+
+@; Circumvent https://github.com/racket/scribble/issues/79
+@(require scribble/struct
+          scribble/decode)
+@(define (nested-inset . vs)
+   (nested #:style 'inset vs))
+
+@(version-case 
+  [(version< (version) "6.4")
+   ]
+  [else
+   (require scribble/example)
+   (define ev ((make-eval-factory '(racket))))])
+
+@title{@racketmodname[stxparse-info]: Track @racket[syntax-parse] and @racket[syntax-case] pattern vars}
+@author[@author+email["Suzanne Soy" "racket@suzanne.soy"]]
+
+Source code: @url{https://github.com/jsmaniac/stxparse-info}
+
+@defmodule[stxparse-info]
+
+This library provides some patched versions of @orig:syntax-parse and of the
+@orig:syntax-case family. These patched versions track which syntax pattern
+variables are bound. This allows some libraries to change the way syntax
+pattern variables work.
+
+For example, @tt{subtemplate} automatically derives temporary
+identifiers when a template contains @racket[yᵢ …], and @racket[xᵢ] is a
+pattern variable. To know from which @racket[varᵢ] the @racket[yᵢ …]
+identifiers must be derived, @tt{subtemplate} needs to know which
+syntax pattern variables are within scope.
+
+@section{Tracking currently-bound pattern variables with @racket[syntax-parse]}
+
+@defmodule[stxparse-info/parse]
+
+The module @racketmodname[stxparse-info/parse] provides patched versions of
+@orig:syntax-parse, @orig:syntax-parser and @orig:define/syntax-parse which
+track which syntax pattern variables are bound.
+
+@(ovl syntax/parse
+      syntax-parse
+      syntax-parser
+      define/syntax-parse)
+
+Additionally, the following identifiers are overridden as they are part of the
+duplicated implementation of @racketmodname[syntax/parse].
+
+@(ovl #:wrapper nested-inset
+      syntax/parse
+      ...+
+      attribute
+      boolean
+      char
+      character
+      define-conventions
+      define-eh-alternative-set
+      define-literal-set
+      define-splicing-syntax-class
+      define-syntax-class
+      exact-integer
+      exact-nonnegative-integer
+      exact-positive-integer
+      expr
+      expr/c
+      id
+      identifier
+      integer
+      kernel-literals
+      keyword
+      literal-set->predicate
+      nat
+      number
+      pattern
+      static
+      str
+      syntax-parse-state-cons!
+      syntax-parse-state-ref
+      syntax-parse-state-set!
+      syntax-parse-state-update! 
+      syntax-parse-track-literals
+      this-syntax
+      ~!
+      ~and
+      ~between
+      ~bind
+      ~commit
+      ~datum
+      ~delimit-cut
+      ~describe
+      ~do
+      ~fail
+      ~literal
+      ~not
+      ~once
+      ~optional
+      ~or
+      ~parse
+      ~peek
+      ~peek-not
+      ~post
+      ~rest
+      ~seq
+      ~undo
+      ~var)
+
+@(version-case
+  [(version>= (version) "6.9.0.6")
+   (ovl #:wrapper nested-inset
+        syntax/parse
+        ~alt
+        ~or*)]
+  [else (begin)])
+
+@(ovl #:wrapper nested-inset
+      #:require (for-template syntax/parse)
+      syntax/parse
+      pattern-expander?
+      pattern-expander
+      prop:pattern-expander
+      syntax-local-syntax-parse-pattern-introduce)
+
+@section{Tracking currently-bound pattern variables with @racket[syntax-case]}
+
+@defmodule[stxparse-info/case]
+
+The module @racketmodname[stxparse-info/case] provides patched versions of
+@orig:syntax-case, @orig:syntax-case*, @orig:with-syntax,
+@orig:define/with-syntax, @orig:datum-case and @orig:with-datum which
+track which syntax or datum pattern variables are bound.
+
+@(ovl racket/base
+      syntax-case
+      syntax-case*
+      with-syntax)
+
+@(ovl syntax/datum
+      datum-case
+      with-datum)
+
+@(ovl racket/syntax
+      define/with-syntax)
+
+@section{Reading and updating the list of currently-bound pattern variables}
+
+@defmodule[stxparse-info/current-pvars] 
+
+@defproc[#:kind "procedure at phase 1"
+         (current-pvars) (listof identifier?)]{
+ This for-syntax procedure returns the list of syntax pattern variables which
+ are known to be bound. The most recently bound variables are at the beginning
+ of the list.
+
+ It is the responsibility of the reader to check that the identifiers are
+ bound, and that they are bound to syntax pattern variables, for example using
+ @racket[identifier-binding] and @racket[syntax-pattern-variable?]. This allows
+ libraries to also track variables bound by match-like forms, for example.}
+
+@defproc[#:kind "procedure at phase 1"
+         (current-pvars+unique) (listof (pairof identifier? identifier?))]{
+ This for-syntax procedure works like @racket[current-pvars], but associates
+ each syntax pattern variable with an identifier containing a unique symbol
+ which is generated at each execution of the code recording the pattern
+ variable via @racket[with-pvars] or @racket[define-pvars].
+
+ The @racket[car] of each pair in the returned list is the syntax pattern
+ variable (as produced by @racket[current-pvars]). It is the responsibility of
+ the reader to check that the identifiers present in the @racket[car] of each
+ element of the returned list are bound, and that they are bound to syntax
+ pattern variables, for example using @racket[identifier-binding] and
+ @racket[syntax-pattern-variable?]. This allows libraries to also track
+ variables bound by match-like forms, for example.
+
+ The @racket[cdr] of each pair is the identifier of a temporary variable.
+ Reading that temporary variable produces a @racket[gensym]-ed symbol, which
+ was generated at run-time at the point where @racket[with-pvars] or
+ @racket[define-pvars] was used to record the corresponding pattern variable.
+
+ This can be used to associate run-time data with each syntax pattern
+ variable, via a weak hash table created with @racket[make-weak-hasheq]. For
+ example, the @tt{subtemplate} library implicitly derives
+ identifiers (similarly to @racket[generate-temporaries]) for uses of
+ @racket[yᵢ ...] from a @racket[xᵢ] pattern variable bearing the same
+ subscript. The generated identifiers are associated with @racket[xᵢ] via this
+ weak hash table mechanism, so that two uses of @racket[yᵢ ...] within the
+ scope of the same @racket[xᵢ] binding derive the same identifiers.
+
+ The code @racket[(with-pvars (v) body)] roughly expands to:
+
+ @racketblock[
+ (let-values ([(tmp) (gensym 'v)])
+   (letrec-syntaxes+values ([(shadow-current-pvars)
+                             (list* (cons (quote-syntax v)
+                                          (quote-syntax tmp))
+                                    old-current-pvars)])
+     body))]
+
+ @bold{Caveat:} this entails that the fresh symbol stored in @racket[tmp] is
+ generated when @racket[with-pvars] or @racket[define-pvars] is called, not
+ when the syntax pattern variable is actually bound. For example:
+
+ @RACKETBLOCK[
+ (define-syntax (get-current-pvars+unique stx)
+   #`'#,(current-pvars+unique))
+              
+ (require racket/private/sc)
+ (let ([my-valvar (quote-syntax x)])
+   (let-syntax ([my-pvar (make-syntax-mapping 0 (quote-syntax my-valvar))])
+     (with-pvars (x)
+       (get-current-pvars+unique)) (code:comment "'([x . g123])")
+     (with-pvars (x)
+       (get-current-pvars+unique)))) (code:comment "'([x . g124])")]
+
+ Under normal circumstances, @racket[with-pvars] @racket[define-pvars] should
+ be called immediately after binding the syntax pattern variable, but the code
+ above shows that it is technically possible to do otherwise.
+
+ This caveat is not meant to dissuade the use of
+ @racket[current-pvars+unique], it rather serves as an explanation of the
+ behaviour encountered when @racket[with-pvars] or @racket[define-pvars] are
+ incorrectly used more than once to record the same pattern variable.}
+
+@defform[(with-pvars (pvar ...) . body)
+         #:contracts ([pvar identifier?])]{
+ Prepends the given @racket[pvar ...] to the list of pattern variables which
+ are known to be bound. The @racket[pvar ...] are prepended in reverse order,
+ so within the body of
+
+ @racketblock[(with-pvars (v₁ v₂ v₃) . body)]
+ 
+ a call to the for-syntax function @racket[(current-pvars)] returns:
+
+ @racketblock[(list* (quote-syntax v₃) (quote-syntax v₂) (quote-syntax v₁)
+                     old-current-pvars)]
+
+ This can be used to implement macros which work similarly to
+ @racket[syntax-parse] or @racket[syntax-case], and have them record the syntax
+ pattern variables which they bind.
+
+ Note that the identifiers @racket[pvar ...] must already be bound to syntax
+ pattern variables when @racket[with-pvars] is used, e.g.
+
+ @racketblock[
+ (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))]
+              [v₂ (make-syntax-mapping depth (quote-syntax valvar))])
+   (with-pvars (v₁ v₂)
+     code))]
+
+ instead of:
+
+ @racketblock[
+ (with-pvars (v₁ v₂)
+   (let-syntax ([v₁ (make-syntax-mapping depth (quote-syntax valvar))]
+                [v₂ (make-syntax-mapping depth (quote-syntax valvar))])
+     code))]}
+
+@defform[(define-pvars pvar ...)
+         #:contracts ([pvar identifier?])]{
+                                           
+ Prepends the given @racket[pvar ...] to the list of pattern variables which
+ are known to be bound, in the same way as @racket[with-pvars]. Whereas
+ @racket[with-pvars] makes the modified list visible in the @racket[_body],
+ @racket[define-pvars] makes the modified list visible in the statements
+ following @racket[define-pvars]. @racket[define-pvars] can be used multiple
+ times within the same @racket[let] or equivalent.
+
+ This can be used to implement macros which work similarly to
+ @racket[define/syntax-parse] or @racket[define/with-syntax], and have them
+ record the syntax pattern variables which they bind.
+
+ @(version-case 
+   [(version< (version) "6.4")
+    @RACKETBLOCK[
+ (let ()
+   (code:comment "Alternate version of define/syntax-parse which")
+   (code:comment "contains (define-pvars x) in its expanded form.")
+   (define/syntax-parse x #'1)
+   (define/syntax-parse y #'2)
+   (define-syntax (get-pvars stx)
+     #`'#,(current-pvars))
+   (get-pvars))
+ (code:comment "=> '(y x)")]]
+   [else
+    @examples[
+ #:eval ev
+ #:hidden
+ (require stxparse-info/parse
+          stxparse-info/current-pvars
+          racket/syntax
+          (for-syntax racket/base))]
+ 
+    @examples[
+ #:eval ev
+ #:escape UNSYNTAX
+ (eval:check
+  (let ()
+    (code:comment "Alternate version of define/syntax-parse which")
+    (code:comment "contains (define-pvars x) in its expanded form.")
+    (define/syntax-parse x #'1)
+    (define/syntax-parse y #'2)
+    (define-syntax (get-pvars stx)
+      #`'#,(current-pvars))
+    (get-pvars))
+  '(y x))]])}
+
+@section{Extensions to @racketmodname[syntax/parse/experimental/template]}
+
+@defmodule[stxparse-info/parse/experimental/template]
+
+@(orig syntax/parse/experimental/template
+       define-template-metafunction)
+
+@defidform[define-template-metafunction]{
+ Overloaded version of @orig:define-template-metafunction from
+ @racketmodname[syntax/parse/experimental/template].
+
+ Note that currently, template metafunctions defined via
+ @racketmodname[stxparse-info/parse/experimental/template] are not compatible
+ with the forms from @racketmodname[syntax/parse/experimental/template], and
+ vice versa. There is a pending Pull Request which would make the necessary
+ primitives from @racketmodname[syntax/parse/experimental/template] public, so
+ hopefully this problem will be solved in future versions.}
+
+@defform[(syntax-local-template-metafunction-introduce stx)]{
+ Like @racket[syntax-local-introduce], but for
+ @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{template metafunctions}.
+
+ This change is also available in the package
+ @racketmodname{backport-template-pr1514}. It has been submitted as a Pull
+ Request to Racket, but can already be used in
+ @racketmodname[stxparse-info/parse/experimental/template] right now.}
+
+@(ovl syntax/parse/experimental/template
+      template
+      quasitemplate
+      template/loc
+      quasitemplate/loc)
+
+Additionally, the following identifiers are overridden as they are part of the
+duplicated implementation of @racketmodname[syntax/parse].
+
+@(ovl #:wrapper nested-inset
+      syntax/parse/experimental/template
+      ??
+      ?@)

7-3-0-1/racket/collects/syntax/parse/define.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     stxparse-info/parse
+                     "private/sc.rkt"))
+(provide define-simple-macro
+         define-syntax-parser
+         (for-syntax (all-from-out stxparse-info/parse)))
+
+(define-syntax (define-simple-macro stx)
+  (syntax-parse stx
+    [(define-simple-macro (~and (macro:id . _) pattern) . body)
+     #`(define-syntax macro
+         (syntax-parser/template
+          #,((make-syntax-introducer) stx)
+          [pattern . body]))]))
+
+(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
+  (define-syntax macro
+    (syntax-parser option-or-clause ...)))
+

7-3-0-1/racket/collects/syntax/parse/experimental/dset.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+;; A dset is an `equal?`-based set, but it preserves order based on
+;; the history of additions, so that if items are added in a
+;; deterministic order, they come back out in a deterministic order.
+
+(provide dset
+         dset-empty?
+         dset->list
+         dset-add
+         dset-union
+         dset-subtract
+         dset-filter)
+
+(define dset
+  (case-lambda
+    [() (hash)]
+    [(e) (hash e 0)]))
+
+(define (dset-empty? ds)
+  (zero? (hash-count ds)))
+
+(define (dset->list ds)
+  (map cdr
+       (sort (for/list ([(k v) (in-hash ds)])
+               (cons v k))
+             <
+             #:key car)))
+
+(define (dset-add ds e)
+  (if (hash-ref ds e #f)
+      ds
+      (hash-set ds e (hash-count ds))))
+
+(define (dset-union ds1 ds2)
+  (cond
+   [((hash-count ds1) . > . (hash-count ds2))
+    (dset-union ds2 ds1)]
+   [else
+    (for/fold ([ds2 ds2]) ([e (dset->list ds1)])
+      (dset-add ds2 e))]))
+
+(define (dset-subtract ds1 ds2)
+  ;; ! takes O(size(ds2)) time !
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
+    (if (hash-ref ds2 e #f)
+        r
+        (dset-add r e))))
+
+(define (dset-filter ds pred)
+  (for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
+    (if (pred e)
+        (dset-add r e)
+        r)))

7-3-0-1/racket/collects/syntax/parse/experimental/eh.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+(require "../private/sc.rkt"
+         syntax/parse/private/keywords)
+(provide ~eh-var
+         define-eh-alternative-set)

7-3-0-1/racket/collects/syntax/parse/lib/function-header.rkt

@@ -0,0 +1,112 @@
+#lang racket/base
+
+(require "../../parse.rkt"
+         "../experimental/template.rkt"
+         racket/dict)
+
+(provide function-header formal formals)
+
+(define-syntax-class function-header
+  (pattern ((~or header:function-header name:id) . args:formals)
+           #:attr params
+           (template ((?@ . (?? header.params ()))
+                      . args.params))))
+
+(define-syntax-class formals
+  #:attributes (params)
+  (pattern (arg:formal ...)
+           #:attr params #'(arg.name ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing")
+  (pattern (arg:formal ... . rest:id)
+           #:attr params #'(arg.name ... rest)
+           #:fail-when (check-duplicate-identifier (syntax->list #'params))
+                       "duplicate argument name"
+           #:fail-when (check-duplicate (attribute arg.kw)
+                                        #:same? (λ (x y)
+                                                  (and x y (equal? (syntax-e x)
+                                                                   (syntax-e y)))))
+                       "duplicate keyword for argument"
+           #:fail-when (invalid-option-placement
+                        (attribute arg.name) (attribute arg.default))
+                       "default-value expression missing"))
+
+(define-splicing-syntax-class formal
+  #:attributes (name kw default)
+  (pattern name:id
+           #:attr kw #f
+           #:attr default #f)
+  (pattern [name:id default]
+           #:attr kw #f)
+  (pattern (~seq kw:keyword name:id)
+           #:attr default #f)
+  (pattern (~seq kw:keyword [name:id default])))
+
+;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
+;; Checks for mandatory argument after optional argument; if found, returns
+;; identifier of mandatory argument.
+(define (invalid-option-placement names defaults)
+  ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
+  ;; Finds first name w/o corresponding default.
+  (define (find-mandatory names defaults)
+    (for/first ([name (in-list names)]
+                [default (in-list defaults)]
+                #:when (not default))
+      name))
+  ;; Skip through mandatory args until first optional found, then search
+  ;; for another mandatory.
+  (let loop ([names names] [defaults defaults])
+    (cond [(or (null? names) (null? defaults))
+           #f]
+          [(eq? (car defaults) #f) ;; mandatory
+           (loop (cdr names) (cdr defaults))]
+          [else ;; found optional
+           (find-mandatory (cdr names) (cdr defaults))])))
+
+;; Copied from unstable/list
+;; check-duplicate : (listof X)
+;;                   #:key (X -> K)
+;;                   #:same? (or/c (K K -> bool) dict?)
+;;                -> X or #f
+(define (check-duplicate items
+                        #:key [key values]
+                        #:same? [same? equal?])
+  (cond [(procedure? same?)
+         (cond [(eq? same? equal?)
+                (check-duplicate/t items key (make-hash) #t)]
+               [(eq? same? eq?)
+                (check-duplicate/t items key (make-hasheq) #t)]
+               [(eq? same? eqv?)
+                (check-duplicate/t items key (make-hasheqv) #t)]
+               [else
+                (check-duplicate/list items key same?)])]
+        [(dict? same?)
+         (let ([dict same?])
+           (if (dict-mutable? dict)
+               (check-duplicate/t items key dict #t)
+               (check-duplicate/t items key dict #f)))]))
+(define (check-duplicate/t items key table mutating?)
+  (let loop ([items items] [table table])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (dict-ref table key-item #f)
+               (car items)
+               (loop (cdr items) (if mutating?
+                                     (begin (dict-set! table key-item #t) table)
+                                     (dict-set table key-item #t))))))))
+(define (check-duplicate/list items key same?)
+  (let loop ([items items] [sofar null])
+    (and (pair? items)
+         (let ([key-item (key (car items))])
+           (if (for/or ([prev (in-list sofar)])
+                 (same? key-item prev))
+               (car items)
+               (loop (cdr items) (cons key-item sofar)))))))

7-3-0-1/racket/collects/syntax/parse/private/3d-stx.rkt

@@ -0,0 +1,250 @@
+#lang racket/base
+(require (only-in '#%flfxnum flvector? fxvector?)
+         (only-in '#%extfl extflonum? extflvector?))
+(provide 2d-stx?
+         check-datum)
+
+;; Checks for 3D syntax (syntax that contains unwritable values, etc)
+
+(define INIT-FUEL #e1e6)
+
+;; TO DO:
+;; - extension via proc (any -> list/#f),
+;;   value considered good if result is list, all values in list are good
+
+;; --
+
+#|
+Some other predicates one might like to have:
+ - would (read (write x)) succeed and be equal/similar to x?
+ - would (datum->syntax #f x) succeed?
+ - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
+ - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
+
+where equal/similar could mean one of the following:
+ - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
+ - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
+ - equal? but also requiring same mutability at every point
+
+Some aux definitions:
+
+(define (rt x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (read in))
+
+(define (wrsd x)
+  (define-values (in out) (make-pipe))
+  (write x out)
+  (close-output-port out)
+  (syntax->datum (read-syntax #f in)))
+
+(define (dsd x)
+  (syntax->datum (datum->syntax #f x)))
+
+(define (evalc x) ;; mimics compiled zo-file constraints
+  (eval (rt (compile `(quote ,x)))))
+
+How mutability behaves:
+ - for vectors, boxes:
+   - read always mutable
+   - read-syntax always immutable
+   - (dsd x) always immutable
+   - (evalc x) always immutable
+ - for hashes:
+   - read always immutable
+   - (dsd x) same as x
+   - (evalc x) always immutable (!!!)
+ - for prefab structs:
+   - read same as x
+   - read-syntax same as x
+   - (dsd x) same as x
+   - (evalc x) same as x
+
+Symbols
+ - (dsd x) same as x
+ - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
+
+Chaperones allow the lazy generation of infinite trees of data
+undetectable by eq?-based cycle detection.  Might be helpful to have
+chaperone-eq? (not recursive, just chaperones of same object) and
+chaperone-eq?-hash-code, to use with make-custom-hash.)
+
+Impersonators allow the lazy generation of infinite trees of data,
+period.
+
+|#
+
+;; ----
+
+;; 2d-stx? : any ... -> boolean
+;; Would (write (compile `(quote-syntax ,x))) succeed?
+;; If traverse-syntax? is #t, recurs into existing syntax
+;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
+;; checks if *new* 3d syntax would be created.
+(define (2d-stx? x
+                 #:traverse-syntax? [traverse-syntax? #t]
+                 #:irritant [irritant-box #f])
+  (check-datum x
+               #:syntax-mode (if traverse-syntax? 'compound 'atomic)
+               #:allow-impersonators? #f
+               #:allow-mutable? 'no-hash/prefab
+               #:allow-unreadable-symbols? #t
+               #:allow-cycles? #t
+               #:irritant irritant-box))
+
+;; ----
+
+;; check-datum : any ... -> boolean
+;; where StxMode = (U 'atomic 'compound #f)
+;; Returns nat if x is "good", #f if "bad"
+;; If irritant-b is a box, the first bad subvalue found is put in the box.
+;; If visited-t is a hash, it is used to detect cycles.
+(define (check-datum x
+                     #:syntax-mode [stx-mode #f]
+                     #:allow-impersonators? [allow-impersonators? #f]
+                     #:allow-mutable? [allow-mutable? #f]
+                     #:allow-unreadable-symbols? [allow-unreadable? #f]
+                     #:allow-cycles? [allow-cycles? #f]
+                     #:irritant [irritant-b #f])
+  ;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
+  (define (run fuel visited-t)
+    (check* x fuel visited-t
+            stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+            irritant-b))
+  (let ([result (run INIT-FUEL #f)])
+    (cond [(not (equal? result 0)) ;; nat>0 or #f
+           (and result #t)]
+          [else
+           ;; (eprintf "out of fuel, restarting\n")
+           (and (run +inf.0 (make-hasheq)) #t)])))
+
+;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
+;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
+;; If bad, places bad subvalue in irritant-b, if box
+(define (check* x0 fuel0 visited-t
+                stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
+                irritant-b)
+  (define no-mutable? (not allow-mutable?))
+  (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
+  (define no-cycle? (not allow-cycles?))
+  (define no-impersonator? (not allow-impersonators?))
+  (define (loop x fuel)
+    (if (and fuel (not (zero? fuel)))
+        (loop* x fuel)
+        fuel))
+  (define (loop* x fuel)
+    (define (bad) (when irritant-b (set-box! irritant-b x)) #f)
+    (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
+      (cond [(and no-mutable? mutable?)
+             (bad)]
+            [else
+             body ...]))
+    (define-syntax-rule (with-cycle-check body ...)
+      (cond [(and visited-t (hash-ref visited-t x #f))
+             => (lambda (status)
+                  (cond [(and no-cycle? (eq? status 'traversing))
+                         (bad)]
+                        [else
+                         fuel]))]
+            [else
+             (when visited-t
+               (hash-set! visited-t x 'traversing))
+             (begin0 (begin body ...)
+               (when visited-t
+                 (hash-remove! visited-t x)))]))
+    ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
+    (cond
+     ;; Immutable compound
+     [(and visited-t (list? x))
+      ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
+      ;; don't do unless visited-t present, else expands fuel by arbitrary factors
+      (with-cycle-check
+       (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
+         (loop e fuel)))]
+     [(pair? x)
+      (with-cycle-check
+       (let ([fuel (loop (car x) (sub1 fuel))])
+         (loop (cdr x) fuel)))]
+     ;; Atomic
+     [(or (null? x)
+          (boolean? x)
+          (number? x)
+          (char? x)
+          (keyword? x)
+          (regexp? x)
+          (byte-regexp? x)
+          (extflonum? x))
+      fuel]
+     [(symbol? x)
+      (cond [(symbol-interned? x)
+             fuel]
+            [(symbol-unreadable? x)
+             (if allow-unreadable? fuel (bad))]
+            [else ;; uninterned
+             (if (eq? allow-unreadable? #t) fuel (bad))])]
+     ;; Mutable flat
+     [(or (string? x)
+          (bytes? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     [(or (fxvector? x)
+          (flvector? x)
+          (extflvector? x))
+      (with-mutable-check (not (immutable? x))
+        fuel)]
+     ;; Syntax
+     [(syntax? x)
+      (case stx-mode
+        ((atomic) fuel)
+        ((compound) (loop (syntax-e x) fuel))
+        (else (bad)))]
+     ;; Impersonators and chaperones
+     [(and no-impersonator? (impersonator? x))  ;; else continue to chaperoned type
+      (bad)]
+     [(and no-impersonator? (chaperone? x))  ;; else continue to impersonated type
+      (bad)]
+     [else
+      (with-cycle-check
+       (cond
+        ;; Mutable (maybe) compound
+        [(vector? x)
+         (with-mutable-check (not (immutable? x))
+           (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
+             (loop e fuel)))]
+        [(box? x)
+         (with-mutable-check (not (immutable? x))
+           (loop (unbox x) (sub1 fuel)))]
+        [(prefab-struct-key x)
+         => (lambda (key)
+              (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
+                     (bad)]
+                    [else
+                     ;; traverse key, since contains arbitrary auto-value
+                     (let ([fuel (loop key fuel)])
+                       (loop (struct->vector x) fuel))]))]
+        [(hash? x)
+         (cond [(and no-mutable-hash/prefab? (not (immutable? x)))
+                (bad)]
+               [else
+                (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
+                  (let ([fuel (loop k fuel)])
+                    (loop v fuel)))])]
+        ;; Bad
+        [else
+         (bad)]))]))
+  (loop x0 fuel0))
+
+;; mutable-prefab-key? : prefab-key -> boolean
+(define (mutable-prefab-key? key)
+  ;; A prefab-key is either
+  ;;  - symbol
+  ;;  - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
+  ;; where mutable fields indicated by vector
+  ;; This code is probably overly general; racket seems to normalize keys.
+  (let loop ([k key])
+    (and (pair? k)
+         (or (and (vector? (car k))
+                  (positive? (vector-length (car k))))
+             (loop (cdr k))))))

7-3-0-1/racket/collects/syntax/parse/private/litconv.rkt

@@ -0,0 +1,284 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/lazy-require
+                     "sc.rkt"
+                     "lib.rkt"
+                     syntax/parse/private/kws
+                     racket/syntax)
+         syntax/parse/private/residual-ct ;; keep abs. path
+         stxparse-info/parse/private/residual)   ;; keep abs. path
+(begin-for-syntax
+ (lazy-require
+  [syntax/private/keyword (options-select-value parse-keyword-options)]
+  [stxparse-info/parse/private/rep ;; keep abs. path
+   (parse-kw-formals
+    check-conventions-rules
+    check-datum-literals-list
+    create-aux-def)]))
+;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
+;; Without this, dependencies don't get collected.
+(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
+
+(provide define-conventions
+         define-literal-set
+         literal-set->predicate
+         kernel-literals)
+
+(define-syntax (define-conventions stx)
+
+  (define-syntax-class header
+    #:description "name or name with formal parameters"
+    #:commit
+    (pattern name:id
+             #:with formals #'()
+             #:attr arity (arity 0 0 null null))
+    (pattern (name:id . formals)
+             #:attr arity (parse-kw-formals #'formals #:context stx)))
+
+  (syntax-parse stx
+    [(define-conventions h:header rule ...)
+     (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 (in-list 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 (class-name ...)
+         (map den:delayed-class dens))
+
+       ;; FIXME: could move make-den:delayed to user of conventions
+       ;; and eliminate from residual.rkt
+       #'(begin
+           (define-syntax h.name
+             (make-conventions
+              (quote-syntax get-parsers)
+              (lambda ()
+                (let ([class-names (list (quote-syntax class-name) ...)])
+                  (map list
+                       (list 'rx ...)
+                       (map make-den:delayed
+                            (generate-temporaries class-names)
+                            class-names))))))
+           (define get-parsers
+             (lambda formals
+               def ...
+               (list parser ...)))))]))
+
+(define-for-syntax (check-phase-level stx ctx)
+  (unless (or (exact-integer? (syntax-e stx))
+              (eq? #f (syntax-e stx)))
+    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
+  stx)
+
+;; check-litset-list : stx stx -> (listof (cons id literalset))
+(define-for-syntax (check-litset-list stx ctx)
+  (syntax-case stx ()
+    [(litset-id ...)
+     (for/list ([litset-id (syntax->list #'(litset-id ...))])
+       (let* ([val (and (identifier? litset-id)
+                        (syntax-local-value/record litset-id literalset?))])
+         (if val
+             (cons litset-id val)
+             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
+    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
+
+;; check-literal-entry/litset : stx stx -> (list id id)
+(define-for-syntax (check-literal-entry/litset stx ctx)
+  (syntax-case stx ()
+    [(internal external)
+     (and (identifier? #'internal) (identifier? #'external))
+     (list #'internal #'external)]
+    [id
+     (identifier? #'id)
+     (list #'id #'id)]
+    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits)
+  (let ([lit-t (make-hasheq)]) ;; sym => #t
+    (define (check+enter! key blame-stx)
+      (when (hash-ref lit-t key #f)
+        (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx))
+      (hash-set! lit-t key #t))
+    (for ([id+litset (in-list imports)])
+      (let ([litset-id (car id+litset)]
+            [litset (cdr id+litset)])
+        (for ([entry (in-list (literalset-literals litset))])
+          (cond [(lse:lit? entry)
+                 (check+enter! (lse:lit-internal entry) litset-id)]
+                [(lse:datum-lit? entry)
+                 (check+enter! (lse:datum-lit-internal entry) litset-id)]))))
+    (for ([datum-lit (in-list datum-lits)])
+      (let ([internal (den:datum-lit-internal datum-lit)])
+        (check+enter! (syntax-e internal) internal)))
+    (for ([lit (in-list lits)])
+      (check+enter! (syntax-e (car lit)) (car lit)))))
+
+(define-syntax (define-literal-set stx)
+  (syntax-case stx ()
+    [(define-literal-set name . rest)
+     (let-values ([(chunks rest)
+                   (parse-keyword-options
+                    #'rest
+                    `((#:literal-sets ,check-litset-list)
+                      (#:datum-literals ,check-datum-literals-list)
+                      (#:phase ,check-phase-level)
+                      (#:for-template)
+                      (#:for-syntax)
+                      (#:for-label))
+                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
+                    #:context stx
+                    #:no-duplicates? #t)])
+       (unless (identifier? #'name)
+         (raise-syntax-error #f "expected identifier" stx #'name))
+       (let ([relphase
+              (cond [(assq '#:for-template chunks) -1]
+                    [(assq '#:for-syntax chunks) 1]
+                    [(assq '#:for-label chunks) #f]
+                    [else (options-select-value chunks '#:phase #:default 0)])]
+             [datum-lits
+              (options-select-value chunks '#:datum-literals #:default null)]
+             [lits (syntax-case rest ()
+                     [( (lit ...) )
+                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
+                        (check-literal-entry/litset lit stx))]
+                     [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [imports (options-select-value chunks '#:literal-sets #:default null)])
+         (check-duplicate-literals stx imports lits datum-lits)
+         (with-syntax ([((internal external) ...) lits]
+                       [(datum-internal ...) (map den:datum-lit-internal datum-lits)]
+                       [(datum-external ...) (map den:datum-lit-external datum-lits)]
+                       [(litset-id ...) (map car imports)]
+                       [relphase relphase])
+           #`(begin
+               (define phase-of-literals
+                 (and 'relphase
+                      (+ (variable-reference->module-base-phase (#%variable-reference))
+                         'relphase)))
+               (define-syntax name
+                 (make-literalset
+                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
+                          ...
+                          (list (make-lse:lit 'internal
+                                              (quote-syntax external)
+                                              (quote-syntax phase-of-literals))
+                                ...
+                                (make-lse:datum-lit 'datum-internal
+                                                    'datum-external)
+                                ...))))
+               (begin-for-syntax/once
+                (for ([x (in-list (syntax->list #'(external ...)))])
+                  (unless (identifier-binding x 'relphase)
+                    (raise-syntax-error #f
+                                        (format "literal is unbound in phase ~a~a~a"
+                                                'relphase
+                                                (case 'relphase
+                                                  ((1) " (for-syntax)")
+                                                  ((-1) " (for-template)")
+                                                  ((#f) " (for-label)")
+                                                  (else ""))
+                                                " relative to the enclosing module")
+                                        (quote-syntax #,stx) x))))))))]))
+
+#|
+NOTES ON PHASES AND BINDINGS
+
+(module M ....
+  .... (define-literal-set LS #:phase PL ....)
+  ....)
+
+For the expansion of the define-literal-set form, the bindings of the literals
+can be accessed by (identifier-binding lit PL), because the phase of the enclosing
+module (M) is 0.
+
+LS may be used, however, in a context where the phase of the enclosing
+module is not 0, so each instantiation of LS needs to calculate the
+phase of M and add that to PL.
+
+--
+
+Normally, literal sets that define the same name conflict. But it
+would be nice to allow them to both be imported in the case where they
+refer to the same binding.
+
+Problem: Can't do the check eagerly, because the binding of L may
+change between when define-literal-set is compiled and the comparison
+involving L. For example:
+
+  (module M racket
+    (require stxparse-info/parse)
+    (define-literal-set LS (lambda))
+    (require (only-in some-other-lang lambda))
+    .... LS ....)
+
+The expansion of the LS definition sees a different lambda than the
+one that the literal in LS actually refers to.
+
+Similarly, a literal in LS might not be defined when the expander
+runs, but might get defined later. (Although I think that will already
+cause an error, so don't worry about that case.)
+|#
+
+;; FIXME: keep one copy of each identifier (?)
+
+(define-syntax (literal-set->predicate stx)
+  (syntax-case stx ()
+    [(literal-set->predicate litset-id)
+     (let ([val (and (identifier? #'litset-id)
+                     (syntax-local-value/record #'litset-id literalset?))])
+       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
+       (let ([lits (literalset-literals val)])
+         (with-syntax ([((lit phase-var) ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:lit? lit))
+                          (list (lse:lit-external lit) (lse:lit-phase lit)))]
+                       [(datum-lit ...)
+                        (for/list ([lit (in-list lits)]
+                                   #:when (lse:datum-lit? lit))
+                          (lse:datum-lit-external lit))])
+           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
+                                         '(datum-lit ...)))))]))
+
+(define (make-literal-set-predicate lits datum-lits)
+  (lambda (x [phase (syntax-local-phase-level)])
+    (or (for/or ([lit (in-list lits)])
+          (let ([lit-id (car lit)]
+                [lit-phase (cadr lit)])
+            (free-identifier=? x lit-id phase lit-phase)))
+        (and (memq (syntax-e x) datum-lits) #t))))
+
+;; Literal sets
+
+(define-literal-set kernel-literals
+  (begin
+   begin0
+   define-values
+   define-syntaxes
+   define-values-for-syntax ;; kept for compat.
+   begin-for-syntax
+   set!
+   let-values
+   letrec-values
+   #%plain-lambda
+   case-lambda
+   if
+   quote
+   quote-syntax
+   letrec-syntaxes+values
+   with-continuation-mark
+   #%expression
+   #%plain-app
+   #%top
+   #%datum
+   #%variable-reference
+   module module* #%provide #%require #%declare
+   #%plain-module-begin))

7-3-0-1/racket/collects/syntax/parse/private/make.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     racket/struct-info))
+(provide make)
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
+
+;; (make struct-name field-expr ...)
+;; Checks that correct number of fields given.
+(define-syntax (make stx)
+  (syntax-case stx ()
+    [(make S expr ...)
+     (let ()
+       (define info (get-struct-info #'S stx))
+       (define constructor (list-ref info 1))
+       (define accessors (list-ref info 3))
+       (unless (identifier? #'constructor)
+         (raise-syntax-error #f "constructor not available for struct" stx #'S))
+       (unless (andmap identifier? accessors)
+         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
+       (let ([num-slots (length accessors)]
+             [num-provided (length (syntax->list #'(expr ...)))])
+         (unless (= num-provided num-slots)
+           (raise-syntax-error
+            #f
+            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
+                    (syntax-e #'S)
+                    num-slots
+                    num-provided)
+            stx)))
+       (with-syntax ([constructor constructor])
+         (syntax-property #'(constructor expr ...)
+                          'disappeared-use
+                          #'S)))]))

7-3-0-1/racket/collects/syntax/parse/private/runtime-progress.rkt

@@ -0,0 +1,257 @@
+#lang racket/base
+(require racket/list
+         syntax/parse/private/minimatch)
+(provide ps-empty
+         ps-add-car
+         ps-add-cdr
+         ps-add-stx
+         ps-add-unbox
+         ps-add-unvector
+         ps-add-unpstruct
+         ps-add-opaque
+         ps-add-post
+         ps-add
+         (struct-out ord)
+
+         ps-pop-opaque
+         ps-pop-ord
+         ps-pop-post
+         ps-context-syntax
+         ps-difference
+
+         (struct-out failure)
+         failure*
+
+         expect?
+         (struct-out expect:thing)
+         (struct-out expect:atom)
+         (struct-out expect:literal)
+         (struct-out expect:message)
+         (struct-out expect:disj)
+         (struct-out expect:proper-pair)
+
+         es-add-thing
+         es-add-message
+         es-add-atom
+         es-add-literal
+         es-add-proper-pair)
+
+;; FIXME: add phase to expect:literal
+
+;; == Failure ==
+
+#|
+A Failure is (failure PS ExpectStack)
+
+A FailureSet is one of
+  - Failure
+  - (cons FailureSet FailureSet)
+
+A FailFunction = (FailureSet -> Answer)
+|#
+(define-struct failure (progress expectstack) #:prefab)
+
+;; failure* : PS ExpectStack/#f -> Failure/#t
+(define (failure* ps es) (if es (failure ps es) #t))
+
+;; == Progress ==
+
+#|
+Progress (PS) is a non-empty list of Progress Frames (PF).
+
+A Progress Frame (PF) is one of
+  - stx     ;; "Base" frame, or ~parse/#:with term
+  - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
+  - nat     ;; Represents that many repeated cdrs
+  - 'post   ;; late/post-traversal check
+  - #s(ord group index) ;; ~and subpattern, only comparable w/in group
+  - 'opaque
+
+The error-reporting context (ie, syntax-parse #:context arg) is always
+the final frame.
+
+All non-stx frames (eg car, cdr) interpreted as applying to nearest following
+stx frame.
+
+A stx frame is introduced
+  - always at base (that is, by syntax-parse)
+    - if syntax-parse has #:context arg, then two stx frames at bottom:
+      (list to-match-stx context-stx)
+  - by #:with/~parse
+  - by #:fail-*/#:when/~fail & stx
+
+Interpretation: later frames are applied first.
+ eg, (list 'car 1 stx)
+      means ( car of ( cdr once of stx ) )
+      NOT apply car, then apply cdr once, then stop
+|#
+(define-struct ord (group index) #:prefab)
+
+(define (ps-empty stx ctx)
+  (if (eq? stx ctx)
+      (list stx)
+      (list stx ctx)))
+(define (ps-add-car parent)
+  (cons 'car parent))
+(define (ps-add-cdr parent [times 1])
+  (if (zero? times)
+      parent
+      (match (car parent)
+        [(? exact-positive-integer? n)
+         (cons (+ times n) (cdr parent))]
+        [_
+         (cons times parent)])))
+(define (ps-add-stx parent stx)
+  (cons stx parent))
+(define (ps-add-unbox parent)
+  (ps-add-car parent))
+(define (ps-add-unvector parent)
+  (ps-add-car parent))
+(define (ps-add-unpstruct parent)
+  (ps-add-car parent))
+(define (ps-add-opaque parent)
+  (cons 'opaque parent))
+(define (ps-add parent frame)
+  (cons frame parent))
+(define (ps-add-post parent)
+  (cons 'post parent))
+
+;; ps-context-syntax : Progress -> syntax
+(define (ps-context-syntax ps)
+  ;; Bottom frame is always syntax
+  (last ps))
+
+;; ps-difference : PS PS -> nat
+;; Returns N s.t. B = (ps-add-cdr^N A)
+(define (ps-difference a b)
+  (define-values (a-cdrs a-base)
+    (match a
+      [(cons (? exact-positive-integer? a-cdrs) a-base)
+       (values a-cdrs a-base)]
+      [_ (values 0 a)]))
+  (define-values (b-cdrs b-base)
+    (match b
+      [(cons (? exact-positive-integer? b-cdrs) b-base)
+       (values b-cdrs b-base)]
+      [_ (values 0 b)]))
+  (unless (eq? a-base b-base)
+    (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
+  (- b-cdrs a-cdrs))
+
+;; ps-pop-opaque : PS -> PS
+;; Used to continue with progress from opaque head pattern.
+(define (ps-pop-opaque ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'opaque ps*)
+     ps*]
+    [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
+
+;; ps-pop-ord : PS -> PS
+(define (ps-pop-ord ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
+     (ps-add-cdr ps* n)]
+    [(cons (? ord?) ps*)
+     ps*]
+    [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
+
+;; ps-pop-post : PS -> PS
+(define (ps-pop-post ps)
+  (match ps
+    [(cons (? exact-positive-integer? n) (cons 'post ps*))
+     (ps-add-cdr ps* n)]
+    [(cons 'post ps*)
+     ps*]
+    [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
+
+
+;; == Expectations ==
+
+#|
+There are multiple types that use the same structures, optimized for
+different purposes.
+
+-- During parsing, the goal is to minimize/consolidate allocations.
+
+An ExpectStack (during parsing) is one of
+  - (expect:thing Progress String Boolean String/#f ExpectStack)
+  * (expect:message String ExpectStack)
+  * (expect:atom Datum ExpectStack)
+  * (expect:literal Identifier ExpectStack)
+  * (expect:proper-pair FirstDesc ExpectStack)
+  * #t
+
+The *-marked variants can only occur at the top of the stack (ie, not
+in the next field of another Expect). The top of the stack contains
+the most specific information.
+
+An ExpectStack can also be #f, which means no failure tracking is
+requested (and thus no more ExpectStacks should be allocated).
+
+-- During reporting, the goal is ease of manipulation.
+
+An ExpectList (during reporting) is (listof Expect).
+
+An Expect is one of
+  - (expect:thing #f String #t String/#f StxIdx)
+  * (expect:message String StxIdx)
+  * (expect:atom Datum StxIdx)
+  * (expect:literal Identifier StxIdx)
+  * (expect:proper-pair FirstDesc StxIdx)
+  * (expect:disj (NEListof Expect) StxIdx)
+  - '...
+
+A StxIdx is (cons Syntax Nat)
+
+That is, the next link is replaced with the syntax+index of the term
+being complained about. An expect:thing's progress is replaced with #f.
+
+An expect:disj never contains a '... or another expect:disj.
+
+We write ExpectList when the most specific information comes first and
+RExpectList when the most specific information comes last.
+|#
+(struct expect:thing (term description transparent? role next) #:prefab)
+(struct expect:message (message next) #:prefab)
+(struct expect:atom (atom next) #:prefab)
+(struct expect:literal (literal next) #:prefab)
+(struct expect:disj (expects next) #:prefab)
+(struct expect:proper-pair (first-desc next) #:prefab)
+
+(define (expect? x)
+  (or (expect:thing? x)
+      (expect:message? x)
+      (expect:atom? x)
+      (expect:literal? x)
+      (expect:disj? x)
+      (expect:proper-pair? x)))
+
+(define (es-add-thing ps description transparent? role next)
+  (if (and next description)
+      (expect:thing ps description transparent? role next)
+      next))
+
+(define (es-add-message message next)
+  (if (and next message)
+      (expect:message message next)
+      next))
+
+(define (es-add-atom atom next)
+  (and next (expect:atom atom next)))
+
+(define (es-add-literal literal next)
+  (and next (expect:literal literal next)))
+
+(define (es-add-proper-pair first-desc next)
+  (and next (expect:proper-pair first-desc next)))
+
+#|
+A FirstDesc is one of
+ - #f                   -- unknown, multiple possible, etc
+ - string               -- description
+ - (list 'any)
+ - (list 'literal symbol)
+ - (list 'datum datum)
+|#

7-3-0-1/racket/collects/syntax/parse/private/txlift.rkt

@@ -0,0 +1,45 @@
+#lang racket/base
+(require (for-template racket/base))
+(provide txlift
+         get-txlifts-as-definitions
+         with-txlifts
+         call/txlifts)
+
+;; Like lifting definitions, but within a single transformer.
+
+;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))]
+(define current-liftbox (make-parameter #f))
+
+(define (call/txlifts proc)
+  (parameterize ((current-liftbox (box null)))
+    (proc)))
+
+(define (txlift expr)
+  (let ([liftbox (current-liftbox)])
+    (check 'txlift liftbox)
+    (let ([var (car (generate-temporaries '(txlift)))])
+      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
+      var)))
+
+(define (get-txlifts)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts liftbox)
+    (reverse (unbox liftbox))))
+
+(define (get-txlifts-as-definitions)
+  (let ([liftbox (current-liftbox)])
+    (check 'get-txlifts-as-definitions liftbox)
+    (map (lambda (p)
+           #`(define #,@p))
+         (reverse (unbox liftbox)))))
+
+(define (check who lb)
+  (unless (box? lb)
+    (error who "not in a txlift-catching context")))
+
+(define (with-txlifts proc)
+  (call/txlifts
+   (lambda ()
+     (let ([v (proc)])
+       (with-syntax ([((var rhs) ...) (get-txlifts)])
+         #`(let* ([var rhs] ...) #,v))))))

case/stxcase-scheme.rkt

@@ -3,11 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/racket/private/stxcase-scheme.rkt")]
-  [(version< (version) "6.90.0.29")
-    ;; TODO: this seems like a bug, it should be 6-12
-    (my-include "../6-11/racket/collects/racket/private/stxcase-scheme.rkt")]
-  [else
-    (my-include "../6-90-0-29/racket/collects/racket/private/stxcase-scheme.rkt")])
+(my-include "../" "/racket/collects/racket/private/stxcase-scheme.rkt")

case/stxcase.rkt

@@ -3,11 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/racket/private/stxcase.rkt")]
-  [(version< (version) "6.90.0.29")
-    ;; TODO: this seems like a bug, it should be 6-12
-    (my-include "../6-11/racket/collects/racket/private/stxcase.rkt")]
-  [else
-    (my-include "../6-90-0-29/racket/collects/racket/private/stxcase.rkt")])
+(my-include "../" "/racket/collects/racket/private/stxcase.rkt")

case/stxloc.rkt

@@ -3,11 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/racket/private/stxloc.rkt")]
-  [(version< (version) "6.90.0.29")
-    ;; TODO: this seems like a bug, it should be 6-12
-    (my-include "../6-11/racket/collects/racket/private/stxloc.rkt")]
-  [else
-    (my-include "../6-90-0-29/racket/collects/racket/private/stxloc.rkt")])
+(my-include "../" "/racket/collects/racket/private/stxloc.rkt")

case/syntax.rkt

@@ -3,11 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/racket/private/syntax.rkt")]
-  [(version< (version) "6.90.0.29")
-    ;; TODO: this seems like a bug, it should be 6-12
-    (my-include "../6-11/racket/collects/racket/private/syntax.rkt")]
-  [else
-    (my-include "../6-90-0-29/racket/collects/racket/private/syntax.rkt")])
+(my-include "../" "/racket/collects/racket/private/syntax.rkt")

case/template.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (begin)]
-  [(version< (version) "6.90.0.29")
-    (begin)]
-  [else
-    (my-include "../6-90-0-29/racket/collects/racket/private/template.rkt")])
+(my-include "../" "/racket/collects/racket/private/template.rkt")

case/with-stx.rkt

@@ -3,11 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/racket/private/with-stx.rkt")]
-  [(version< (version) "6.90.0.29")
-    ;; TODO: this seems like a bug, should be 6-12
-    (my-include "../6-11/racket/collects/racket/private/with-stx.rkt")]
-  [else
-    (my-include "../6-90-0-29/racket/collects/racket/private/with-stx.rkt")])
+(my-include "../" "/racket/collects/racket/private/with-stx.rkt")

info.rkt

@@ -11,6 +11,8 @@
                      "racket-doc"
                      "at-exp-lib")) ;; for the documentation only
 (define scribblings '(("scribblings/stxparse-info.scrbl" () ("Syntax Extensions"))))
+(define compile-omit-paths '("6-11" "6-12" "6-90-0-29" "7-0-0-20" "7-3-0-1"))
 (define pkg-desc "Description Here")
 (define version "0.0")
 (define pkg-authors '(Suzanne Soy))
+

my-include.rkt

@@ -1,15 +1,16 @@
 #lang racket
 (provide my-include)
-(require (for-syntax mzlib/etc))
+(require version-case
+         (for-syntax mzlib/etc))
 
-(define-syntax (my-include stx)
-  (syntax-case stx ()
-    [(_ filename)
-     (string? (syntax-e #'filename))
-     #'(begin
-         (define-syntax (tmp _stx)
-           (my-include2 (this-expression-source-directory filename) filename))
-         (tmp))]))
+(define-for-syntax (my-include1 esrcdir)
+  (lambda (filename)
+    (with-syntax ([esrcdir esrcdir]
+                  [filename filename])
+      #'(begin
+          (define-syntax (tmp _stx)
+            (my-include2 (this-expression-source-directory esrcdir) filename))
+          (tmp)))))
 
 (define-for-syntax (my-include2 dirname filename)
   (let ([filename (build-path dirname
@@ -21,4 +22,25 @@
       [(-module name . rest)
        #'(begin (module name . rest)
                 (require 'name)
-                (provide (all-from-out 'name)))])))
+                (provide (all-from-out 'name)))])))
+
+(define-syntax (my-include stx)
+  (syntax-case stx ()
+    [(_ updir filename)
+     (and (string? (syntax-e #'updir))
+          (string? (syntax-e #'filename)))
+     (let ([-updir (syntax-e #'updir)]
+           [-filename (syntax-e #'filename)]
+           [my-include1 (my-include1 #'filename)]
+           [loc (lambda (x) (quasisyntax/loc #'filename #,x))])
+       #`(version-case
+           [(version< (version) "6.11.0.900")
+             #,(my-include1 (loc (string-append -updir "6-11" -filename)))]
+           [(version< (version) "6.90.0.29")
+             #,(my-include1 (loc (string-append -updir "6-12" -filename)))]
+           [(version< (version) "7.0.0.20")
+             #,(my-include1 (loc (string-append -updir "6-90-0-29" -filename)))]
+           [(version< (version) "7.3.0.1")
+             #,(my-include1 (loc (string-append -updir "7-0-0-20" -filename)))]
+           [else
+             #,(my-include1 (loc (string-append -updir "7-3-0-1" -filename)))]))]))

parse.rkt

@@ -3,8 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "7.3.0.1")
-    (my-include "7-0-0-20/racket/collects/syntax/parse.rkt")]
-  [else
-    (my-include "7-3-0-1/racket/collects/syntax/parse.rkt")])
+(my-include "" "/racket/collects/syntax/parse.rkt")

parse/debug.rkt

@@ -3,14 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/syntax/parse/debug.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../6-12/racket/collects/syntax/parse/debug.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../6-90-0-29/racket/collects/syntax/parse/debug.rkt")]
-  [(version< (version) "7.3.0.1")
-    (my-include "../7-0-0-20/racket/collects/syntax/parse/debug.rkt")]
-  [else
-    (my-include "../7-3-0-1/racket/collects/syntax/parse/debug.rkt")])
+(my-include "../" "/racket/collects/syntax/parse/debug.rkt")

parse/define.rkt

@@ -1,20 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base
-                     stxparse-info/parse
-                     "private/sc.rkt"))
-(provide define-simple-macro
-         define-syntax-parser
-         (for-syntax (all-from-out stxparse-info/parse)))
-
-(define-syntax (define-simple-macro stx)
-  (syntax-parse stx
-    [(define-simple-macro (~and (macro:id . _) pattern) . body)
-     #`(define-syntax macro
-         (syntax-parser/template
-          #,((make-syntax-introducer) stx)
-          [pattern . body]))]))
-
-(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
-  (define-syntax macro
-    (syntax-parser option-or-clause ...)))
-
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../" "/racket/collects/syntax/parse/define.rkt")

parse/experimental/contract.rkt

@@ -3,8 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "7.3.0.1")
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt")]
-  [else
-    (my-include "../../7-3-0-1/racket/collects/syntax/parse/experimental/contract.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/experimental/contract.rkt")

parse/experimental/dset.rkt

@@ -1,54 +1,6 @@
 #lang racket/base
-
-;; A dset is an `equal?`-based set, but it preserves order based on
-;; the history of additions, so that if items are added in a
-;; deterministic order, they come back out in a deterministic order.
-
-(provide dset
-         dset-empty?
-         dset->list
-         dset-add
-         dset-union
-         dset-subtract
-         dset-filter)
-
-(define dset
-  (case-lambda
-    [() (hash)]
-    [(e) (hash e 0)]))
-
-(define (dset-empty? ds)
-  (zero? (hash-count ds)))
-
-(define (dset->list ds)
-  (map cdr
-       (sort (for/list ([(k v) (in-hash ds)])
-               (cons v k))
-             <
-             #:key car)))
-
-(define (dset-add ds e)
-  (if (hash-ref ds e #f)
-      ds
-      (hash-set ds e (hash-count ds))))
-
-(define (dset-union ds1 ds2)
-  (cond
-   [((hash-count ds1) . > . (hash-count ds2))
-    (dset-union ds2 ds1)]
-   [else
-    (for/fold ([ds2 ds2]) ([e (dset->list ds1)])
-      (dset-add ds2 e))]))
-
-(define (dset-subtract ds1 ds2)
-  ;; ! takes O(size(ds2)) time !
-  (for/fold ([r (dset)]) ([e (in-list (dset->list ds1))])
-    (if (hash-ref ds2 e #f)
-        r
-        (dset-add r e))))
-
-(define (dset-filter ds pred)
-  (for/fold ([r (dset)]) ([e (in-list (dset->list ds))])
-    (if (pred e)
-        (dset-add r e)
-        r)))
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/experimental/dset.rkt")

parse/experimental/eh.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require "../private/sc.rkt"
-         syntax/parse/private/keywords)
-(provide ~eh-var
-         define-eh-alternative-set)
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/experimental/eh.rkt")

parse/experimental/private/substitute.rkt

@@ -3,8 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../../6-11/racket/collects/syntax/parse/experimental/private/substitute.rkt")]
-  [else
-    (begin)])
+(my-include "../../../" "/racket/collects/syntax/parse/experimental/substitute.rkt")

parse/experimental/provide.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/experimental/provide.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/experimental/provide.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/provide.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/experimental/provide.rkt")

parse/experimental/reflect.rkt

@@ -3,12 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/experimental/reflect.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/experimental/reflect.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/reflect.rkt")]
-  [else
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/experimental/reflect.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/experimental/reflect.rkt")

parse/experimental/specialize.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/experimental/specialize.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/experimental/specialize.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/specialize.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/experimental/specialize.rkt")

parse/experimental/splicing.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/experimental/splicing.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/experimental/splicing.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/splicing.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/experimental/splicing.rkt")

parse/experimental/template.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/experimental/template.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/experimental/template.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/template.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/experimental/template.rkt")

parse/lib/function-header.rkt

@@ -1,112 +1,6 @@
 #lang racket/base
-
-(require "../../parse.rkt"
-         "../experimental/template.rkt"
-         racket/dict)
-
-(provide function-header formal formals)
-
-(define-syntax-class function-header
-  (pattern ((~or header:function-header name:id) . args:formals)
-           #:attr params
-           (template ((?@ . (?? header.params ()))
-                      . args.params))))
-
-(define-syntax-class formals
-  #:attributes (params)
-  (pattern (arg:formal ...)
-           #:attr params #'(arg.name ...)
-           #:fail-when (check-duplicate-identifier (syntax->list #'params))
-                       "duplicate argument name"
-           #:fail-when (check-duplicate (attribute arg.kw)
-                                        #:same? (λ (x y)
-                                                  (and x y (equal? (syntax-e x)
-                                                                   (syntax-e y)))))
-                       "duplicate keyword for argument"
-           #:fail-when (invalid-option-placement
-                        (attribute arg.name) (attribute arg.default))
-                       "default-value expression missing")
-  (pattern (arg:formal ... . rest:id)
-           #:attr params #'(arg.name ... rest)
-           #:fail-when (check-duplicate-identifier (syntax->list #'params))
-                       "duplicate argument name"
-           #:fail-when (check-duplicate (attribute arg.kw)
-                                        #:same? (λ (x y)
-                                                  (and x y (equal? (syntax-e x)
-                                                                   (syntax-e y)))))
-                       "duplicate keyword for argument"
-           #:fail-when (invalid-option-placement
-                        (attribute arg.name) (attribute arg.default))
-                       "default-value expression missing"))
-
-(define-splicing-syntax-class formal
-  #:attributes (name kw default)
-  (pattern name:id
-           #:attr kw #f
-           #:attr default #f)
-  (pattern [name:id default]
-           #:attr kw #f)
-  (pattern (~seq kw:keyword name:id)
-           #:attr default #f)
-  (pattern (~seq kw:keyword [name:id default])))
-
-;; invalid-option-placement : (Listof Id) (Listof Syntax/#f) -> Id/#f
-;; Checks for mandatory argument after optional argument; if found, returns
-;; identifier of mandatory argument.
-(define (invalid-option-placement names defaults)
-  ;; find-mandatory : (Listof Id) (Listof Syntax/#f) -> Id/#f
-  ;; Finds first name w/o corresponding default.
-  (define (find-mandatory names defaults)
-    (for/first ([name (in-list names)]
-                [default (in-list defaults)]
-                #:when (not default))
-      name))
-  ;; Skip through mandatory args until first optional found, then search
-  ;; for another mandatory.
-  (let loop ([names names] [defaults defaults])
-    (cond [(or (null? names) (null? defaults))
-           #f]
-          [(eq? (car defaults) #f) ;; mandatory
-           (loop (cdr names) (cdr defaults))]
-          [else ;; found optional
-           (find-mandatory (cdr names) (cdr defaults))])))
-
-;; Copied from unstable/list
-;; check-duplicate : (listof X)
-;;                   #:key (X -> K)
-;;                   #:same? (or/c (K K -> bool) dict?)
-;;                -> X or #f
-(define (check-duplicate items
-                        #:key [key values]
-                        #:same? [same? equal?])
-  (cond [(procedure? same?)
-         (cond [(eq? same? equal?)
-                (check-duplicate/t items key (make-hash) #t)]
-               [(eq? same? eq?)
-                (check-duplicate/t items key (make-hasheq) #t)]
-               [(eq? same? eqv?)
-                (check-duplicate/t items key (make-hasheqv) #t)]
-               [else
-                (check-duplicate/list items key same?)])]
-        [(dict? same?)
-         (let ([dict same?])
-           (if (dict-mutable? dict)
-               (check-duplicate/t items key dict #t)
-               (check-duplicate/t items key dict #f)))]))
-(define (check-duplicate/t items key table mutating?)
-  (let loop ([items items] [table table])
-    (and (pair? items)
-         (let ([key-item (key (car items))])
-           (if (dict-ref table key-item #f)
-               (car items)
-               (loop (cdr items) (if mutating?
-                                     (begin (dict-set! table key-item #t) table)
-                                     (dict-set table key-item #t))))))))
-(define (check-duplicate/list items key same?)
-  (let loop ([items items] [sofar null])
-    (and (pair? items)
-         (let ([key-item (key (car items))])
-           (if (for/or ([prev (in-list sofar)])
-                 (same? key-item prev))
-               (car items)
-               (loop (cdr items) (cons key-item sofar)))))))
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/lib/function-header.rkt")

parse/pre.rkt

@@ -3,12 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../6-11/racket/collects/syntax/parse/pre.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../6-12/racket/collects/syntax/parse/pre.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../6-90-0-29/racket/collects/syntax/parse/pre.rkt")]
-  [else
-    (my-include "../7-0-0-20/racket/collects/syntax/parse/pre.rkt")])
+(my-include "../" "/racket/collects/syntax/parse/pre.rkt")

parse/private/3d-stx.rkt

@@ -1,250 +1,7 @@
 #lang racket/base
-(require (only-in '#%flfxnum flvector? fxvector?)
-         (only-in '#%extfl extflonum? extflvector?))
-(provide 2d-stx?
-         check-datum)
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/private/3d-stx.rkt")
 
-;; Checks for 3D syntax (syntax that contains unwritable values, etc)
-
-(define INIT-FUEL #e1e6)
-
-;; TO DO:
-;; - extension via proc (any -> list/#f),
-;;   value considered good if result is list, all values in list are good
-
-;; --
-
-#|
-Some other predicates one might like to have:
- - would (read (write x)) succeed and be equal/similar to x?
- - would (datum->syntax #f x) succeed?
- - would (syntax->datum (datum->syntax #f x)) succeed and be equal/similar to x?
- - would (eval (read (write (compile `(quote ,x))))) succeed and be equal/similar to x?
-
-where equal/similar could mean one of the following:
- - equal?, which equates eg (vector 1 2 3) and (vector-immutable 1 2 3)
- - equal? relaxed to equate eg mutable and immutable hashes (but not prefabs)
- - equal? but also requiring same mutability at every point
-
-Some aux definitions:
-
-(define (rt x)
-  (define-values (in out) (make-pipe))
-  (write x out)
-  (close-output-port out)
-  (read in))
-
-(define (wrsd x)
-  (define-values (in out) (make-pipe))
-  (write x out)
-  (close-output-port out)
-  (syntax->datum (read-syntax #f in)))
-
-(define (dsd x)
-  (syntax->datum (datum->syntax #f x)))
-
-(define (evalc x) ;; mimics compiled zo-file constraints
-  (eval (rt (compile `(quote ,x)))))
-
-How mutability behaves:
- - for vectors, boxes:
-   - read always mutable
-   - read-syntax always immutable
-   - (dsd x) always immutable
-   - (evalc x) always immutable
- - for hashes:
-   - read always immutable
-   - (dsd x) same as x
-   - (evalc x) always immutable (!!!)
- - for prefab structs:
-   - read same as x
-   - read-syntax same as x
-   - (dsd x) same as x
-   - (evalc x) same as x
-
-Symbols
- - (dsd x) same as x
- - (evalc x) preserves interned, unreadable, makes new uninterned (loses eq-ness)
-
-Chaperones allow the lazy generation of infinite trees of data
-undetectable by eq?-based cycle detection.  Might be helpful to have
-chaperone-eq? (not recursive, just chaperones of same object) and
-chaperone-eq?-hash-code, to use with make-custom-hash.)
-
-Impersonators allow the lazy generation of infinite trees of data,
-period.
-
-|#
-
-;; ----
-
-;; 2d-stx? : any ... -> boolean
-;; Would (write (compile `(quote-syntax ,x))) succeed?
-;; If traverse-syntax? is #t, recurs into existing syntax
-;; If traverse-syntax? is #f, assumes existing stxobjs are 2d, and only
-;; checks if *new* 3d syntax would be created.
-(define (2d-stx? x
-                 #:traverse-syntax? [traverse-syntax? #t]
-                 #:irritant [irritant-box #f])
-  (check-datum x
-               #:syntax-mode (if traverse-syntax? 'compound 'atomic)
-               #:allow-impersonators? #f
-               #:allow-mutable? 'no-hash/prefab
-               #:allow-unreadable-symbols? #t
-               #:allow-cycles? #t
-               #:irritant irritant-box))
-
-;; ----
-
-;; check-datum : any ... -> boolean
-;; where StxMode = (U 'atomic 'compound #f)
-;; Returns nat if x is "good", #f if "bad"
-;; If irritant-b is a box, the first bad subvalue found is put in the box.
-;; If visited-t is a hash, it is used to detect cycles.
-(define (check-datum x
-                     #:syntax-mode [stx-mode #f]
-                     #:allow-impersonators? [allow-impersonators? #f]
-                     #:allow-mutable? [allow-mutable? #f]
-                     #:allow-unreadable-symbols? [allow-unreadable? #f]
-                     #:allow-cycles? [allow-cycles? #f]
-                     #:irritant [irritant-b #f])
-  ;; Try once with some fuel. If runs out of fuel, try again with cycle checking.
-  (define (run fuel visited-t)
-    (check* x fuel visited-t
-            stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
-            irritant-b))
-  (let ([result (run INIT-FUEL #f)])
-    (cond [(not (equal? result 0)) ;; nat>0 or #f
-           (and result #t)]
-          [else
-           ;; (eprintf "out of fuel, restarting\n")
-           (and (run +inf.0 (make-hasheq)) #t)])))
-
-;; check* : any nat/+inf.0 StxMode boolean boolean boolean box -> nat/#f
-;; Returns #f if bad, positive nat if good, 0 if ran out of fuel
-;; If bad, places bad subvalue in irritant-b, if box
-(define (check* x0 fuel0 visited-t
-                stx-mode allow-impersonators? allow-mutable? allow-unreadable? allow-cycles?
-                irritant-b)
-  (define no-mutable? (not allow-mutable?))
-  (define no-mutable-hash/prefab? (or no-mutable? (eq? allow-mutable? 'no-hash/prefab)))
-  (define no-cycle? (not allow-cycles?))
-  (define no-impersonator? (not allow-impersonators?))
-  (define (loop x fuel)
-    (if (and fuel (not (zero? fuel)))
-        (loop* x fuel)
-        fuel))
-  (define (loop* x fuel)
-    (define (bad) (when irritant-b (set-box! irritant-b x)) #f)
-    (define-syntax-rule (with-mutable-check mutable? body ...) ;; don't use for hash or prefab
-      (cond [(and no-mutable? mutable?)
-             (bad)]
-            [else
-             body ...]))
-    (define-syntax-rule (with-cycle-check body ...)
-      (cond [(and visited-t (hash-ref visited-t x #f))
-             => (lambda (status)
-                  (cond [(and no-cycle? (eq? status 'traversing))
-                         (bad)]
-                        [else
-                         fuel]))]
-            [else
-             (when visited-t
-               (hash-set! visited-t x 'traversing))
-             (begin0 (begin body ...)
-               (when visited-t
-                 (hash-remove! visited-t x)))]))
-    ;; (eprintf "-- checking ~s, fuel ~s\n" x fuel)
-    (cond
-     ;; Immutable compound
-     [(and visited-t (list? x))
-      ;; space optimization: if list (finite), no need to store all cdr pairs in cycle table
-      ;; don't do unless visited-t present, else expands fuel by arbitrary factors
-      (with-cycle-check
-       (for/fold ([fuel (sub1 fuel)]) ([e (in-list x)] #:break (not fuel))
-         (loop e fuel)))]
-     [(pair? x)
-      (with-cycle-check
-       (let ([fuel (loop (car x) (sub1 fuel))])
-         (loop (cdr x) fuel)))]
-     ;; Atomic
-     [(or (null? x)
-          (boolean? x)
-          (number? x)
-          (char? x)
-          (keyword? x)
-          (regexp? x)
-          (byte-regexp? x)
-          (extflonum? x))
-      fuel]
-     [(symbol? x)
-      (cond [(symbol-interned? x)
-             fuel]
-            [(symbol-unreadable? x)
-             (if allow-unreadable? fuel (bad))]
-            [else ;; uninterned
-             (if (eq? allow-unreadable? #t) fuel (bad))])]
-     ;; Mutable flat
-     [(or (string? x)
-          (bytes? x))
-      (with-mutable-check (not (immutable? x))
-        fuel)]
-     [(or (fxvector? x)
-          (flvector? x)
-          (extflvector? x))
-      (with-mutable-check (not (immutable? x))
-        fuel)]
-     ;; Syntax
-     [(syntax? x)
-      (case stx-mode
-        ((atomic) fuel)
-        ((compound) (loop (syntax-e x) fuel))
-        (else (bad)))]
-     ;; Impersonators and chaperones
-     [(and no-impersonator? (impersonator? x))  ;; else continue to chaperoned type
-      (bad)]
-     [(and no-impersonator? (chaperone? x))  ;; else continue to impersonated type
-      (bad)]
-     [else
-      (with-cycle-check
-       (cond
-        ;; Mutable (maybe) compound
-        [(vector? x)
-         (with-mutable-check (not (immutable? x))
-           (for/fold ([fuel fuel]) ([e (in-vector x)] #:break (not fuel))
-             (loop e fuel)))]
-        [(box? x)
-         (with-mutable-check (not (immutable? x))
-           (loop (unbox x) (sub1 fuel)))]
-        [(prefab-struct-key x)
-         => (lambda (key)
-              (cond [(and no-mutable-hash/prefab? (mutable-prefab-key? key))
-                     (bad)]
-                    [else
-                     ;; traverse key, since contains arbitrary auto-value
-                     (let ([fuel (loop key fuel)])
-                       (loop (struct->vector x) fuel))]))]
-        [(hash? x)
-         (cond [(and no-mutable-hash/prefab? (not (immutable? x)))
-                (bad)]
-               [else
-                (for/fold ([fuel fuel]) ([(k v) (in-hash x)] #:break (not fuel))
-                  (let ([fuel (loop k fuel)])
-                    (loop v fuel)))])]
-        ;; Bad
-        [else
-         (bad)]))]))
-  (loop x0 fuel0))
-
-;; mutable-prefab-key? : prefab-key -> boolean
-(define (mutable-prefab-key? key)
-  ;; A prefab-key is either
-  ;;  - symbol
-  ;;  - (list* symbol maybe-nat maybe-list maybe-vector prefab-key)
-  ;; where mutable fields indicated by vector
-  ;; This code is probably overly general; racket seems to normalize keys.
-  (let loop ([k key])
-    (and (pair? k)
-         (or (and (vector? (car k))
-                  (positive? (vector-length (car k))))
-             (loop (cdr k))))))

parse/private/lib.rkt

@@ -3,12 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/lib.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/lib.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/lib.rkt")]
-  [else
-    (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/lib.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/lib.rkt")

parse/private/litconv.rkt

@@ -1,284 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base
-                     racket/lazy-require
-                     "sc.rkt"
-                     "lib.rkt"
-                     syntax/parse/private/kws
-                     racket/syntax)
-         syntax/parse/private/residual-ct ;; keep abs. path
-         stxparse-info/parse/private/residual)   ;; keep abs. path
-(begin-for-syntax
- (lazy-require
-  [syntax/private/keyword (options-select-value parse-keyword-options)]
-  [stxparse-info/parse/private/rep ;; keep abs. path
-   (parse-kw-formals
-    check-conventions-rules
-    check-datum-literals-list
-    create-aux-def)]))
-;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
-;; Without this, dependencies don't get collected.
-(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
-(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
-
-(provide define-conventions
-         define-literal-set
-         literal-set->predicate
-         kernel-literals)
-
-(define-syntax (define-conventions stx)
-
-  (define-syntax-class header
-    #:description "name or name with formal parameters"
-    #:commit
-    (pattern name:id
-             #:with formals #'()
-             #:attr arity (arity 0 0 null null))
-    (pattern (name:id . formals)
-             #:attr arity (parse-kw-formals #'formals #:context stx)))
-
-  (syntax-parse stx
-    [(define-conventions h:header rule ...)
-     (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 (in-list 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 (class-name ...)
-         (map den:delayed-class dens))
-
-       ;; FIXME: could move make-den:delayed to user of conventions
-       ;; and eliminate from residual.rkt
-       #'(begin
-           (define-syntax h.name
-             (make-conventions
-              (quote-syntax get-parsers)
-              (lambda ()
-                (let ([class-names (list (quote-syntax class-name) ...)])
-                  (map list
-                       (list 'rx ...)
-                       (map make-den:delayed
-                            (generate-temporaries class-names)
-                            class-names))))))
-           (define get-parsers
-             (lambda formals
-               def ...
-               (list parser ...)))))]))
-
-(define-for-syntax (check-phase-level stx ctx)
-  (unless (or (exact-integer? (syntax-e stx))
-              (eq? #f (syntax-e stx)))
-    (raise-syntax-error #f "expected phase-level (exact integer or #f)" ctx stx))
-  stx)
-
-;; check-litset-list : stx stx -> (listof (cons id literalset))
-(define-for-syntax (check-litset-list stx ctx)
-  (syntax-case stx ()
-    [(litset-id ...)
-     (for/list ([litset-id (syntax->list #'(litset-id ...))])
-       (let* ([val (and (identifier? litset-id)
-                        (syntax-local-value/record litset-id literalset?))])
-         (if val
-             (cons litset-id val)
-             (raise-syntax-error #f "expected literal set name" ctx litset-id))))]
-    [_ (raise-syntax-error #f "expected list of literal set names" ctx stx)]))
-
-;; check-literal-entry/litset : stx stx -> (list id id)
-(define-for-syntax (check-literal-entry/litset stx ctx)
-  (syntax-case stx ()
-    [(internal external)
-     (and (identifier? #'internal) (identifier? #'external))
-     (list #'internal #'external)]
-    [id
-     (identifier? #'id)
-     (list #'id #'id)]
-    [_ (raise-syntax-error #f "expected literal entry" ctx stx)]))
-
-(define-for-syntax (check-duplicate-literals ctx imports lits datum-lits)
-  (let ([lit-t (make-hasheq)]) ;; sym => #t
-    (define (check+enter! key blame-stx)
-      (when (hash-ref lit-t key #f)
-        (raise-syntax-error #f (format "duplicate literal: ~a" key) ctx blame-stx))
-      (hash-set! lit-t key #t))
-    (for ([id+litset (in-list imports)])
-      (let ([litset-id (car id+litset)]
-            [litset (cdr id+litset)])
-        (for ([entry (in-list (literalset-literals litset))])
-          (cond [(lse:lit? entry)
-                 (check+enter! (lse:lit-internal entry) litset-id)]
-                [(lse:datum-lit? entry)
-                 (check+enter! (lse:datum-lit-internal entry) litset-id)]))))
-    (for ([datum-lit (in-list datum-lits)])
-      (let ([internal (den:datum-lit-internal datum-lit)])
-        (check+enter! (syntax-e internal) internal)))
-    (for ([lit (in-list lits)])
-      (check+enter! (syntax-e (car lit)) (car lit)))))
-
-(define-syntax (define-literal-set stx)
-  (syntax-case stx ()
-    [(define-literal-set name . rest)
-     (let-values ([(chunks rest)
-                   (parse-keyword-options
-                    #'rest
-                    `((#:literal-sets ,check-litset-list)
-                      (#:datum-literals ,check-datum-literals-list)
-                      (#:phase ,check-phase-level)
-                      (#:for-template)
-                      (#:for-syntax)
-                      (#:for-label))
-                    #:incompatible '((#:phase #:for-template #:for-syntax #:for-label))
-                    #:context stx
-                    #:no-duplicates? #t)])
-       (unless (identifier? #'name)
-         (raise-syntax-error #f "expected identifier" stx #'name))
-       (let ([relphase
-              (cond [(assq '#:for-template chunks) -1]
-                    [(assq '#:for-syntax chunks) 1]
-                    [(assq '#:for-label chunks) #f]
-                    [else (options-select-value chunks '#:phase #:default 0)])]
-             [datum-lits
-              (options-select-value chunks '#:datum-literals #:default null)]
-             [lits (syntax-case rest ()
-                     [( (lit ...) )
-                      (for/list ([lit (in-list (syntax->list #'(lit ...)))])
-                        (check-literal-entry/litset lit stx))]
-                     [_ (raise-syntax-error #f "bad syntax" stx)])]
-             [imports (options-select-value chunks '#:literal-sets #:default null)])
-         (check-duplicate-literals stx imports lits datum-lits)
-         (with-syntax ([((internal external) ...) lits]
-                       [(datum-internal ...) (map den:datum-lit-internal datum-lits)]
-                       [(datum-external ...) (map den:datum-lit-external datum-lits)]
-                       [(litset-id ...) (map car imports)]
-                       [relphase relphase])
-           #`(begin
-               (define phase-of-literals
-                 (and 'relphase
-                      (+ (variable-reference->module-base-phase (#%variable-reference))
-                         'relphase)))
-               (define-syntax name
-                 (make-literalset
-                  (append (literalset-literals (syntax-local-value (quote-syntax litset-id)))
-                          ...
-                          (list (make-lse:lit 'internal
-                                              (quote-syntax external)
-                                              (quote-syntax phase-of-literals))
-                                ...
-                                (make-lse:datum-lit 'datum-internal
-                                                    'datum-external)
-                                ...))))
-               (begin-for-syntax/once
-                (for ([x (in-list (syntax->list #'(external ...)))])
-                  (unless (identifier-binding x 'relphase)
-                    (raise-syntax-error #f
-                                        (format "literal is unbound in phase ~a~a~a"
-                                                'relphase
-                                                (case 'relphase
-                                                  ((1) " (for-syntax)")
-                                                  ((-1) " (for-template)")
-                                                  ((#f) " (for-label)")
-                                                  (else ""))
-                                                " relative to the enclosing module")
-                                        (quote-syntax #,stx) x))))))))]))
-
-#|
-NOTES ON PHASES AND BINDINGS
-
-(module M ....
-  .... (define-literal-set LS #:phase PL ....)
-  ....)
-
-For the expansion of the define-literal-set form, the bindings of the literals
-can be accessed by (identifier-binding lit PL), because the phase of the enclosing
-module (M) is 0.
-
-LS may be used, however, in a context where the phase of the enclosing
-module is not 0, so each instantiation of LS needs to calculate the
-phase of M and add that to PL.
-
---
-
-Normally, literal sets that define the same name conflict. But it
-would be nice to allow them to both be imported in the case where they
-refer to the same binding.
-
-Problem: Can't do the check eagerly, because the binding of L may
-change between when define-literal-set is compiled and the comparison
-involving L. For example:
-
-  (module M racket
-    (require stxparse-info/parse)
-    (define-literal-set LS (lambda))
-    (require (only-in some-other-lang lambda))
-    .... LS ....)
-
-The expansion of the LS definition sees a different lambda than the
-one that the literal in LS actually refers to.
-
-Similarly, a literal in LS might not be defined when the expander
-runs, but might get defined later. (Although I think that will already
-cause an error, so don't worry about that case.)
-|#
-
-;; FIXME: keep one copy of each identifier (?)
-
-(define-syntax (literal-set->predicate stx)
-  (syntax-case stx ()
-    [(literal-set->predicate litset-id)
-     (let ([val (and (identifier? #'litset-id)
-                     (syntax-local-value/record #'litset-id literalset?))])
-       (unless val (raise-syntax-error #f "expected literal set name" stx #'litset-id))
-       (let ([lits (literalset-literals val)])
-         (with-syntax ([((lit phase-var) ...)
-                        (for/list ([lit (in-list lits)]
-                                   #:when (lse:lit? lit))
-                          (list (lse:lit-external lit) (lse:lit-phase lit)))]
-                       [(datum-lit ...)
-                        (for/list ([lit (in-list lits)]
-                                   #:when (lse:datum-lit? lit))
-                          (lse:datum-lit-external lit))])
-           #'(make-literal-set-predicate (list (list (quote-syntax lit) phase-var) ...)
-                                         '(datum-lit ...)))))]))
-
-(define (make-literal-set-predicate lits datum-lits)
-  (lambda (x [phase (syntax-local-phase-level)])
-    (or (for/or ([lit (in-list lits)])
-          (let ([lit-id (car lit)]
-                [lit-phase (cadr lit)])
-            (free-identifier=? x lit-id phase lit-phase)))
-        (and (memq (syntax-e x) datum-lits) #t))))
-
-;; Literal sets
-
-(define-literal-set kernel-literals
-  (begin
-   begin0
-   define-values
-   define-syntaxes
-   define-values-for-syntax ;; kept for compat.
-   begin-for-syntax
-   set!
-   let-values
-   letrec-values
-   #%plain-lambda
-   case-lambda
-   if
-   quote
-   quote-syntax
-   letrec-syntaxes+values
-   with-continuation-mark
-   #%expression
-   #%plain-app
-   #%top
-   #%datum
-   #%variable-reference
-   module module* #%provide #%require #%declare
-   #%plain-module-begin))
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/private/litconv.rkt")

parse/private/make.rkt

@@ -1,43 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base
-                     racket/struct-info))
-(provide make)
-
-;; get-struct-info : identifier stx -> struct-info-list
-(define-for-syntax (get-struct-info id ctx)
-  (define (bad-struct-name x)
-    (raise-syntax-error #f "expected struct name" ctx x))
-  (unless (identifier? id)
-    (bad-struct-name id))
-  (let ([value (syntax-local-value id (lambda () #f))])
-    (unless (struct-info? value)
-      (bad-struct-name id))
-    (extract-struct-info value)))
-
-;; (make struct-name field-expr ...)
-;; Checks that correct number of fields given.
-(define-syntax (make stx)
-  (syntax-case stx ()
-    [(make S expr ...)
-     (let ()
-       (define info (get-struct-info #'S stx))
-       (define constructor (list-ref info 1))
-       (define accessors (list-ref info 3))
-       (unless (identifier? #'constructor)
-         (raise-syntax-error #f "constructor not available for struct" stx #'S))
-       (unless (andmap identifier? accessors)
-         (raise-syntax-error #f "incomplete info for struct type" stx #'S))
-       (let ([num-slots (length accessors)]
-             [num-provided (length (syntax->list #'(expr ...)))])
-         (unless (= num-provided num-slots)
-           (raise-syntax-error
-            #f
-            (format "wrong number of arguments for struct ~s (expected ~s, got ~s)"
-                    (syntax-e #'S)
-                    num-slots
-                    num-provided)
-            stx)))
-       (with-syntax ([constructor constructor])
-         (syntax-property #'(constructor expr ...)
-                          'disappeared-use
-                          #'S)))]))
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/private/make.rkt")

parse/private/opt.rkt

@@ -3,8 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/opt.rkt")]
-  [else
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/opt.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/opt.rkt")

parse/private/parse-aux.rkt

@@ -3,8 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/parse-aux.rkt")]
-  [else
-    (begin)])
+(my-include "../../" "/racket/collects/syntax/parse/private/parse-aux.rkt")

parse/private/parse.rkt

@@ -3,14 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/parse.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/parse.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/parse.rkt")]
-  [(version< (version) "7.3.0.1")
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/parse.rkt")]
-  [else
-    (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/parse.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/parse.rkt")

parse/private/rep.rkt

@@ -3,14 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/rep.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/rep.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/rep.rkt")]
-  [(version< (version) "7.3.0.1")
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/rep.rkt")]
-  [else
-    (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/rep.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/rep.rkt")

parse/private/residual.rkt

@@ -3,12 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/residual.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/residual.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/residual.rkt")]
-  [else
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/residual.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/residual.rkt")

parse/private/runtime-progress.rkt

@@ -1,257 +1,6 @@
 #lang racket/base
-(require racket/list
-         syntax/parse/private/minimatch)
-(provide ps-empty
-         ps-add-car
-         ps-add-cdr
-         ps-add-stx
-         ps-add-unbox
-         ps-add-unvector
-         ps-add-unpstruct
-         ps-add-opaque
-         ps-add-post
-         ps-add
-         (struct-out ord)
-
-         ps-pop-opaque
-         ps-pop-ord
-         ps-pop-post
-         ps-context-syntax
-         ps-difference
-
-         (struct-out failure)
-         failure*
-
-         expect?
-         (struct-out expect:thing)
-         (struct-out expect:atom)
-         (struct-out expect:literal)
-         (struct-out expect:message)
-         (struct-out expect:disj)
-         (struct-out expect:proper-pair)
-
-         es-add-thing
-         es-add-message
-         es-add-atom
-         es-add-literal
-         es-add-proper-pair)
-
-;; FIXME: add phase to expect:literal
-
-;; == Failure ==
-
-#|
-A Failure is (failure PS ExpectStack)
-
-A FailureSet is one of
-  - Failure
-  - (cons FailureSet FailureSet)
-
-A FailFunction = (FailureSet -> Answer)
-|#
-(define-struct failure (progress expectstack) #:prefab)
-
-;; failure* : PS ExpectStack/#f -> Failure/#t
-(define (failure* ps es) (if es (failure ps es) #t))
-
-;; == Progress ==
-
-#|
-Progress (PS) is a non-empty list of Progress Frames (PF).
-
-A Progress Frame (PF) is one of
-  - stx     ;; "Base" frame, or ~parse/#:with term
-  - 'car    ;; car of pair; also vector->list, unbox, struct->list, etc
-  - nat     ;; Represents that many repeated cdrs
-  - 'post   ;; late/post-traversal check
-  - #s(ord group index) ;; ~and subpattern, only comparable w/in group
-  - 'opaque
-
-The error-reporting context (ie, syntax-parse #:context arg) is always
-the final frame.
-
-All non-stx frames (eg car, cdr) interpreted as applying to nearest following
-stx frame.
-
-A stx frame is introduced
-  - always at base (that is, by syntax-parse)
-    - if syntax-parse has #:context arg, then two stx frames at bottom:
-      (list to-match-stx context-stx)
-  - by #:with/~parse
-  - by #:fail-*/#:when/~fail & stx
-
-Interpretation: later frames are applied first.
- eg, (list 'car 1 stx)
-      means ( car of ( cdr once of stx ) )
-      NOT apply car, then apply cdr once, then stop
-|#
-(define-struct ord (group index) #:prefab)
-
-(define (ps-empty stx ctx)
-  (if (eq? stx ctx)
-      (list stx)
-      (list stx ctx)))
-(define (ps-add-car parent)
-  (cons 'car parent))
-(define (ps-add-cdr parent [times 1])
-  (if (zero? times)
-      parent
-      (match (car parent)
-        [(? exact-positive-integer? n)
-         (cons (+ times n) (cdr parent))]
-        [_
-         (cons times parent)])))
-(define (ps-add-stx parent stx)
-  (cons stx parent))
-(define (ps-add-unbox parent)
-  (ps-add-car parent))
-(define (ps-add-unvector parent)
-  (ps-add-car parent))
-(define (ps-add-unpstruct parent)
-  (ps-add-car parent))
-(define (ps-add-opaque parent)
-  (cons 'opaque parent))
-(define (ps-add parent frame)
-  (cons frame parent))
-(define (ps-add-post parent)
-  (cons 'post parent))
-
-;; ps-context-syntax : Progress -> syntax
-(define (ps-context-syntax ps)
-  ;; Bottom frame is always syntax
-  (last ps))
-
-;; ps-difference : PS PS -> nat
-;; Returns N s.t. B = (ps-add-cdr^N A)
-(define (ps-difference a b)
-  (define-values (a-cdrs a-base)
-    (match a
-      [(cons (? exact-positive-integer? a-cdrs) a-base)
-       (values a-cdrs a-base)]
-      [_ (values 0 a)]))
-  (define-values (b-cdrs b-base)
-    (match b
-      [(cons (? exact-positive-integer? b-cdrs) b-base)
-       (values b-cdrs b-base)]
-      [_ (values 0 b)]))
-  (unless (eq? a-base b-base)
-    (error 'ps-difference "INTERNAL ERROR: ~e does not extend ~e" b a))
-  (- b-cdrs a-cdrs))
-
-;; ps-pop-opaque : PS -> PS
-;; Used to continue with progress from opaque head pattern.
-(define (ps-pop-opaque ps)
-  (match ps
-    [(cons (? exact-positive-integer? n) (cons 'opaque ps*))
-     (ps-add-cdr ps* n)]
-    [(cons 'opaque ps*)
-     ps*]
-    [_ (error 'ps-pop-opaque "INTERNAL ERROR: opaque frame not found: ~e" ps)]))
-
-;; ps-pop-ord : PS -> PS
-(define (ps-pop-ord ps)
-  (match ps
-    [(cons (? exact-positive-integer? n) (cons (? ord?) ps*))
-     (ps-add-cdr ps* n)]
-    [(cons (? ord?) ps*)
-     ps*]
-    [_ (error 'ps-pop-ord "INTERNAL ERROR: ord frame not found: ~e" ps)]))
-
-;; ps-pop-post : PS -> PS
-(define (ps-pop-post ps)
-  (match ps
-    [(cons (? exact-positive-integer? n) (cons 'post ps*))
-     (ps-add-cdr ps* n)]
-    [(cons 'post ps*)
-     ps*]
-    [_ (error 'ps-pop-post "INTERNAL ERROR: post frame not found: ~e" ps)]))
-
-
-;; == Expectations ==
-
-#|
-There are multiple types that use the same structures, optimized for
-different purposes.
-
--- During parsing, the goal is to minimize/consolidate allocations.
-
-An ExpectStack (during parsing) is one of
-  - (expect:thing Progress String Boolean String/#f ExpectStack)
-  * (expect:message String ExpectStack)
-  * (expect:atom Datum ExpectStack)
-  * (expect:literal Identifier ExpectStack)
-  * (expect:proper-pair FirstDesc ExpectStack)
-  * #t
-
-The *-marked variants can only occur at the top of the stack (ie, not
-in the next field of another Expect). The top of the stack contains
-the most specific information.
-
-An ExpectStack can also be #f, which means no failure tracking is
-requested (and thus no more ExpectStacks should be allocated).
-
--- During reporting, the goal is ease of manipulation.
-
-An ExpectList (during reporting) is (listof Expect).
-
-An Expect is one of
-  - (expect:thing #f String #t String/#f StxIdx)
-  * (expect:message String StxIdx)
-  * (expect:atom Datum StxIdx)
-  * (expect:literal Identifier StxIdx)
-  * (expect:proper-pair FirstDesc StxIdx)
-  * (expect:disj (NEListof Expect) StxIdx)
-  - '...
-
-A StxIdx is (cons Syntax Nat)
-
-That is, the next link is replaced with the syntax+index of the term
-being complained about. An expect:thing's progress is replaced with #f.
-
-An expect:disj never contains a '... or another expect:disj.
-
-We write ExpectList when the most specific information comes first and
-RExpectList when the most specific information comes last.
-|#
-(struct expect:thing (term description transparent? role next) #:prefab)
-(struct expect:message (message next) #:prefab)
-(struct expect:atom (atom next) #:prefab)
-(struct expect:literal (literal next) #:prefab)
-(struct expect:disj (expects next) #:prefab)
-(struct expect:proper-pair (first-desc next) #:prefab)
-
-(define (expect? x)
-  (or (expect:thing? x)
-      (expect:message? x)
-      (expect:atom? x)
-      (expect:literal? x)
-      (expect:disj? x)
-      (expect:proper-pair? x)))
-
-(define (es-add-thing ps description transparent? role next)
-  (if (and next description)
-      (expect:thing ps description transparent? role next)
-      next))
-
-(define (es-add-message message next)
-  (if (and next message)
-      (expect:message message next)
-      next))
-
-(define (es-add-atom atom next)
-  (and next (expect:atom atom next)))
-
-(define (es-add-literal literal next)
-  (and next (expect:literal literal next)))
-
-(define (es-add-proper-pair first-desc next)
-  (and next (expect:proper-pair first-desc next)))
-
-#|
-A FirstDesc is one of
- - #f                   -- unknown, multiple possible, etc
- - string               -- description
- - (list 'any)
- - (list 'literal symbol)
- - (list 'datum datum)
-|#
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/private/runtime-progress.rkt")

parse/private/runtime-reflect.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/runtime-reflect.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/runtime-reflect.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime-reflect.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/runtime-reflect.rkt")

parse/private/runtime-report.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/runtime-report.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/runtime-report.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime-report.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/runtime-report.rkt")

parse/private/runtime.rkt

@@ -3,10 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/runtime.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/runtime.rkt")]
-  [else
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/runtime.rkt")

parse/private/sc.rkt

@@ -3,12 +3,4 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "../../6-11/racket/collects/syntax/parse/private/sc.rkt")]
-  [(version< (version) "6.90.0.29")
-    (my-include "../../6-12/racket/collects/syntax/parse/private/sc.rkt")]
-  [(version< (version) "7.0.0.20")
-    (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/sc.rkt")]
-  [else
-    (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/sc.rkt")])
+(my-include "../../" "/racket/collects/syntax/parse/private/sc.rkt")

parse/private/txlift.rkt

@@ -1,45 +1,6 @@
 #lang racket/base
-(require (for-template racket/base))
-(provide txlift
-         get-txlifts-as-definitions
-         with-txlifts
-         call/txlifts)
-
-;; Like lifting definitions, but within a single transformer.
-
-;; current-liftbox : Parameter of [#f or (Listof (list Id Stx))]
-(define current-liftbox (make-parameter #f))
-
-(define (call/txlifts proc)
-  (parameterize ((current-liftbox (box null)))
-    (proc)))
-
-(define (txlift expr)
-  (let ([liftbox (current-liftbox)])
-    (check 'txlift liftbox)
-    (let ([var (car (generate-temporaries '(txlift)))])
-      (set-box! liftbox (cons (list var expr) (unbox liftbox)))
-      var)))
-
-(define (get-txlifts)
-  (let ([liftbox (current-liftbox)])
-    (check 'get-txlifts liftbox)
-    (reverse (unbox liftbox))))
-
-(define (get-txlifts-as-definitions)
-  (let ([liftbox (current-liftbox)])
-    (check 'get-txlifts-as-definitions liftbox)
-    (map (lambda (p)
-           #`(define #,@p))
-         (reverse (unbox liftbox)))))
-
-(define (check who lb)
-  (unless (box? lb)
-    (error who "not in a txlift-catching context")))
-
-(define (with-txlifts proc)
-  (call/txlifts
-   (lambda ()
-     (let ([v (proc)])
-       (with-syntax ([((var rhs) ...) (get-txlifts)])
-         #`(let* ([var rhs] ...) #,v))))))
+(#%require version-case
+           (for-syntax (only racket/base version)
+                       (only racket/base #%app #%datum))
+           stxparse-info/my-include)
+(my-include "../../" "/racket/collects/syntax/parse/private/txlift.rkt")

scribblings/stxparse-info.scrbl

@@ -3,12 +3,5 @@
            (for-syntax (only racket/base version)
                        (only racket/base #%app #%datum))
            stxparse-info/my-include)
-(version-case
-  [(version< (version) "6.11.0.900")
-    (my-include "stxparse-info.scrbl-6-11")]
-  [(version< (version) "6.90.0.29")
-    (my-include "stxparse-info.scrbl-6-12")]
-  [(version< (version) "7.3.0.1")
-    (my-include "stxparse-info.scrbl-6-90-0-29")]
-  [else
-    (my-include "stxparse-info.scrbl-7-3-0-1")])
+(my-include "../" "/stxparse-info.scrbl")
+