From d64d2c1901bc0e369008511e3abc40f089450830 Mon Sep 17 00:00:00 2001
From: Suzanne Soy <ligo@suzanne.soy>
Date: Wed, 3 Mar 2021 03:21:48 +0000
Subject: [PATCH] Upgrade for Racket 7.4
---
7-4/0001-require-paths.patch | 650 ++++++
...ax-e-and-template-metafunction-stuff.patch | 197 ++
7-4/base_commit.txt | 1 +
.../racket/private/stxcase-scheme.rkt | 75 +
.../collects/racket/private/stxcase.rkt | 390 ++++
7-4/racket/collects/racket/private/stxloc.rkt | 59 +
.../collects/racket/private/template.rkt | 705 ++++++
.../collects/racket/private/with-stx.rkt | 99 +
7-4/racket/collects/racket/syntax.rkt | 216 ++
7-4/racket/collects/syntax/parse.rkt | 33 +
7-4/racket/collects/syntax/parse/debug.rkt | 129 ++
7-4/racket/collects/syntax/parse/define.rkt | 20 +
.../syntax/parse/experimental/contract.rkt | 46 +
.../collects/syntax/parse/experimental/eh.rkt | 5 +
.../parse/experimental/private/substitute.rkt | 1 +
.../syntax/parse/experimental/provide.rkt | 156 ++
.../syntax/parse/experimental/reflect.rkt | 147 ++
.../syntax/parse/experimental/specialize.rkt | 40 +
.../syntax/parse/experimental/splicing.rkt | 95 +
.../syntax/parse/experimental/template.rkt | 49 +
.../syntax/parse/lib/function-header.rkt | 112 +
7-4/racket/collects/syntax/parse/pre.rkt | 49 +
.../collects/syntax/parse/private/3d-stx.rkt | 250 +++
.../collects/syntax/parse/private/lib.rkt | 96 +
.../collects/syntax/parse/private/litconv.rkt | 284 +++
.../collects/syntax/parse/private/make.rkt | 43 +
.../collects/syntax/parse/private/opt.rkt | 456 ++++
.../collects/syntax/parse/private/parse.rkt | 1206 ++++++++++
.../collects/syntax/parse/private/rep.rkt | 1965 +++++++++++++++++
.../syntax/parse/private/residual.rkt | 302 +++
.../syntax/parse/private/runtime-progress.rkt | 258 +++
.../syntax/parse/private/runtime-reflect.rkt | 96 +
.../syntax/parse/private/runtime-report.rkt | 816 +++++++
.../collects/syntax/parse/private/runtime.rkt | 235 ++
.../collects/syntax/parse/private/sc.rkt | 32 +
.../collects/syntax/parse/private/txlift.rkt | 45 +
7-4/stxparse-info.scrbl | 357 +++
info.rkt | 4 +-
my-include.rkt | 6 +-
39 files changed, 9721 insertions(+), 4 deletions(-)
create mode 100644 7-4/0001-require-paths.patch
create mode 100644 7-4/0002-auto-syntax-e-and-template-metafunction-stuff.patch
create mode 100644 7-4/base_commit.txt
create mode 100644 7-4/racket/collects/racket/private/stxcase-scheme.rkt
create mode 100644 7-4/racket/collects/racket/private/stxcase.rkt
create mode 100644 7-4/racket/collects/racket/private/stxloc.rkt
create mode 100644 7-4/racket/collects/racket/private/template.rkt
create mode 100644 7-4/racket/collects/racket/private/with-stx.rkt
create mode 100644 7-4/racket/collects/racket/syntax.rkt
create mode 100644 7-4/racket/collects/syntax/parse.rkt
create mode 100644 7-4/racket/collects/syntax/parse/debug.rkt
create mode 100644 7-4/racket/collects/syntax/parse/define.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/contract.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/eh.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/private/substitute.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/provide.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/reflect.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/specialize.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/splicing.rkt
create mode 100644 7-4/racket/collects/syntax/parse/experimental/template.rkt
create mode 100644 7-4/racket/collects/syntax/parse/lib/function-header.rkt
create mode 100644 7-4/racket/collects/syntax/parse/pre.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/3d-stx.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/lib.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/litconv.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/make.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/opt.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/parse.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/rep.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/residual.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/runtime-progress.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/runtime-reflect.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/runtime-report.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/runtime.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/sc.rkt
create mode 100644 7-4/racket/collects/syntax/parse/private/txlift.rkt
create mode 100644 7-4/stxparse-info.scrbl
diff --git a/7-4/0001-require-paths.patch b/7-4/0001-require-paths.patch
new file mode 100644
index 0000000..6b8be51
--- /dev/null
+++ b/7-4/0001-require-paths.patch
@@ -0,0 +1,650 @@
+From f40af8e9288f83b19c8b358981e2a8c7c42874ef Mon Sep 17 00:00:00 2001
+From: Suzanne Soy <ligo@suzanne.soy>
+Date: Tue, 2 Mar 2021 21:19:51 +0000
+Subject: [PATCH 1/2] require paths
+
+---
+ .../racket/private/stxcase-scheme.rkt | 7 +--
+ racket/collects/racket/private/stxcase.rkt | 12 ++---
+ racket/collects/racket/private/stxloc.rkt | 4 +-
+ racket/collects/racket/private/template.rkt | 49 +++++++++++--------
+ racket/collects/racket/private/with-stx.rkt | 6 +--
+ racket/collects/racket/syntax.rkt | 3 +-
+ racket/collects/syntax/parse.rkt | 3 +-
+ racket/collects/syntax/parse/debug.rkt | 8 +--
+ racket/collects/syntax/parse/define.rkt | 4 +-
+ .../syntax/parse/experimental/contract.rkt | 4 +-
+ .../collects/syntax/parse/experimental/eh.rkt | 2 +-
+ .../parse/experimental/private/substitute.rkt | 1 +
+ .../syntax/parse/experimental/provide.rkt | 6 +--
+ .../syntax/parse/experimental/reflect.rkt | 6 +--
+ .../syntax/parse/experimental/specialize.rkt | 4 +-
+ .../syntax/parse/experimental/splicing.rkt | 6 +--
+ racket/collects/syntax/parse/private/lib.rkt | 2 +-
+ .../collects/syntax/parse/private/litconv.rkt | 10 ++--
+ racket/collects/syntax/parse/private/opt.rkt | 6 +--
+ .../collects/syntax/parse/private/parse.rkt | 18 +++----
+ racket/collects/syntax/parse/private/rep.rkt | 14 +++---
+ .../syntax/parse/private/residual.rkt | 6 +--
+ .../syntax/parse/private/runtime-progress.rkt | 2 +-
+ .../syntax/parse/private/runtime-reflect.rkt | 30 +++++++++---
+ .../syntax/parse/private/runtime-report.rkt | 6 +--
+ .../collects/syntax/parse/private/runtime.rkt | 4 +-
+ racket/collects/syntax/parse/private/sc.rkt | 4 +-
+ 27 files changed, 128 insertions(+), 99 deletions(-)
+ create mode 100644 racket/collects/syntax/parse/experimental/private/substitute.rkt
+
+diff --git racket/collects/racket/private/stxcase-scheme.rkt racket/collects/racket/private/stxcase-scheme.rkt
+index 9f1a21abbb..46bddba4e5 100644
+--- racket/collects/racket/private/stxcase-scheme.rkt
++++ racket/collects/racket/private/stxcase-scheme.rkt
+@@ -4,8 +4,8 @@
+ ;; check-duplicate-identifier, and assembles everything we have so far
+
+ (module stxcase-scheme '#%kernel
+- (#%require "small-scheme.rkt" "stx.rkt" "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
+- (for-syntax '#%kernel "small-scheme.rkt" "stx.rkt" "stxcase.rkt"
++ (#%require racket/private/small-scheme racket/private/stx "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
++ (for-syntax '#%kernel racket/private/small-scheme racket/private/stx "stxcase.rkt"
+ "stxloc.rkt"))
+
+ (-define (check-duplicate-identifier names)
+@@ -68,7 +68,8 @@
+ (syntax-arm stx #f #t)
+ (raise-argument-error 'syntax-protect "syntax?" stx)))
+
+- (#%provide syntax datum (all-from "with-stx.rkt") (all-from "stxloc.rkt")
++ (#%provide syntax datum (all-from "with-stx.rkt")
++ (all-from "stxloc.rkt")
+ check-duplicate-identifier syntax-protect
+ syntax-rules syntax-id-rules
+ (for-syntax syntax-pattern-variable?)))
+diff --git racket/collects/racket/private/stxcase.rkt racket/collects/racket/private/stxcase.rkt
+index 69832a27a1..ca8f8f631b 100644
+--- racket/collects/racket/private/stxcase.rkt
++++ racket/collects/racket/private/stxcase.rkt
+@@ -2,10 +2,10 @@
+ ;; syntax-case and syntax
+
+ (module stxcase '#%kernel
+- (#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
+- "ellipses.rkt"
+- (for-syntax "stx.rkt" "small-scheme.rkt"
+- "gen-temp.rkt" "member.rkt" "sc.rkt" '#%kernel))
++ (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
++ racket/private/ellipses
++ (for-syntax racket/private/stx racket/private/small-scheme
++ racket/private/gen-temp racket/private/member racket/private/sc '#%kernel))
+
+ (-define interp-match
+ (lambda (pat e literals immediate=?)
+@@ -379,6 +379,6 @@
+ m))))])))
+ x)))))))
+
+- (#%require "template.rkt")
+- (#%provide (all-from "ellipses.rkt") syntax-case** syntax syntax/loc datum
++ (#%require racket/private/template)
++ (#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
+ (for-syntax syntax-pattern-variable?)))
+diff --git racket/collects/racket/private/stxloc.rkt racket/collects/racket/private/stxloc.rkt
+index c9e0d54324..e26417c7bc 100644
+--- racket/collects/racket/private/stxloc.rkt
++++ racket/collects/racket/private/stxloc.rkt
+@@ -3,8 +3,8 @@
+ ;; syntax/loc
+
+ (module stxloc '#%kernel
+- (#%require "qq-and-or.rkt" "stxcase.rkt" "define-et-al.rkt"
+- (for-syntax '#%kernel "stxcase.rkt" "sc.rkt"))
++ (#%require racket/private/qq-and-or "stxcase.rkt" racket/private/define-et-al
++ (for-syntax '#%kernel "stxcase.rkt" racket/private/sc))
+
+ (begin-for-syntax
+ (define-values (transform-to-syntax-case**)
+diff --git racket/collects/racket/private/template.rkt racket/collects/racket/private/template.rkt
+index 9037109f38..06dfba3033 100644
+--- racket/collects/racket/private/template.rkt
++++ racket/collects/racket/private/template.rkt
+@@ -1,25 +1,25 @@
+ (module template '#%kernel
+-(#%require "stx.rkt" "small-scheme.rkt" "performance-hint.rkt"
+- (rename "small-scheme.rkt" define -define)
+- (rename "small-scheme.rkt" define-syntax -define-syntax)
+- "ellipses.rkt"
+- (for-syntax "stx.rkt" "small-scheme.rkt"
+- (rename "small-scheme.rkt" define -define)
+- (rename "small-scheme.rkt" define-syntax -define-syntax)
+- "member.rkt" "sc.rkt" '#%kernel))
++(#%require racket/private/stx racket/private/small-scheme racket/private/performance-hint
++ (rename racket/private/small-scheme define -define)
++ (rename racket/private/small-scheme define-syntax -define-syntax)
++ racket/private/ellipses
++ (for-syntax racket/private/stx racket/private/small-scheme
++ (rename racket/private/small-scheme define -define)
++ (rename racket/private/small-scheme define-syntax -define-syntax)
++ racket/private/member racket/private/sc '#%kernel))
+ (#%provide syntax
+ syntax/loc
+ datum
+ ~? ~@
+ ~@! signal-absent-pvar
+- (protect
+- (for-syntax attribute-mapping
+- attribute-mapping?
+- attribute-mapping-name
+- attribute-mapping-var
+- attribute-mapping-depth
+- attribute-mapping-check
+- metafunction metafunction?)))
++ (for-syntax attribute-mapping
++ attribute-mapping?
++ attribute-mapping-name
++ attribute-mapping-var
++ attribute-mapping-depth
++ attribute-mapping-check
++ (protect metafunction
++ metafunction?)))
+
+ ;; ============================================================
+ ;; Syntax of templates
+@@ -87,7 +87,14 @@
+ ;; (struct attribute-mapping (var name depth check) ...)
+ ;; check : #f (trusted) or Id, ref to Checker
+ ;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) )
+- (define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
++ (#%require (for-template (only racket/private/template
++ attribute-mapping
++ attribute-mapping?
++ attribute-mapping-var
++ attribute-mapping-name
++ attribute-mapping-depth
++ attribute-mapping-check)))
++ #;(define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
+ attribute-mapping-ref _attribute-mapping-set!)
+ (make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector)
+ (lambda (self stx)
+@@ -106,10 +113,10 @@
+ (quote-syntax ,source-name)))
+ (datum->syntax here-stx code stx))
+ (attribute-mapping-var self)))))
+- (define (attribute-mapping-var a) (attribute-mapping-ref a 0))
+- (define (attribute-mapping-name a) (attribute-mapping-ref a 1))
+- (define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
+- (define (attribute-mapping-check a) (attribute-mapping-ref a 3))
++ #;(define (attribute-mapping-var a) (attribute-mapping-ref a 0))
++ #;(define (attribute-mapping-name a) (attribute-mapping-ref a 1))
++ #;(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
++ #;(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
+
+ ;; (struct metafunction (var))
+ (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
+diff --git racket/collects/racket/private/with-stx.rkt racket/collects/racket/private/with-stx.rkt
+index b10fc4ec7c..1e22edcd99 100644
+--- racket/collects/racket/private/with-stx.rkt
++++ racket/collects/racket/private/with-stx.rkt
+@@ -2,9 +2,9 @@
+ ;; with-syntax, generate-temporaries
+
+ (module with-stx '#%kernel
+- (#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt"
+- (for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt"
+- "gen-temp.rkt" "sc.rkt" "qq-and-or.rkt" "cond.rkt"))
++ (#%require racket/private/stx racket/private/small-scheme "stxcase.rkt"
++ (for-syntax '#%kernel racket/private/stx "stxcase.rkt" "stxloc.rkt"
++ racket/private/gen-temp racket/private/sc racket/private/qq-and-or racket/private/cond))
+
+ (-define (with-syntax-fail stx)
+ (raise-syntax-error
+diff --git racket/collects/racket/syntax.rkt racket/collects/racket/syntax.rkt
+index ce0a72d1fc..428c195971 100644
+--- racket/collects/racket/syntax.rkt
++++ racket/collects/racket/syntax.rkt
+@@ -1,5 +1,6 @@
+ #lang racket/base
+-(require (for-syntax racket/base
++(require (only-in "stxloc.rkt" syntax-case)
++ (for-syntax racket/base
+ racket/private/sc))
+ (provide define/with-syntax
+
+diff --git racket/collects/syntax/parse.rkt racket/collects/syntax/parse.rkt
+index 6e81621a07..643de4ddda 100644
+--- racket/collects/syntax/parse.rkt
++++ racket/collects/syntax/parse.rkt
+@@ -24,7 +24,8 @@
+ [syntax-local-syntax-parse-pattern-introduce
+ (-> syntax? syntax?)]))
+
+- (define pattern-expander
++ (require (only-in (for-template syntax/parse) pattern-expander))
++ #;(define pattern-expander
+ (let ()
+ (struct pattern-expander (proc) #:transparent
+ #:omit-define-syntaxes
+diff --git racket/collects/syntax/parse/debug.rkt racket/collects/syntax/parse/debug.rkt
+index a092ab6263..c62849b212 100644
+--- racket/collects/syntax/parse/debug.rkt
++++ racket/collects/syntax/parse/debug.rkt
+@@ -2,20 +2,20 @@
+ (require (for-syntax racket/base
+ syntax/stx
+ racket/syntax
+- "private/rep-data.rkt"
++ syntax/parse/private/rep-data
+ "private/rep.rkt"
+- "private/kws.rkt")
++ syntax/parse/private/kws)
+ racket/list
+ racket/pretty
+ "../parse.rkt"
+- (except-in syntax/parse/private/residual
++ (except-in stxparse-info/parse/private/residual
+ prop:syntax-class
+ prop:pattern-expander
+ syntax-local-syntax-parse-pattern-introduce)
+ "private/runtime.rkt"
+ "private/runtime-progress.rkt"
+ "private/runtime-report.rkt"
+- "private/kws.rkt")
++ syntax/parse/private/kws)
+
+ ;; No lazy loading for this module's dependencies.
+
+diff --git racket/collects/syntax/parse/define.rkt racket/collects/syntax/parse/define.rkt
+index 80af669b22..6392c75adb 100644
+--- racket/collects/syntax/parse/define.rkt
++++ racket/collects/syntax/parse/define.rkt
+@@ -1,10 +1,10 @@
+ #lang racket/base
+ (require (for-syntax racket/base
+- syntax/parse
++ stxparse-info/parse
+ "private/sc.rkt"))
+ (provide define-simple-macro
+ define-syntax-parser
+- (for-syntax (all-from-out syntax/parse)))
++ (for-syntax (all-from-out stxparse-info/parse)))
+
+ (define-syntax (define-simple-macro stx)
+ (syntax-parse stx
+diff --git racket/collects/syntax/parse/experimental/contract.rkt racket/collects/syntax/parse/experimental/contract.rkt
+index 022e590958..b0f932b3ff 100644
+--- racket/collects/syntax/parse/experimental/contract.rkt
++++ racket/collects/syntax/parse/experimental/contract.rkt
+@@ -1,8 +1,8 @@
+ #lang racket/base
+-(require syntax/parse/pre
++(require stxparse-info/parse/pre
+ "provide.rkt"
+ syntax/contract
+- (only-in syntax/parse/private/residual ;; keep abs. path
++ (only-in stxparse-info/parse/private/residual ;; keep abs. path
+ this-context-syntax
+ this-role)
+ racket/contract/base)
+diff --git racket/collects/syntax/parse/experimental/eh.rkt racket/collects/syntax/parse/experimental/eh.rkt
+index 305080721f..f8e1b09302 100644
+--- racket/collects/syntax/parse/experimental/eh.rkt
++++ racket/collects/syntax/parse/experimental/eh.rkt
+@@ -1,5 +1,5 @@
+ #lang racket/base
+ (require "../private/sc.rkt"
+- "../private/keywords.rkt")
++ syntax/parse/private/keywords)
+ (provide ~eh-var
+ define-eh-alternative-set)
+diff --git racket/collects/syntax/parse/experimental/private/substitute.rkt racket/collects/syntax/parse/experimental/private/substitute.rkt
+new file mode 100644
+index 0000000000..7bc35af1c4
+--- /dev/null
++++ racket/collects/syntax/parse/experimental/private/substitute.rkt
+@@ -0,0 +1 @@
++#lang racket/base
+diff --git racket/collects/syntax/parse/experimental/provide.rkt racket/collects/syntax/parse/experimental/provide.rkt
+index 86a3b6fd88..173d81e428 100644
+--- racket/collects/syntax/parse/experimental/provide.rkt
++++ racket/collects/syntax/parse/experimental/provide.rkt
+@@ -4,10 +4,10 @@
+ syntax/location
+ (for-syntax racket/base
+ racket/syntax
+- "../private/minimatch.rkt"
+- syntax/parse/pre
++ syntax/parse/private/minimatch
++ stxparse-info/parse/pre
+ syntax/parse/private/residual-ct ;; keep abs. path
+- "../private/kws.rkt"
++ syntax/parse/private/kws
+ syntax/contract))
+ (provide provide-syntax-class/contract
+ syntax-class/c
+diff --git racket/collects/syntax/parse/experimental/reflect.rkt racket/collects/syntax/parse/experimental/reflect.rkt
+index 7e4daa3e5a..8f18781e9a 100644
+--- racket/collects/syntax/parse/experimental/reflect.rkt
++++ racket/collects/syntax/parse/experimental/reflect.rkt
+@@ -5,10 +5,10 @@
+ syntax/parse/private/residual-ct) ;; keep abs.path
+ racket/contract/base
+ racket/contract/combinator
+- "../private/minimatch.rkt"
+- "../private/keywords.rkt"
++ syntax/parse/private/minimatch
++ syntax/parse/private/keywords
+ "../private/runtime-reflect.rkt"
+- "../private/kws.rkt")
++ syntax/parse/private/kws)
+ (begin-for-syntax
+ (lazy-require
+ [syntax/parse/private/rep-data ;; keep abs. path
+diff --git racket/collects/syntax/parse/experimental/specialize.rkt racket/collects/syntax/parse/experimental/specialize.rkt
+index e32b077825..ad569c1cb0 100644
+--- racket/collects/syntax/parse/experimental/specialize.rkt
++++ racket/collects/syntax/parse/experimental/specialize.rkt
+@@ -1,8 +1,8 @@
+ #lang racket/base
+ (require (for-syntax racket/base
+ racket/syntax
+- "../private/kws.rkt"
+- "../private/rep-data.rkt"
++ syntax/parse/private/kws
++ syntax/parse/private/rep-data
+ "../private/rep.rkt")
+ "../private/runtime.rkt")
+ (provide define-syntax-class/specialize)
+diff --git racket/collects/syntax/parse/experimental/splicing.rkt racket/collects/syntax/parse/experimental/splicing.rkt
+index 510b2a7361..56abbd5cd2 100644
+--- racket/collects/syntax/parse/experimental/splicing.rkt
++++ racket/collects/syntax/parse/experimental/splicing.rkt
+@@ -1,9 +1,9 @@
+ #lang racket/base
+ (require (for-syntax racket/base
+- syntax/parse
++ stxparse-info/parse
+ racket/lazy-require
+- "../private/kws.rkt")
+- syntax/parse/private/residual) ;; keep abs. path
++ syntax/parse/private/kws)
++ stxparse-info/parse/private/residual) ;; keep abs. path
+ (provide define-primitive-splicing-syntax-class)
+
+ (begin-for-syntax
+diff --git racket/collects/syntax/parse/private/lib.rkt racket/collects/syntax/parse/private/lib.rkt
+index 5eaa74c946..01e110c45b 100644
+--- racket/collects/syntax/parse/private/lib.rkt
++++ racket/collects/syntax/parse/private/lib.rkt
+@@ -1,6 +1,6 @@
+ #lang racket/base
+ (require "sc.rkt"
+- "keywords.rkt"
++ syntax/parse/private/keywords
+ (only-in "residual.rkt" state-cons!)
+ (for-syntax syntax/parse/private/residual-ct)
+ (for-syntax racket/base))
+diff --git racket/collects/syntax/parse/private/litconv.rkt racket/collects/syntax/parse/private/litconv.rkt
+index 772930c301..9e25611d96 100644
+--- racket/collects/syntax/parse/private/litconv.rkt
++++ racket/collects/syntax/parse/private/litconv.rkt
+@@ -3,14 +3,14 @@
+ racket/lazy-require
+ "sc.rkt"
+ "lib.rkt"
+- "kws.rkt"
++ syntax/parse/private/kws
+ racket/syntax)
+ syntax/parse/private/residual-ct ;; keep abs. path
+- syntax/parse/private/residual) ;; 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)]
+- [syntax/parse/private/rep ;; keep abs. path
++ [stxparse-info/parse/private/rep ;; keep abs. path
+ (parse-kw-formals
+ check-conventions-rules
+ check-datum-literals-list
+@@ -18,7 +18,7 @@
+ ;; 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_ 'syntax/parse/private/rep)
++(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
+
+ (provide define-conventions
+ define-literal-set
+@@ -215,7 +215,7 @@ change between when define-literal-set is compiled and the comparison
+ involving L. For example:
+
+ (module M racket
+- (require syntax/parse)
++ (require stxparse-info/parse)
+ (define-literal-set LS (lambda))
+ (require (only-in some-other-lang lambda))
+ .... LS ....)
+diff --git racket/collects/syntax/parse/private/opt.rkt racket/collects/syntax/parse/private/opt.rkt
+index 0e7af8e5a8..12714d6be1 100644
+--- racket/collects/syntax/parse/private/opt.rkt
++++ racket/collects/syntax/parse/private/opt.rkt
+@@ -2,9 +2,9 @@
+ (require racket/syntax
+ racket/pretty
+ syntax/parse/private/residual-ct ;; keep abs. path
+- "minimatch.rkt"
+- "rep-patterns.rkt"
+- "kws.rkt")
++ syntax/parse/private/minimatch
++ syntax/parse/private/rep-patterns
++ syntax/parse/private/kws)
+ (provide (struct-out pk1)
+ (rename-out [optimize-matrix0 optimize-matrix]))
+
+diff --git racket/collects/syntax/parse/private/parse.rkt racket/collects/syntax/parse/private/parse.rkt
+index 609d0a48b4..e14cc3aea9 100644
+--- racket/collects/syntax/parse/private/parse.rkt
++++ racket/collects/syntax/parse/private/parse.rkt
+@@ -4,22 +4,22 @@
+ syntax/private/id-table
+ syntax/keyword
+ racket/syntax
+- "minimatch.rkt"
+- "datum-to-expr.rkt"
+- "rep-attrs.rkt"
+- "rep-data.rkt"
+- "rep-patterns.rkt"
++ syntax/parse/private/minimatch
++ syntax/parse/private/datum-to-expr
++ syntax/parse/private/rep-attrs
++ syntax/parse/private/rep-data
++ syntax/parse/private/rep-patterns
+ "rep.rkt"
+- "kws.rkt"
++ syntax/parse/private/kws
+ "opt.rkt"
+ "txlift.rkt")
+- "keywords.rkt"
++ syntax/parse/private/keywords
+ racket/syntax
+ racket/stxparam
+ syntax/stx
+- syntax/parse/private/residual ;; keep abs. path
++ stxparse-info/parse/private/residual ;; keep abs. path
+ "runtime.rkt"
+- syntax/parse/private/runtime-reflect) ;; keep abs. path
++ stxparse-info/parse/private/runtime-reflect) ;; keep abs. path
+
+ ;; ============================================================
+
+diff --git racket/collects/syntax/parse/private/rep.rkt racket/collects/syntax/parse/private/rep.rkt
+index 1264a0398f..be08bc36c1 100644
+--- racket/collects/syntax/parse/private/rep.rkt
++++ racket/collects/syntax/parse/private/rep.rkt
+@@ -1,12 +1,12 @@
+ #lang racket/base
+ (require (for-template racket/base
+ syntax/parse/private/keywords
+- syntax/parse/private/residual ;; keep abs. path
+- syntax/parse/private/runtime)
++ stxparse-info/parse/private/residual ;; keep abs. path
++ stxparse-info/parse/private/runtime)
+ racket/list
+ racket/contract/base
+ "make.rkt"
+- "minimatch.rkt"
++ syntax/parse/private/minimatch
+ syntax/apply-transformer
+ syntax/private/id-table
+ syntax/stx
+@@ -14,11 +14,11 @@
+ racket/syntax
+ racket/struct
+ "txlift.rkt"
+- "rep-attrs.rkt"
+- "rep-data.rkt"
+- "rep-patterns.rkt"
++ syntax/parse/private/rep-attrs
++ syntax/parse/private/rep-data
++ syntax/parse/private/rep-patterns
+ syntax/parse/private/residual-ct ;; keep abs. path
+- "kws.rkt")
++ syntax/parse/private/kws)
+
+ ;; Error reporting
+ ;; All entry points should have explicit, mandatory #:context arg
+diff --git racket/collects/syntax/parse/private/residual.rkt racket/collects/syntax/parse/private/residual.rkt
+index 3f9416c950..528885697b 100644
+--- racket/collects/syntax/parse/private/residual.rkt
++++ racket/collects/syntax/parse/private/residual.rkt
+@@ -7,10 +7,10 @@
+ ;; ============================================================
+ ;; Compile-time
+
+-(require (for-syntax racket/private/sc "residual-ct.rkt"))
+-(provide (for-syntax (all-from-out "residual-ct.rkt")))
++(require (for-syntax racket/private/sc syntax/parse/private/residual-ct))
++(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
+
+-(require racket/private/template)
++(require "../../case/template.rkt")
+ (provide (for-syntax attribute-mapping attribute-mapping?))
+
+ ;; ============================================================
+diff --git racket/collects/syntax/parse/private/runtime-progress.rkt racket/collects/syntax/parse/private/runtime-progress.rkt
+index 4065357c76..ad894d2c70 100644
+--- racket/collects/syntax/parse/private/runtime-progress.rkt
++++ racket/collects/syntax/parse/private/runtime-progress.rkt
+@@ -1,6 +1,6 @@
+ #lang racket/base
+ (require racket/list
+- "minimatch.rkt")
++ syntax/parse/private/minimatch)
+ (provide ps-empty
+ ps-add-car
+ ps-add-cdr
+diff --git racket/collects/syntax/parse/private/runtime-reflect.rkt racket/collects/syntax/parse/private/runtime-reflect.rkt
+index e3bc47a4c5..59125cf0ac 100644
+--- racket/collects/syntax/parse/private/runtime-reflect.rkt
++++ racket/collects/syntax/parse/private/runtime-reflect.rkt
+@@ -1,7 +1,7 @@
+ #lang racket/base
+ (require "residual.rkt"
+- (only-in "residual-ct.rkt" attr-name attr-depth)
+- "kws.rkt")
++ (only-in syntax/parse/private/residual-ct attr-name attr-depth)
++ syntax/parse/private/kws)
+ (provide reflect-parser
+ (struct-out reified)
+ (struct-out reified-syntax-class)
+@@ -11,10 +11,28 @@
+ A Reified is
+ (reified symbol ParserFunction nat (listof (list symbol nat)))
+ |#
+-(define-struct reified-base (name) #:transparent)
+-(define-struct (reified reified-base) (parser arity signature))
+-(define-struct (reified-syntax-class reified) ())
+-(define-struct (reified-splicing-syntax-class reified) ())
++(require (only-in syntax/parse/private/runtime-reflect
++ reified
++ reified?
++ reified-parser
++ reified-arity
++ reified-signature
++ make-reified
++ struct:reified
++
++ reified-syntax-class
++ reified-syntax-class?
++ make-reified-syntax-class
++ struct:reified-syntax-class
++
++ reified-splicing-syntax-class
++ reified-splicing-syntax-class?
++ make-reified-splicing-syntax-class
++ struct:reified-splicing-syntax-class))
++#;(define-struct reified-base (name) #:transparent)
++#;(define-struct (reified reified-base) (parser arity signature))
++#;(define-struct (reified-syntax-class reified) ())
++#;(define-struct (reified-splicing-syntax-class reified) ())
+
+ (define (reflect-parser obj e-arity e-attrs splicing?)
+ ;; e-arity represents single call; min and max are same
+diff --git racket/collects/syntax/parse/private/runtime-report.rkt racket/collects/syntax/parse/private/runtime-report.rkt
+index 59733c4cd2..a1d09e11ad 100644
+--- racket/collects/syntax/parse/private/runtime-report.rkt
++++ racket/collects/syntax/parse/private/runtime-report.rkt
+@@ -4,9 +4,9 @@
+ syntax/stx
+ racket/struct
+ syntax/srcloc
+- "minimatch.rkt"
+- syntax/parse/private/residual
+- "kws.rkt")
++ syntax/parse/private/minimatch
++ stxparse-info/parse/private/residual
++ syntax/parse/private/kws)
+ (provide call-current-failure-handler
+ current-failure-handler
+ invert-failure
+diff --git racket/collects/syntax/parse/private/runtime.rkt racket/collects/syntax/parse/private/runtime.rkt
+index d100d2c564..41b321499e 100644
+--- racket/collects/syntax/parse/private/runtime.rkt
++++ racket/collects/syntax/parse/private/runtime.rkt
+@@ -1,13 +1,13 @@
+ #lang racket/base
+ (require racket/stxparam
+- syntax/parse/private/residual ;; keep abs. path
++ stxparse-info/parse/private/residual ;; keep abs. path
+ (for-syntax racket/base
+ racket/list
+ syntax/kerncase
+ syntax/strip-context
+ racket/private/sc
+ racket/syntax
+- "rep-data.rkt"))
++ syntax/parse/private/rep-data))
+
+ (provide with
+ fail-handler
+diff --git racket/collects/syntax/parse/private/sc.rkt racket/collects/syntax/parse/private/sc.rkt
+index 27b069059d..d4e5ff695a 100644
+--- racket/collects/syntax/parse/private/sc.rkt
++++ racket/collects/syntax/parse/private/sc.rkt
+@@ -1,6 +1,6 @@
+ #lang racket/base
+ (require racket/lazy-require
+- "keywords.rkt"
++ syntax/parse/private/keywords
+ "residual.rkt")
+
+ (lazy-require-syntax
+@@ -21,7 +21,7 @@
+ syntax-parser
+ define/syntax-parse
+
+- (except-out (all-from-out "keywords.rkt")
++ (except-out (all-from-out syntax/parse/private/keywords)
+ ~reflect
+ ~splicing-reflect
+ ~eh-var)
+--
+2.30.0
+
diff --git a/7-4/0002-auto-syntax-e-and-template-metafunction-stuff.patch b/7-4/0002-auto-syntax-e-and-template-metafunction-stuff.patch
new file mode 100644
index 0000000..2c33d5f
--- /dev/null
+++ b/7-4/0002-auto-syntax-e-and-template-metafunction-stuff.patch
@@ -0,0 +1,197 @@
+From 544b1d8c15e32f5ce722d69d3f9ec51b73430b5a Mon Sep 17 00:00:00 2001
+From: Suzanne Soy <ligo@suzanne.soy>
+Date: Tue, 2 Mar 2021 21:20:46 +0000
+Subject: [PATCH 2/2] auto-syntax-e and template-metafunction stuff
+
+---
+ racket/collects/racket/private/stxcase.rkt | 14 ++++++++++----
+ racket/collects/racket/syntax.rkt | 9 ++++++---
+ .../syntax/parse/experimental/template.rkt | 17 +++++++++++++++--
+ racket/collects/syntax/parse/private/parse.rkt | 7 ++++++-
+ .../collects/syntax/parse/private/residual.rkt | 4 +++-
+ .../collects/syntax/parse/private/runtime.rkt | 12 ++++++++----
+ 6 files changed, 48 insertions(+), 15 deletions(-)
+
+diff --git racket/collects/racket/private/stxcase.rkt racket/collects/racket/private/stxcase.rkt
+index ca8f8f631b..cded343601 100644
+--- racket/collects/racket/private/stxcase.rkt
++++ racket/collects/racket/private/stxcase.rkt
+@@ -4,8 +4,10 @@
+ (module stxcase '#%kernel
+ (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
+ racket/private/ellipses
++ stxparse-info/current-pvars
+ (for-syntax racket/private/stx racket/private/small-scheme
+- racket/private/gen-temp racket/private/member racket/private/sc '#%kernel))
++ racket/private/gen-temp racket/private/member racket/private/sc '#%kernel
++ auto-syntax-e/utils))
+
+ (-define interp-match
+ (lambda (pat e literals immediate=?)
+@@ -346,7 +348,7 @@
+ (list
+ (if s-exp?
+ (quote-syntax make-s-exp-mapping)
+- (quote-syntax make-syntax-mapping))
++ (quote-syntax make-auto-pvar))
+ ;; Tell it the shape of the variable:
+ (let loop ([var unflat-pattern-var][d 0])
+ (if (syntax? var)
+@@ -361,9 +363,13 @@
+ null
+ (if fender
+ (list (quote-syntax if) fender
+- answer
++ (list (quote-syntax with-pvars)
++ pattern-vars
++ answer)
+ do-try-next)
+- answer)))
++ (list (quote-syntax with-pvars)
++ pattern-vars
++ answer))))
+ do-try-next))])
+ (if fender
+ (list
+diff --git racket/collects/racket/syntax.rkt racket/collects/racket/syntax.rkt
+index 428c195971..85c41d155f 100644
+--- racket/collects/racket/syntax.rkt
++++ racket/collects/racket/syntax.rkt
+@@ -1,7 +1,9 @@
+ #lang racket/base
+ (require (only-in "stxloc.rkt" syntax-case)
++ stxparse-info/current-pvars
+ (for-syntax racket/base
+- racket/private/sc))
++ racket/private/sc
++ auto-syntax-e/utils))
+ (provide define/with-syntax
+
+ current-recorded-disappeared-uses
+@@ -44,8 +46,9 @@
+ (with-syntax ([pattern rhs])
+ (values (pvar-value pvar) ...)))
+ (define-syntax pvar
+- (make-syntax-mapping 'depth (quote-syntax valvar)))
+- ...)))]))
++ (make-auto-pvar 'depth (quote-syntax valvar)))
++ ...
++ (define-pvars pvar ...))))]))
+ ;; Ryan: alternative name: define/syntax-pattern ??
+
+ ;; auxiliary macro
+diff --git racket/collects/syntax/parse/experimental/template.rkt racket/collects/syntax/parse/experimental/template.rkt
+index b52fd80e6e..160eccc84b 100644
+--- racket/collects/syntax/parse/experimental/template.rkt
++++ racket/collects/syntax/parse/experimental/template.rkt
+@@ -1,5 +1,6 @@
+ #lang racket/base
+-(require (for-syntax racket/base)
++(require (for-syntax racket/base
++ auto-syntax-e/utils)
+ (only-in racket/private/template
+ metafunction))
+ (provide (rename-out [syntax template]
+@@ -26,10 +27,22 @@
+ (define current-template-metafunction-introducer
+ (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
+
++(define old-template-metafunction-introducer
++ (make-parameter #f))
++
++(define (syntax-local-template-metafunction-introduce stx)
++ (let ([mark (current-template-metafunction-introducer)]
++ [old-mark (old-template-metafunction-introducer)])
++ (unless old-mark
++ (error 'syntax-local-template-metafunction-introduce
++ "must be called within the dynamic extent of a template metafunction"))
++ (mark (old-mark stx))))
++
+ (define ((make-hygienic-metafunction transformer) stx)
+ (define mark (make-syntax-introducer))
+ (define old-mark (current-template-metafunction-introducer))
+- (parameterize ((current-template-metafunction-introducer mark))
++ (parameterize ((current-template-metafunction-introducer mark)
++ (old-template-metafunction-introducer old-mark))
+ (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
+ (unless (syntax? r)
+ (raise-syntax-error #f "result of template metafunction was not syntax" stx))
+diff --git racket/collects/syntax/parse/private/parse.rkt racket/collects/syntax/parse/private/parse.rkt
+index e14cc3aea9..7e5c61dee1 100644
+--- racket/collects/syntax/parse/private/parse.rkt
++++ racket/collects/syntax/parse/private/parse.rkt
+@@ -435,7 +435,12 @@ Conventions:
+ ((body-sequence)
+ (syntax-case rest ()
+ [(e0 e ...)
+- #'(let () e0 e ...)]
++ ;; Should we use a shadower (works on the whole file, unhygienically),
++ ;; or use the context of the syntax-parse identifier?
++ (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)])
++ (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro
++ #`(let () (#,the-#%intdef-begin e0 e ...))
++ #'(let () e0 e ...)))]
+ [_ (raise-syntax-error #f "expected non-empty clause body"
+ #'ctx clause)]))
+ (else
+diff --git racket/collects/syntax/parse/private/residual.rkt racket/collects/syntax/parse/private/residual.rkt
+index 528885697b..1624b6394a 100644
+--- racket/collects/syntax/parse/private/residual.rkt
++++ racket/collects/syntax/parse/private/residual.rkt
+@@ -18,7 +18,9 @@
+
+ (require "runtime-progress.rkt"
+ "3d-stx.rkt"
+- syntax/stx)
++ auto-syntax-e
++ syntax/stx
++ stxparse-info/current-pvars)
+
+ (provide (all-from-out "runtime-progress.rkt")
+
+diff --git racket/collects/syntax/parse/private/runtime.rkt racket/collects/syntax/parse/private/runtime.rkt
+index 41b321499e..90d7ea88f4 100644
+--- racket/collects/syntax/parse/private/runtime.rkt
++++ racket/collects/syntax/parse/private/runtime.rkt
+@@ -1,11 +1,13 @@
+ #lang racket/base
+ (require racket/stxparam
+ stxparse-info/parse/private/residual ;; keep abs. path
++ stxparse-info/current-pvars
+ (for-syntax racket/base
+ racket/list
+ syntax/kerncase
+ syntax/strip-context
+ racket/private/sc
++ auto-syntax-e/utils
+ racket/syntax
+ syntax/parse/private/rep-data))
+
+@@ -111,9 +113,10 @@ residual.rkt.
+ ...)
+ ([(vtmp) value] ...)
+ (letrec-syntaxes+values
+- ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
++ ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...)
+ ()
+- . body))))]))
++ (with-pvars (name ...)
++ . body)))))]))
+
+ ;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
+ ;; Special case: empty attrs need not match number of value exprs.
+@@ -147,8 +150,9 @@ residual.rkt.
+ (attribute-mapping (quote-syntax vtmp) 'name 'depth
+ (if 'syntax? #f (quote-syntax check-attr-value))))
+ ...
+- (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
+- ...)))]))
++ (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp)))
++ ...
++ (define-pvars name ...))))]))
+
+ (define-syntax-rule (phase-of-enclosing-module)
+ (variable-reference->module-base-phase
+--
+2.30.0
+
diff --git a/7-4/base_commit.txt b/7-4/base_commit.txt
new file mode 100644
index 0000000..91d7ffb
--- /dev/null
+++ b/7-4/base_commit.txt
@@ -0,0 +1 @@
+cc06a5e2523ae3049b69d15cd2548eed5a887100
diff --git a/7-4/racket/collects/racket/private/stxcase-scheme.rkt b/7-4/racket/collects/racket/private/stxcase-scheme.rkt
new file mode 100644
index 0000000..46bddba
--- /dev/null
+++ b/7-4/racket/collects/racket/private/stxcase-scheme.rkt
@@ -0,0 +1,75 @@
+
+;;----------------------------------------------------------------------
+;; #%stxcase-scheme: adds let-syntax, syntax-rules, and
+;; check-duplicate-identifier, and assembles everything we have so far
+
+(module stxcase-scheme '#%kernel
+ (#%require racket/private/small-scheme racket/private/stx "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
+ (for-syntax '#%kernel racket/private/small-scheme racket/private/stx "stxcase.rkt"
+ "stxloc.rkt"))
+
+ (-define (check-duplicate-identifier names)
+ (unless (and (list? names) (andmap identifier? names))
+ (raise-argument-error 'check-duplicate-identifier "(listof identifier?)" names))
+ (let/ec escape
+ (let ([ht (make-hasheq)])
+ (for-each
+ (lambda (defined-name)
+ (unless (identifier? defined-name)
+ (raise-argument-error 'check-duplicate-identifier
+ "(listof identifier?)" names))
+ (let ([l (hash-ref ht (syntax-e defined-name) null)])
+ (when (ormap (lambda (i) (bound-identifier=? i defined-name)) l)
+ (escape defined-name))
+ (hash-set! ht (syntax-e defined-name) (cons defined-name l))))
+ names)
+ #f)))
+
+ (begin-for-syntax
+ (define-values (check-sr-rules)
+ (lambda (stx kws)
+ (for-each (lambda (id)
+ (unless (identifier? id)
+ (raise-syntax-error
+ #f
+ "pattern must start with an identifier, found something else"
+ stx
+ id)))
+ (syntax->list kws)))))
+
+ ;; From Dybvig, mostly:
+ (-define-syntax syntax-rules
+ (lambda (stx)
+ (syntax-case** syntax-rules #t stx () free-identifier=? #f
+ ((sr (k ...) ((keyword . pattern) template) ...)
+ (andmap identifier? (syntax->list (syntax (k ...))))
+ (begin
+ (check-sr-rules stx (syntax (keyword ...)))
+ (syntax/loc stx
+ (lambda (x)
+ (syntax-case** sr #t x (k ...) free-identifier=? #f
+ ((_ . pattern) (syntax-protect (syntax/loc x template)))
+ ...))))))))
+
+ (-define-syntax syntax-id-rules
+ (lambda (x)
+ (syntax-case** syntax-id-rules #t x () free-identifier=? #f
+ ((sidr (k ...) (pattern template) ...)
+ (andmap identifier? (syntax->list (syntax (k ...))))
+ (syntax/loc x
+ (make-set!-transformer
+ (lambda (x)
+ (syntax-case** sidr #t x (k ...) free-identifier=? #f
+ (pattern (syntax-protect (syntax/loc x template)))
+ ...))))))))
+
+ (-define (syntax-protect stx)
+ (if (syntax? stx)
+ (syntax-arm stx #f #t)
+ (raise-argument-error 'syntax-protect "syntax?" stx)))
+
+ (#%provide syntax datum (all-from "with-stx.rkt")
+ (all-from "stxloc.rkt")
+ check-duplicate-identifier syntax-protect
+ syntax-rules syntax-id-rules
+ (for-syntax syntax-pattern-variable?)))
diff --git a/7-4/racket/collects/racket/private/stxcase.rkt b/7-4/racket/collects/racket/private/stxcase.rkt
new file mode 100644
index 0000000..cded343
--- /dev/null
+++ b/7-4/racket/collects/racket/private/stxcase.rkt
@@ -0,0 +1,390 @@
+;;----------------------------------------------------------------------
+;; syntax-case and syntax
+
+(module stxcase '#%kernel
+ (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
+ racket/private/ellipses
+ stxparse-info/current-pvars
+ (for-syntax racket/private/stx racket/private/small-scheme
+ racket/private/gen-temp racket/private/member racket/private/sc '#%kernel
+ auto-syntax-e/utils))
+
+ (-define interp-match
+ (lambda (pat e literals immediate=?)
+ (interp-gen-match pat e literals immediate=? #f)))
+
+ (-define interp-s-match
+ (lambda (pat e literals immediate=?)
+ (interp-gen-match pat e literals immediate=? #t)))
+
+ (-define interp-gen-match
+ (lambda (pat e literals immediate=? s-exp?)
+ (let loop ([pat pat][e e][cap e])
+ (cond
+ [(null? pat)
+ (if s-exp?
+ (null? e)
+ (stx-null? e))]
+ [(number? pat)
+ (and (if s-exp? (symbol? e) (identifier? e))
+ (immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))]
+ [(not pat)
+ #t]
+ [else
+ (let ([i (vector-ref pat 0)])
+ (cond
+ [(eq? i 'bind)
+ (let ([e (if s-exp?
+ e
+ (if (vector-ref pat 2)
+ (datum->syntax cap e cap)
+ e))])
+ (if (vector-ref pat 1)
+ e
+ (list e)))]
+ [(eq? i 'pair)
+ (let ([match-head (vector-ref pat 1)]
+ [match-tail (vector-ref pat 2)]
+ [mh-did-var? (vector-ref pat 3)]
+ [mt-did-var? (vector-ref pat 4)])
+ (let ([cap (if (syntax? e) e cap)])
+ (and (stx-pair? e)
+ (let ([h (loop match-head (stx-car e) cap)])
+ (and h
+ (let ([t (loop match-tail (stx-cdr e) cap)])
+ (and t
+ (if mh-did-var?
+ (if mt-did-var?
+ (append h t)
+ h)
+ t))))))))]
+ [(eq? i 'quote)
+ (if s-exp?
+ (and (equal? (vector-ref pat 1) e)
+ null)
+ (and (syntax? e)
+ (equal? (vector-ref pat 1) (syntax-e e))
+ null))]
+ [(eq? i 'ellipses)
+ (let ([match-head (vector-ref pat 1)]
+ [nest-cnt (vector-ref pat 2)]
+ [last? (vector-ref pat 3)])
+ (and (if s-exp?
+ (list? e)
+ (stx-list? e))
+ (if (zero? nest-cnt)
+ (andmap (lambda (e) (loop match-head e cap))
+ (if s-exp? e (stx->list e)))
+ (let/ec esc
+ (let ([l (map (lambda (e)
+ (let ([m (loop match-head e cap)])
+ (if m
+ m
+ (esc #f))))
+ (if s-exp? e (stx->list e)))])
+ (if (null? l)
+ (let loop ([cnt nest-cnt])
+ (cond
+ [(= 1 cnt) (if last? '() '(()))]
+ [else (cons '() (loop (sub1 cnt)))]))
+ ((if last? stx-rotate* stx-rotate) l)))))))]
+ [(eq? i 'mid-ellipses)
+ (let ([match-head (vector-ref pat 1)]
+ [match-tail (vector-ref pat 2)]
+ [tail-cnt (vector-ref pat 3)]
+ [prop? (vector-ref pat 4)]
+ [mh-did-var? (vector-ref pat 5)]
+ [mt-did-var? (vector-ref pat 6)])
+ (let-values ([(pre-items post-items ok?)
+ (split-stx-list e tail-cnt prop?)]
+ [(cap) (if (syntax? e) e cap)])
+ (and ok?
+ (let ([h (loop match-head pre-items cap)])
+ (and h
+ (let ([t (loop match-tail post-items cap)])
+ (and t
+ (if mt-did-var?
+ (if mh-did-var?
+ (append h t)
+ t)
+ h))))))))]
+ [(eq? i 'veclist)
+ (and (if s-exp?
+ (vector? e)
+ (stx-vector? e #f))
+ (loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))]
+ [(eq? i 'vector)
+ (and (if s-exp?
+ (and (vector? e) (= (vector-length e) (vector-ref pat 1)))
+ (stx-vector? e (vector-ref pat 1)))
+ (let vloop ([p (vector-ref pat 2)][pos 0])
+ (cond
+ [(null? p) null]
+ [else
+ (let ([clause (car p)])
+ (let ([match-elem (car clause)]
+ [elem-did-var? (cdr clause)])
+ (let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)])
+ (and m
+ (let ([body (vloop (cdr p) (add1 pos))])
+ (and body
+ (if elem-did-var?
+ (if (null? body)
+ m
+ (append m body))
+ body)))))))])))]
+ [(eq? i 'box)
+ (let ([match-content (vector-ref pat 1)])
+ (and (if s-exp?
+ (box? e)
+ (stx-box? e))
+ (loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))]
+ [(eq? i 'prefab)
+ (and (if s-exp?
+ (equal? (vector-ref pat 1) (prefab-struct-key e))
+ (stx-prefab? (vector-ref pat 1) e))
+ (loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))]
+ [else (error "yikes!" pat)]))]))))
+
+ (-define-syntax syntax-case**
+ (lambda (x)
+ (-define l (and (stx-list? x) (cdr (stx->list x))))
+ (unless (and (stx-list? x)
+ (> (length l) 3))
+ (raise-syntax-error
+ #f
+ "bad form"
+ x))
+ (let ([who (car l)]
+ [arg-is-stx? (cadr l)]
+ [expr (caddr l)]
+ [kws (cadddr l)]
+ [lit-comp (cadddr (cdr l))]
+ [s-exp? (syntax-e (cadddr (cddr l)))]
+ [clauses (cddddr (cddr l))])
+ (unless (stx-list? kws)
+ (raise-syntax-error
+ (syntax-e who)
+ "expected a parenthesized sequence of literal identifiers"
+ kws))
+ (for-each
+ (lambda (lit)
+ (unless (identifier? lit)
+ (raise-syntax-error
+ (syntax-e who)
+ "literal is not an identifier"
+ lit)))
+ (stx->list kws))
+ (for-each
+ (lambda (clause)
+ (unless (and (stx-list? clause)
+ (<= 2 (length (stx->list clause)) 3))
+ (raise-syntax-error
+ (syntax-e who)
+ "expected a clause containing a pattern, an optional guard expression, and an expression"
+ clause)))
+ clauses)
+ (let ([patterns (map stx-car clauses)]
+ [fenders (map (lambda (clause)
+ (and (stx-pair? (stx-cdr (stx-cdr clause)))
+ (stx-car (stx-cdr clause))))
+ clauses)]
+ [answers (map (lambda (clause)
+ (let ([r (stx-cdr (stx-cdr clause))])
+ (if (stx-pair? r)
+ (stx-car r)
+ (stx-car (stx-cdr clause)))))
+ clauses)])
+ (let* ([arg (quote-syntax arg)]
+ [rslt (quote-syntax rslt)]
+ [pattern-varss (map
+ (lambda (pattern)
+ (get-match-vars who pattern pattern (stx->list kws)))
+ (stx->list patterns))]
+ [lit-comp-is-mod? (and (identifier? lit-comp)
+ (free-identifier=?
+ lit-comp
+ (quote-syntax free-identifier=?)))])
+ (syntax-arm
+ (datum->syntax
+ (quote-syntax here)
+ (list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?))
+ expr
+ (list (quote-syntax datum->syntax)
+ (list
+ (quote-syntax quote-syntax)
+ (datum->syntax
+ expr
+ 'here))
+ expr))))
+ (let loop ([patterns patterns]
+ [fenders fenders]
+ [unflat-pattern-varss pattern-varss]
+ [answers answers])
+ (cond
+ [(null? patterns)
+ (list
+ (quote-syntax raise-syntax-error)
+ #f
+ "bad syntax"
+ arg)]
+ [else
+ (let ([rest (loop (cdr patterns) (cdr fenders)
+ (cdr unflat-pattern-varss) (cdr answers))])
+ (let ([pattern (car patterns)]
+ [fender (car fenders)]
+ [unflat-pattern-vars (car unflat-pattern-varss)]
+ [answer (car answers)])
+ (-define pattern-vars
+ (map (lambda (var)
+ (let loop ([var var])
+ (if (syntax? var)
+ var
+ (loop (car var)))))
+ unflat-pattern-vars))
+ (-define temp-vars
+ (map
+ (lambda (p) (gen-temp-id 'sc))
+ pattern-vars))
+ (-define tail-pattern-var (sub1 (length pattern-vars)))
+ ;; Here's the result expression for one match:
+ (let* ([do-try-next (if (car fenders)
+ (list (quote-syntax try-next))
+ rest)]
+ [mtch (make-match&env
+ who
+ pattern
+ pattern
+ (stx->list kws)
+ (not lit-comp-is-mod?)
+ s-exp?)]
+ [cant-fail? (if lit-comp-is-mod?
+ (equal? mtch '(lambda (e) e))
+ (equal? mtch '(lambda (e free-identifier=?) e)))]
+ ;; Avoid generating gigantic matching expressions.
+ ;; If it's too big, interpret at run time, instead
+ [interp? (and (not cant-fail?)
+ (zero?
+ (let sz ([mtch mtch][fuel 100])
+ (cond
+ [(zero? fuel) 0]
+ [(pair? mtch) (sz (cdr mtch)
+ (sz (car mtch)
+ fuel))]
+ [(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))]
+ [else (sub1 fuel)]))))]
+ [mtch (if interp?
+ (let ([interp-box (box null)])
+ (let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)])
+ (list 'lambda
+ '(e)
+ (list (if s-exp? 'interp-s-match 'interp-match)
+ (list 'quote pat)
+ 'e
+ (if (null? (unbox interp-box))
+ #f
+ (list (if s-exp? 'quote 'quote-syntax)
+ (list->vector (reverse (unbox interp-box)))))
+ lit-comp))))
+ mtch)]
+ [m
+ ;; Do match, bind result to rslt:
+ (list (quote-syntax let)
+ (list
+ (list rslt
+ (if cant-fail?
+ arg
+ (list* (datum->syntax
+ (quote-syntax here)
+ mtch
+ pattern)
+ arg
+ (if (or interp? lit-comp-is-mod?)
+ null
+ (list lit-comp))))))
+ ;; If match succeeded...
+ (list
+ (quote-syntax if)
+ (if cant-fail?
+ #t
+ rslt)
+ ;; Extract each name binding into a temp variable:
+ (list
+ (quote-syntax let)
+ (map (lambda (pattern-var temp-var)
+ (list
+ temp-var
+ (let ([pos (stx-memq-pos pattern-var pattern-vars)])
+ (let ([accessor (cond
+ [(= tail-pattern-var pos)
+ (cond
+ [(eq? pos 0) 'tail]
+ [(eq? pos 1) (quote-syntax unsafe-cdr)]
+ [else 'tail])]
+ [(eq? pos 0) (quote-syntax unsafe-car)]
+ [else #f])])
+ (cond
+ [(eq? accessor 'tail)
+ (if (zero? pos)
+ rslt
+ (list
+ (quote-syntax unsafe-list-tail)
+ rslt
+ pos))]
+ [accessor (list
+ accessor
+ rslt)]
+ [else (list
+ (quote-syntax unsafe-list-ref)
+ rslt
+ pos)])))))
+ pattern-vars temp-vars)
+ ;; Tell nested `syntax' forms about the
+ ;; pattern-bound variables:
+ (list
+ (quote-syntax letrec-syntaxes+values)
+ (map (lambda (pattern-var unflat-pattern-var temp-var)
+ (list (list pattern-var)
+ (list
+ (if s-exp?
+ (quote-syntax make-s-exp-mapping)
+ (quote-syntax make-auto-pvar))
+ ;; Tell it the shape of the variable:
+ (let loop ([var unflat-pattern-var][d 0])
+ (if (syntax? var)
+ d
+ (loop (car var) (add1 d))))
+ ;; Tell it the variable name:
+ (list
+ (quote-syntax quote-syntax)
+ temp-var))))
+ pattern-vars unflat-pattern-vars
+ temp-vars)
+ null
+ (if fender
+ (list (quote-syntax if) fender
+ (list (quote-syntax with-pvars)
+ pattern-vars
+ answer)
+ do-try-next)
+ (list (quote-syntax with-pvars)
+ pattern-vars
+ answer))))
+ do-try-next))])
+ (if fender
+ (list
+ (quote-syntax let)
+ ;; Bind try-next to try next case
+ (list (list (quote try-next)
+ (list (quote-syntax lambda)
+ (list)
+ rest)))
+ ;; Try one match
+ m)
+ ;; Match try already embed the rest case
+ m))))])))
+ x)))))))
+
+ (#%require racket/private/template)
+ (#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
+ (for-syntax syntax-pattern-variable?)))
diff --git a/7-4/racket/collects/racket/private/stxloc.rkt b/7-4/racket/collects/racket/private/stxloc.rkt
new file mode 100644
index 0000000..e26417c
--- /dev/null
+++ b/7-4/racket/collects/racket/private/stxloc.rkt
@@ -0,0 +1,59 @@
+
+;;----------------------------------------------------------------------
+;; syntax/loc
+
+(module stxloc '#%kernel
+ (#%require racket/private/qq-and-or "stxcase.rkt" racket/private/define-et-al
+ (for-syntax '#%kernel "stxcase.rkt" racket/private/sc))
+
+ (begin-for-syntax
+ (define-values (transform-to-syntax-case**)
+ (lambda (stx sc arg-is-stx? expr kws lit-comp s-exp? clauses)
+ ((λ (ans) (datum->syntax #'here ans stx))
+ (list* 'syntax-case** sc arg-is-stx? expr kws lit-comp s-exp?
+ clauses)))))
+
+ ;; Like regular syntax-case, but with free-identifier=? replacement
+ (-define-syntax syntax-case*
+ (lambda (stx)
+ (syntax-case** #f #t stx () free-identifier=? #f
+ [(sc stxe kl id=? . clause)
+ (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'id=? #f #'clause)])))
+
+ ;; Regular syntax-case
+ (-define-syntax syntax-case
+ (lambda (stx)
+ (syntax-case** #f #t stx () free-identifier=? #f
+ [(sc stxe kl . clause)
+ (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'free-identifier=? #f
+ #'clause)])))
+
+ ;; Like `syntax-case, but on plain datums
+ (-define-syntax datum-case
+ (lambda (stx)
+ (syntax-case** #f #t stx () free-identifier=? #f
+ [(sc stxe kl . clause)
+ (transform-to-syntax-case** stx #'sc #f #'stxe #'kl #'eq? #t #'clause)])))
+
+ (-define-syntax quote-syntax/prune
+ (lambda (stx)
+ (syntax-case** #f #t stx () free-identifier=? #f
+ [(_ id)
+ (if (symbol? (syntax-e #'id))
+ (datum->syntax #'here
+ (list (quote-syntax quote-syntax)
+ (identifier-prune-lexical-context (syntax id)
+ (list
+ (syntax-e (syntax id))
+ '#%top)))
+ stx
+ #f
+ stx)
+ (raise-syntax-error
+ #f
+ "expected an identifier"
+ stx
+ #'id))])))
+
+ (#%provide syntax/loc quote-syntax/prune syntax-case* syntax-case datum-case
+ ... _ ~? ~@))
diff --git a/7-4/racket/collects/racket/private/template.rkt b/7-4/racket/collects/racket/private/template.rkt
new file mode 100644
index 0000000..06dfba3
--- /dev/null
+++ b/7-4/racket/collects/racket/private/template.rkt
@@ -0,0 +1,705 @@
+(module template '#%kernel
+(#%require racket/private/stx racket/private/small-scheme racket/private/performance-hint
+ (rename racket/private/small-scheme define -define)
+ (rename racket/private/small-scheme define-syntax -define-syntax)
+ racket/private/ellipses
+ (for-syntax racket/private/stx racket/private/small-scheme
+ (rename racket/private/small-scheme define -define)
+ (rename racket/private/small-scheme define-syntax -define-syntax)
+ racket/private/member racket/private/sc '#%kernel))
+(#%provide syntax
+ syntax/loc
+ datum
+ ~? ~@
+ ~@! signal-absent-pvar
+ (for-syntax attribute-mapping
+ attribute-mapping?
+ attribute-mapping-name
+ attribute-mapping-var
+ attribute-mapping-depth
+ attribute-mapping-check
+ (protect metafunction
+ metafunction?)))
+
+;; ============================================================
+;; Syntax of templates
+
+;; A Template (T) is one of:
+;; - pattern-variable
+;; - constant (including () and non-pvar identifiers)
+;; - (metafunction . T)
+;; - (H . T)
+;; - (H ... . T), (H ... ... . T), etc
+;; - (... T) -- escapes inner ..., ~?, ~@
+;; - (~? T T)
+;; - #(T*) -- actually, vector->list interpreted as T
+;; - #s(prefab-struct-key T*) -- likewise
+
+;; A HeadTemplate (H) is one of:
+;; - T
+;; - (~? H)
+;; - (~? H H)
+;; - (~@ . T)
+
+(define-syntax ~@! #f) ;; private, escape-ignoring version of ~@, used by unsyntax-splicing
+
+;; ============================================================
+;; Compile-time
+
+;; Parse template syntax into a Guide (AST--the name is left over from
+;; when the "guide" was a data structure interpreted at run time).
+
+;; The AST representation is designed to coincide with the run-time
+;; support, so compilation is just (datum->syntax #'here guide). The
+;; variants listed below are the ones recognized and treated specially
+;; by other functions (eg optimize-resyntax, relocate-guide).
+
+;; A Guide (G) is one of:
+;; - (list 't-resyntax Expr Expr G)
+;; - (list 't-quote Datum) ;; constant, but not null
+;; - (list 't-quote-syntax Syntax)
+;; - (list 't-var Id) ;; trusted pattern variable
+;; - (list 't-list G ...)
+;; - (list 't-list* G ... G)
+;; - (list 't-append HG G)
+;; - (list 't-orelse G G)
+;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions
+;; -- where Subst = Nat ;; replace nth car with arg
+;; | 'tail Nat ;; replace nth cdr with arg
+;; | 'append Nat ;; replace nth car by appending arg
+;; | 'recur Nat ;; replace nth car by recurring on it with arg
+;; - other expression (must be pair!)
+
+;; A HeadGuide (HG) is one of:
+;; - (list 'h-t G)
+;; - other expression (must be pair!)
+
+(begin-for-syntax
+
+ (define here-stx (quote-syntax here))
+
+ (define template-logger (make-logger 'template (current-logger)))
+
+ ;; An Attribute is an identifier statically bound to a syntax-mapping
+ ;; (see sc.rkt) whose valvar is an identifier statically bound to an
+ ;; attribute-mapping.
+
+ ;; (struct attribute-mapping (var name depth check) ...)
+ ;; check : #f (trusted) or Id, ref to Checker
+ ;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) )
+ (#%require (for-template (only racket/private/template
+ attribute-mapping
+ attribute-mapping?
+ attribute-mapping-var
+ attribute-mapping-name
+ attribute-mapping-depth
+ attribute-mapping-check)))
+ #;(define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
+ attribute-mapping-ref _attribute-mapping-set!)
+ (make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector)
+ (lambda (self stx)
+ (if (attribute-mapping-check self)
+ (let ([source-name
+ (or (let loop ([p (syntax-property stx 'disappeared-use)])
+ (cond [(identifier? p) p]
+ [(pair? p) (or (loop (car p)) (loop (cdr p)))]
+ [else #f]))
+ (attribute-mapping-name self))])
+ (define code
+ `(,(attribute-mapping-check self)
+ ,(attribute-mapping-var self)
+ ,(attribute-mapping-depth self)
+ #t
+ (quote-syntax ,source-name)))
+ (datum->syntax here-stx code stx))
+ (attribute-mapping-var self)))))
+ #;(define (attribute-mapping-var a) (attribute-mapping-ref a 0))
+ #;(define (attribute-mapping-name a) (attribute-mapping-ref a 1))
+ #;(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
+ #;(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
+
+ ;; (struct metafunction (var))
+ (define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
+ (make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector)))
+ (define (metafunction-var mf) (metafunction-ref mf 0))
+
+ (define (guide-is? x tag) (and (pair? x) (eq? (car x) tag)))
+
+ (define (ht-guide? x) (guide-is? x 'h-t))
+ (define (ht-guide-t x) (cadr x))
+
+ (define (quote-guide? x) (guide-is? x 't-quote))
+ (define (quote-guide-v x) (cadr x))
+ (define (quote-syntax-guide? x) (guide-is? x 't-quote-syntax))
+ (define (quote-syntax-guide-v x) (cadr x))
+
+ (define (null-guide? x) (and (guide-is? x 't-list) (null? (cdr x))))
+
+ (define (datum-guide? x) (or (quote-guide? x) (null-guide? x)))
+ (define (datum-guide-v x) (if (null-guide? x) null (quote-guide-v x)))
+
+ (define (list-guide? x) (guide-is? x 't-list))
+ (define (list-guide-vs x) (cdr x))
+
+ (define (list*-guide? x) (guide-is? x 't-list*))
+ (define (list*-guide-vs x) (cdr x))
+
+ (define (struct-guide? x) (guide-is? x 't-struct))
+ (define (struct-guide-key x) (cadr (cadr x)))
+ (define (struct-guide-v x) (caddr x))
+
+ (define (vector-guide? x) (guide-is? x 't-vector))
+ (define (vector-guide-v x) (cadr x))
+
+ (define (box-guide? x) (guide-is? x 't-box))
+ (define (box-guide-v x) (cadr x))
+
+ (define (append-guide gh gt)
+ (cond [(ht-guide? gh) (cons-guide (ht-guide-t gh) gt)]
+ [(null-guide? gt) gh]
+ [else `(t-append ,gh ,gt)]))
+
+ (define (cons-guide g1 g2)
+ (cond [(and (datum-guide? g1) (datum-guide? g2))
+ `(t-quote ,(cons (datum-guide-v g1) (datum-guide-v g2)))]
+ [(list-guide? g2) (list* 't-list g1 (list-guide-vs g2))]
+ [(list*-guide? g2) (list* 't-list* g1 (list*-guide-vs g2))]
+ [else (list 't-list* g1 g2)]))
+
+ (define (const-stx-guide? x)
+ (cond [(quote-guide? x) #t]
+ [(quote-syntax-guide? x) #t]
+ [(list-guide? x) (andmap const-stx-guide? (list-guide-vs x))]
+ [(list*-guide? x) (andmap const-stx-guide? (list*-guide-vs x))]
+ [(struct-guide? x) (const-stx-guide? (struct-guide-v x))]
+ [(vector-guide? x) (const-stx-guide? (vector-guide-v x))]
+ [(box-guide? x) (const-stx-guide? (box-guide-v x))]
+ [else #f]))
+ (define (const-stx-guide-v x)
+ (cond [(quote-guide? x) (quote-guide-v x)]
+ [(quote-syntax-guide? x) (quote-syntax-guide-v x)]
+ [(list-guide? x) (map const-stx-guide-v (list-guide-vs x))]
+ [(list*-guide? x) (apply list* (map const-stx-guide-v (list*-guide-vs x)))]
+ [(struct-guide? x)
+ (apply make-prefab-struct (struct-guide-key x) (const-stx-guide-v (struct-guide-v x)))]
+ [(vector-guide? x) (list->vector (const-stx-guide-v (vector-guide-v x)))]
+ [(box-guide? x) (box (const-stx-guide-v (box-guide-v x)))]
+ [else (error 'const-stx-guide-v "bad guide: ~e" x)]))
+
+ (define (dots-guide hguide frame head at-stx)
+ (let ([cons? (ht-guide? hguide)]
+ [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]
+ [env (dotsframe-env frame)])
+ (cond [(and (guide-is? hguide 't-var) (= (length env) 1)
+ (eq? (cadr hguide) (caar env)))
+ ;; (x ...), where x is trusted
+ (cond [cons? `(t-var ,(cdar env))]
+ [else `(apply append (t-var ,(cdar env)))])]
+ [else
+ `(t-dots ,cons? ,hguide ,(map car env) ,(map cdr env)
+ (quote ,head) (quote-syntax ,at-stx))])))
+
+ ;; A Depth is (Listof MapFrame)
+
+ ;; A DotsFrame is (vector (Listof (cons Id Syntax)) (Hash Id => Id) Id Bool)
+ ;; Each ellipsis in a template has a corresponding DotsFrame of the form
+ ;; (vector env ht ellipsis-id any-vars?), where
+ ;; -- env is (list (cons iter-id src-list-expr) ...), where src-list-expr
+ ;; is a src-list-id either by itself or wrapped in a check
+ ;; -- ht maps a src-list-id to the corresponding iter-id
+ ;; -- ellipsis-id is the identifier for the ellipsis (for error reporting)
+ ;; -- any-vars? is a flag that indicates whether any pattern variables occur
+ ;; in this frame's subtemplate (for error reporting)
+ ;; When a pattern variable of depth D is found, it is added to the D current
+ ;; innermost (ie, topmost) dotsframes (see `lookup`).
+ (define (new-dotsframe ellipsis-stx)
+ (vector null (make-hasheq) ellipsis-stx #f))
+ (define (dotsframe-env frame) (vector-ref frame 0))
+ (define (dotsframe-ref frame src-id)
+ (hash-ref (vector-ref frame 1) src-id #f))
+ (define (dotsframe-add! frame iter-id src-id src-expr)
+ (vector-set! frame 0 (cons (cons iter-id src-expr) (vector-ref frame 0)))
+ (hash-set! (vector-ref frame 1) src-id iter-id))
+ (define (dotsframe-index-iter frame) (vector-ref frame 2))
+ (define (dotsframe-index-iter! frame)
+ (cond [(vector-ref frame 2) => (lambda (x) x)]
+ [else (let ([index-var (gentemp)])
+ (vector-set! frame 2 index-var)
+ index-var)]))
+ (define (dotsframe-ellipsis-id frame) (vector-ref frame 2))
+ (define (dotsframe-has-mapvars? frame) (pair? (vector-ref frame 0)))
+ (define (dotsframe-has-any-vars? frame) (vector-ref frame 3))
+
+ (define (frames-seen-pvar! frames)
+ (when (pair? frames)
+ (unless (vector-ref (car frames) 3)
+ (vector-set! (car frames) 3 #t)
+ (frames-seen-pvar! (cdr frames)))))
+
+ (define (ellipsis? x)
+ (and (identifier? x) (free-identifier=? x (quote-syntax ...))))
+
+ ;; ----------------------------------------
+ ;; Parsing templates
+
+ ;; parse-template : Syntax Syntax Boolean -> (values Guide (Listof Id))
+ (define (parse-template ctx t stx?)
+ ;; wrong-syntax : Syntax Format-String Any ... -> (error)
+ (define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x))
+
+ ;; disappeared-uses : (Listof Id)
+ (define disappeared-uses null)
+ ;; disappeared! : Id -> Void
+ (define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses)))
+
+ ;; parse-t : Stx Nat Boolean -> Guide
+ (define (parse-t t depth esc?)
+ (cond [(stx-pair? t)
+ (if (identifier? (stx-car t))
+ (parse-t-pair/command t depth esc?)
+ (parse-t-pair/dots t depth esc?))]
+ [else (parse-t-nonpair t depth esc?)]))
+
+ ;; parse-t-pair/command : Stx Nat Boolean -> ...
+ ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc)
+ (define (parse-t-pair/command t depth esc?)
+ (cond [esc?
+ (parse-t-pair/dots t depth esc?)]
+ [(parse-form t (quote-syntax ...) 1)
+ => (lambda (t)
+ (disappeared! (car t))
+ (parse-t (cadr t) depth #t))]
+ [(parse-form t (quote-syntax ~?) 2)
+ => (lambda (t)
+ (disappeared! (car t))
+ (define t1 (cadr t))
+ (define t2 (caddr t))
+ (define guide1 (parse-t t1 depth esc?))
+ (define guide2 (parse-t t2 depth esc?))
+ `(t-orelse ,guide1 ,guide2))]
+ [(lookup-metafun (stx-car t))
+ => (lambda (mf)
+ (unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
+ (disappeared! (stx-car t))
+ (define guide (parse-t (stx-cdr t) depth esc?))
+ `(t-metafun ,(metafunction-var mf) ,guide
+ (quote-syntax
+ ,(let ([tstx (and (syntax? t) t)])
+ (datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))]
+ [else (parse-t-pair/dots t depth esc?)]))
+
+ ;; parse-t-pair/dots : Stx Nat Boolean -> ...
+ ;; t is a stx pair; check for dots
+ (define (parse-t-pair/dots t depth esc?)
+ (define head (stx-car t))
+ (define-values (tail frames) ;; first-in-stx = innermost is first in list
+ (let loop ([tail (stx-cdr t)] [frames null])
+ (cond [(and (not esc?) (stx-pair? tail) (ellipsis? (stx-car tail)))
+ (disappeared! (stx-car tail))
+ (loop (stx-cdr tail) (cons (new-dotsframe (stx-car tail)) frames))]
+ [else (values tail (reverse frames))])))
+ (define at-stx (datum->syntax #f '... head))
+ (define hguide
+ (let loop ([frames frames] [hguide (parse-h head (append frames depth) esc?)])
+ (cond [(pair? frames)
+ (define frame (car frames))
+ (unless (dotsframe-has-mapvars? frame)
+ (unless (dotsframe-has-any-vars? frame)
+ (wrong-syntax head "no pattern variables before ellipsis in template"))
+ (wrong-syntax (dotsframe-ellipsis-id frame) "too many ellipses in template"))
+ (loop (cdr frames) (dots-guide hguide frame head at-stx))]
+ [else hguide])))
+ (define tguide (parse-t tail depth esc?))
+ (resyntax t (append-guide hguide tguide)))
+
+ ;; parse-t-nonpair : Syntax Nat Boolean -> ...
+ ;; PRE: t is not a stxpair
+ (define (parse-t-nonpair t depth esc?)
+ (define td (if (syntax? t) (syntax-e t) t))
+ (cond [(identifier? t)
+ (cond [(and (not esc?)
+ (or (free-identifier=? t (quote-syntax ...))
+ (free-identifier=? t (quote-syntax ~?))
+ (free-identifier=? t (quote-syntax ~@))))
+ (wrong-syntax t "illegal use")]
+ [(lookup-metafun t)
+ (wrong-syntax t "illegal use of syntax metafunction")]
+ [(lookup t depth) => (lambda (ref) ref)]
+ [else (const-guide t)])]
+ [(vector? td)
+ (define guide (parse-t (vector->list td) depth esc?))
+ (resyntax t `(t-vector ,guide))]
+ [(prefab-struct-key td)
+ => (lambda (key)
+ (define elems (cdr (vector->list (struct->vector td))))
+ (define guide (parse-t elems depth esc?))
+ (resyntax t `(t-struct (quote ,key) ,guide)))]
+ [(box? td)
+ (define guide (parse-t (unbox td) depth esc?))
+ (resyntax t `(t-box ,guide))]
+ [else (const-guide t)]))
+
+ ;; parse-h : Syntax Depth Boolean -> HeadGuide
+ (define (parse-h h depth esc?)
+ (cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
+ => (lambda (h)
+ (disappeared! (car h))
+ (define guide (parse-h (cadr h) depth esc?))
+ `(h-orelse ,guide null))]
+ [(and (not esc?) (parse-form h (quote-syntax ~?) 2))
+ => (lambda (h)
+ (disappeared! (car h))
+ (define guide1 (parse-h (cadr h) depth esc?))
+ (define guide2 (parse-h (caddr h) depth esc?))
+ (if (and (ht-guide? guide1) (ht-guide? guide2))
+ `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
+ `(h-orelse ,guide1 ,guide2)))]
+ [(and (stx-pair? h)
+ (let ([h-head (stx-car h)])
+ (and (identifier? h-head)
+ (or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?))
+ (free-identifier=? h-head (quote-syntax ~@!))))))
+ (disappeared! (stx-car h))
+ (define guide (parse-t (stx-cdr h) depth esc?))
+ `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h)))]
+ [else
+ (define guide (parse-t h depth esc?))
+ `(h-t ,guide)]))
+
+ ;; lookup : Identifier Depth -> Syntax/#f
+ ;; If pattern variable with depth>0, insert into depth innermost ellipsis envs.
+ (define (lookup id depth0)
+ (define (make-pvar var check pvar-depth)
+ (define (make-ref var)
+ (cond [check `(t-check-var (,check ,var 0 #t (quote-syntax ,id)))]
+ [else `(t-var ,var)]))
+ (define (make-src-ref var id)
+ (cond [check `(#%expression (,check ,var 1 #f (quote-syntax ,id)))]
+ [else var]))
+ (disappeared! id)
+ (frames-seen-pvar! depth0)
+ (make-ref
+ (let dloop ([depth depth0] [pvar-depth pvar-depth]) ;; ... -> Identifier
+ ;; Returns variable reference whose value has not been checked yet.
+ (cond [(zero? pvar-depth) var]
+ [(null? depth)
+ (if (null? depth0)
+ (wrong-syntax id "missing ellipsis with pattern variable in template")
+ (wrong-syntax id "too few ellipses for pattern variable in template"))]
+ [else
+ (define src (dloop (cdr depth) (sub1 pvar-depth)))
+ (or (dotsframe-ref (car depth) src)
+ (let ([iter (gentemp)])
+ (dotsframe-add! (car depth) iter src (make-src-ref src id))
+ iter))]))))
+ (let ([v (syntax-local-value id (lambda () #f))])
+ (cond [(and stx? (syntax-pattern-variable? v))
+ (define pvar-depth (syntax-mapping-depth v))
+ (define attr
+ (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
+ (and (attribute-mapping? attr) attr)))
+ (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
+ (define check (and attr (attribute-mapping-check attr)))
+ (make-pvar var check pvar-depth)]
+ [(and (not stx?) (s-exp-pattern-variable? v))
+ (define pvar-depth (s-exp-mapping-depth v))
+ (define var (s-exp-mapping-valvar v))
+ (make-pvar var #f pvar-depth)]
+ [else
+ ;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute
+ (for-each
+ (lambda (pfx)
+ (let ([pfx-v (syntax-local-value pfx (lambda () #f))])
+ (if (and (syntax-pattern-variable? pfx-v)
+ (let ([valvar (syntax-mapping-valvar pfx-v)])
+ (attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
+ (wrong-syntax id "undefined nested attribute of attribute `~a'"
+ (syntax-e pfx))
+ (void))))
+ (dotted-prefixes id))
+ #f])))
+
+ ;; resyntax : Stx Guide -> Guide
+ (define (resyntax t g)
+ (cond [(not (and stx? (syntax? t))) g]
+ [(const-stx-guide? g)
+ `(t-quote-syntax ,(datum->syntax t (const-stx-guide-v g) t t))]
+ [#t (optimize-resyntax t g)]
+ [else `(t-resyntax #f (quote-syntax ,(datum->syntax t 'STX t t)) ,g)]))
+
+ ;; optimize-resyntax : Syntax Guide -> Guide
+ (define (optimize-resyntax t0 g)
+ (define HOLE (datum->syntax #f '_))
+ (define (finish i rt rs re)
+ (values (sub1 i) (reverse rs) (reverse re)
+ (datum->syntax t0 (apply list* (reverse rt)) t0 t0)))
+ (define (loop-gs list*? gs i rt rs re)
+ (cond [(null? gs)
+ (finish i (cons null rt) rs re)]
+ [(and list*? (null? (cdr gs)))
+ (loop-g (car gs) i rt rs re)]
+ [else
+ (define g0 (car gs))
+ (cond [(quote-syntax-guide? g0)
+ (let ([const (quote-syntax-guide-v g0)])
+ (loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))]
+ [(eq? (car g0) 't-subst) ;; (t-subst LOC STX <substs>)
+ (let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _)
+ [subargs (list-tail g0 3)])
+ (loop-gs list*? (cdr gs) (add1 i) (cons subt rt)
+ (list* i 'recur rs) (cons `(list . ,subargs) re)))]
+ [else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt)
+ (cons i rs) (cons g0 re))])]))
+ (define (loop-g g i rt rs re)
+ (cond [(list-guide? g)
+ (loop-gs #f (list-guide-vs g) i rt rs re)]
+ [(list*-guide? g)
+ (loop-gs #t (list*-guide-vs g) i rt rs re)]
+ [(guide-is? g 't-append)
+ (loop-g (caddr g) (add1 i) (cons HOLE rt)
+ (list* i 'append rs) (cons (cadr g) re))]
+ [(eq? (car g) 't-quote-syntax)
+ (let ([const (quote-syntax-guide-v g)])
+ (finish i (cons const rt) rs re))]
+ [else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))]))
+ (define-values (npairs substs exprs t*) (loop-g g 0 null null null))
+ (cond [(and substs
+ ;; Tunable condition for choosing whether to create a t-subst.
+ ;; Avoid creating useless (t-subst loc stx '(tail 0) g).
+ (<= (length substs) (* 2 npairs)))
+ #;(log-message template-logger 'debug
+ (format "OPTIMIZED ~s" (syntax->datum t0)) #f)
+ `(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)]
+ [else
+ #;(log-message template-logger 'debug
+ (format "NOT opt ~s" (syntax->datum t0)) #f)
+ (let ([rep (datum->syntax t0 'STX t0 t0)])
+ `(t-resyntax #f (quote-syntax ,rep) ,g))]))
+
+ ;; const-guide : Any -> Guide
+ (define (const-guide x)
+ (cond [(and stx? (syntax? x)) `(t-quote-syntax ,x)]
+ [(null? x) `(t-list)]
+ [else `(t-quote , x)]))
+
+ (let ([guide (parse-t t null #f)])
+ (values guide disappeared-uses)))
+
+ ;; parse-form : Stx Id Nat -> (list[arity+1] Syntax)
+ (define (parse-form stx form-id arity)
+ (and (stx-pair? stx)
+ (let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)])
+ (and (identifier? stx-h) (free-identifier=? stx-h form-id)
+ (let ([stx-tl (stx->list stx-t)])
+ (and (list? stx-tl)
+ (= (length stx-tl) arity)
+ (cons stx-h stx-tl)))))))
+
+ ;; lookup-metafun : Identifier -> Metafunction/#f
+ (define (lookup-metafun id)
+ (define v (syntax-local-value id (lambda () #f)))
+ (and (metafunction? v) v))
+
+ (define (dotted-prefixes id)
+ (let* ([id-string (symbol->string (syntax-e id))]
+ [dot-locations
+ (let loop ([i 0])
+ (if (< i (string-length id-string))
+ (if (eqv? (string-ref id-string i) #\.)
+ (cons i (loop (add1 i)))
+ (loop (add1 i)))
+ null))])
+ (map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc))))
+ dot-locations)))
+
+ (define gentemp-counter 0)
+ (define (gentemp)
+ (set! gentemp-counter (add1 gentemp-counter))
+ ((make-syntax-introducer)
+ (datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter)))))
+
+ (define (stx-drop n x)
+ (if (zero? n) x (stx-drop (sub1 n) (stx-cdr x))))
+
+ ;; ----------------------------------------
+ ;; Relocating (eg, syntax/loc)
+
+ ;; Only relocate if relocation would affect a syntax pair originating
+ ;; from template structure. For example (x,y are pvars):
+ ;; (syntax/loc loc-stx (1 2 3)) => relocate
+ ;; (syntax/loc loc-stx y) => don't relocate
+ ;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x!
+ ;; Deciding whether to relocate after the fact is hard. But with explicit
+ ;; t-resyntax, it's much easier.
+
+ ;; relocate-guide : Syntax Guide Id -> Guide
+ (define (relocate-guide ctx g0 loc-id)
+ (define (loop g)
+ (define gtag (car g))
+ (cond [(guide-is? g 't-resyntax)
+ `(t-resyntax ,loc-id . ,(cddr g))]
+ [(quote-syntax-guide? g)
+ `(t-relocate ,g ,loc-id)]
+ [(guide-is? g 't-subst)
+ `(t-subst ,loc-id . ,(cddr g))]
+ ;; ----
+ [(guide-is? g 't-orelse)
+ `(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))]
+ ;; ----
+ ;; Nothing else should be relocated
+ [else g]))
+ (loop g0))
+
+ ;; ----------------------------------------
+
+ ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
+ (define (do-template ctx tstx loc-id stx?)
+ (define-values (pre-guide disappeared-uses)
+ (parse-template ctx tstx stx?))
+ (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
+ (define code (syntax-arm (datum->syntax here-stx guide ctx)))
+ (syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses)))
+ )
+
+(define-syntax (syntax stx)
+ (define s (syntax->list stx))
+ (if (and (list? s) (= (length s) 2))
+ (do-template stx (cadr s) #f #t)
+ (raise-syntax-error #f "bad syntax" stx)))
+
+(define-syntax (syntax/loc stx)
+ (define s (syntax->list stx))
+ (if (and (list? s) (= (length s) 3))
+ (let ([loc-id (quote-syntax loc)])
+ (define code
+ `(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))])
+ ,(do-template stx (caddr s) loc-id #t)))
+ (syntax-arm (datum->syntax here-stx code stx)))
+ (raise-syntax-error #f "bad syntax" stx)))
+
+(define-syntax (datum stx)
+ (define s (syntax->list stx))
+ (if (and (list? s) (= (length s) 2))
+ (do-template stx (cadr s) #f #f)
+ (raise-syntax-error #f "bad syntax" stx)))
+
+;; check-loc : Symbol Any -> (U Syntax #f)
+;; Raise exn if not syntax. Returns same syntax if suitable for srcloc
+;; (ie, if at least syntax-source or syntax-position set), #f otherwise.
+(define (check-loc who x)
+ (if (syntax? x)
+ (if (or (syntax-source x) (syntax-position x))
+ x
+ #f)
+ (raise-argument-error who "syntax?" x)))
+
+;; ============================================================
+;; Run-time support
+
+;; (t-dots cons? hguide iter-vars src-vars head-datum at-stx) : Expr[(Listof Syntax)]
+(define-syntax (t-dots stx)
+ (define s (syntax->list stx))
+ (define cons? (syntax-e (list-ref s 1)))
+ (define head (list-ref s 2))
+ (define iter-vars (syntax->list (list-ref s 3)))
+ (define src-exprs (syntax->list (list-ref s 4)))
+ (define in-stx (list-ref s 5))
+ (define at-stx (list-ref s 6))
+ (define code
+ `(let ,(map list iter-vars src-exprs)
+ ,(if (> (length iter-vars) 1) `(check-same-length ,in-stx ,at-stx . ,iter-vars) '(void))
+ ,(if cons?
+ `(map (lambda ,iter-vars ,head) . ,iter-vars)
+ `(apply append (map (lambda ,iter-vars ,head) . ,iter-vars)))))
+ (datum->syntax here-stx code stx))
+
+(define-syntaxes (t-orelse h-orelse)
+ (let ()
+ (define (orelse-transformer stx)
+ (define s (syntax->list stx))
+ (datum->syntax here-stx
+ `(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s)))))
+ (values orelse-transformer orelse-transformer)))
+
+(#%require (rename '#%kernel t-quote quote)
+ (rename '#%kernel t-quote-syntax quote-syntax)
+ (rename '#%kernel t-var #%expression)
+ (rename '#%kernel t-check-var #%expression)
+ ;; (rename '#%kernel t-append append)
+ (rename '#%kernel t-list list)
+ (rename '#%kernel t-list* list*)
+ (rename '#%kernel t-escaped #%expression)
+ (rename '#%kernel t-vector list->vector)
+ (rename '#%kernel t-box box-immutable)
+ (rename '#%kernel h-t list))
+
+(begin-encourage-inline
+
+(define (t-append xs ys) (if (null? ys) xs (append xs ys)))
+(define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx))
+(define (t-relocate g loc) (datum->syntax g (syntax-e g) (or loc g) g))
+(define (t-orelse* g1 g2)
+ ((let/ec escape
+ (with-continuation-mark
+ absent-pvar-escape-key
+ (lambda () (escape g2))
+ (let ([v (g1)]) (lambda () v))))))
+(define (t-struct key g) (apply make-prefab-struct key g))
+(define (t-metafun mf g stx)
+ (mf (datum->syntax stx (cons (stx-car stx) g) stx stx)))
+(define (h-splice g in-stx at-stx)
+ (if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx)))
+
+#| end begin-encourage-inline |#)
+
+;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax
+;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs)
+;; There is one arg for each index in substs. See also defn of Guide above.
+(define (t-subst loc stx substs . args)
+ (define (loop/mode s i mode seek substs args)
+ (cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))]
+ [(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
+ [(eq? mode 'tail) (car args)]
+ [(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
+ [(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args))
+ (loop (cdr s) (add1 i) substs (cdr args)))]))
+ (define (loop s i substs args)
+ (cond [(null? substs) s]
+ [(symbol? (car substs))
+ (loop/mode s i (car substs) (cadr substs) (cddr substs) args)]
+ [else (loop/mode s i #f (car substs) (cdr substs) args)]))
+ (define v (loop (syntax-e stx) 0 substs args))
+ (datum->syntax stx v (or loc stx) stx))
+
+(define absent-pvar-escape-key (gensym 'absent-pvar-escape))
+
+;; signal-absent-pvar : -> escapes or #f
+;; Note: Only escapes if in ~? form.
+(define (signal-absent-pvar)
+ (let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)])
+ (if escape (escape) #f)))
+
+;; error/splice : Any Stx Stx -> (escapes)
+(define (error/splice r in-stx at-stx)
+ (raise-syntax-error 'syntax
+ (format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx))
+
+;; check-same-length : Stx Stx List ... -> Void
+(define check-same-length
+ (case-lambda
+ [(in at a) (void)]
+ [(in at a b)
+ (if (= (length a) (length b))
+ (void)
+ (raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
+ (list in '...) at))]
+ [(in at a . bs)
+ (define alen (length a))
+ (for-each (lambda (b)
+ (if (= alen (length b))
+ (void)
+ (raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
+ (list in '...) at)))
+ bs)]))
+
+)
diff --git a/7-4/racket/collects/racket/private/with-stx.rkt b/7-4/racket/collects/racket/private/with-stx.rkt
new file mode 100644
index 0000000..1e22edc
--- /dev/null
+++ b/7-4/racket/collects/racket/private/with-stx.rkt
@@ -0,0 +1,99 @@
+;;----------------------------------------------------------------------
+;; with-syntax, generate-temporaries
+
+(module with-stx '#%kernel
+ (#%require racket/private/stx racket/private/small-scheme "stxcase.rkt"
+ (for-syntax '#%kernel racket/private/stx "stxcase.rkt" "stxloc.rkt"
+ racket/private/gen-temp racket/private/sc racket/private/qq-and-or racket/private/cond))
+
+ (-define (with-syntax-fail stx)
+ (raise-syntax-error
+ 'with-syntax
+ "binding match failed"
+ stx))
+
+ (-define (with-datum-fail stx)
+ (raise-syntax-error
+ 'with-datum
+ "binding match failed"
+ stx))
+
+ ;; Partly from Dybvig
+ (begin-for-syntax
+ (define-values (gen-with-syntax)
+ (let ([here-stx (quote-syntax here)])
+ (lambda (x s-exp?)
+ (syntax-case x ()
+ ((_ () e1 e2 ...)
+ (syntax/loc x (let () e1 e2 ...)))
+ ((_ ((out in) ...) e1 e2 ...)
+ (let ([ins (syntax->list (syntax (in ...)))])
+ ;; Check for duplicates or other syntax errors:
+ (get-match-vars (syntax _) x (syntax (out ...)) null)
+ ;; Generate temps and contexts:
+ (let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)]
+ [heres (map (lambda (x)
+ (datum->syntax
+ x
+ 'here
+ x))
+ ins)]
+ [outs (syntax->list (syntax (out ...)))])
+ ;; Let-bind RHSs, then build up nested syntax-cases:
+ (datum->syntax
+ here-stx
+ `(let ,(map (lambda (tmp here in)
+ `[,tmp ,(if s-exp?
+ in
+ `(datum->syntax
+ (quote-syntax ,here)
+ ,in))])
+ tmps heres ins)
+ ,(let loop ([tmps tmps][outs outs])
+ (cond
+ [(null? tmps)
+ (syntax (begin e1 e2 ...))]
+ [else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp?
+ [,(car outs) ,(loop (cdr tmps)
+ (cdr outs))]
+ [_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail)
+ ;; Minimize the syntax structure we keep:
+ (quote-syntax ,(datum->syntax
+ #f
+ (syntax->datum (car outs))
+ (car outs))))])])))
+ x)))))))))
+
+ (-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f)))
+ (-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t)))
+
+ (-define counter 0)
+ (-define (append-number s)
+ (set! counter (add1 counter))
+ (string->symbol (format "~a~s" s counter)))
+
+ (-define (generate-temporaries sl)
+ (unless (stx-list? sl)
+ (raise-argument-error
+ 'generate-temporaries
+ "(or/c list? syntax->list)"
+ sl))
+ (let ([l (stx->list sl)])
+ (map (lambda (x)
+ ((make-syntax-introducer)
+ (cond
+ [(symbol? x)
+ (datum->syntax #f (append-number x))]
+ [(string? x)
+ (datum->syntax #f (append-number x))]
+ [(keyword? x)
+ (datum->syntax #f (append-number (keyword->string x)))]
+ [(identifier? x)
+ (datum->syntax #f (append-number (syntax-e x)))]
+ [(and (syntax? x) (keyword? (syntax-e x)))
+ (datum->syntax #f (append-number (keyword->string (syntax-e x))))]
+ [else
+ (datum->syntax #f (append-number 'temp))])))
+ l)))
+
+ (#%provide with-syntax with-datum generate-temporaries))
diff --git a/7-4/racket/collects/racket/syntax.rkt b/7-4/racket/collects/racket/syntax.rkt
new file mode 100644
index 0000000..85c41d1
--- /dev/null
+++ b/7-4/racket/collects/racket/syntax.rkt
@@ -0,0 +1,216 @@
+#lang racket/base
+(require (only-in "stxloc.rkt" syntax-case)
+ stxparse-info/current-pvars
+ (for-syntax racket/base
+ racket/private/sc
+ auto-syntax-e/utils))
+(provide define/with-syntax
+
+ current-recorded-disappeared-uses
+ with-disappeared-uses
+ syntax-local-value/record
+ record-disappeared-uses
+
+ format-symbol
+ format-id
+
+ current-syntax-context
+ wrong-syntax
+
+ generate-temporary
+ internal-definition-context-apply
+ syntax-local-eval
+ with-syntax*)
+
+;; == Defining pattern variables ==
+
+(define-syntax (define/with-syntax stx)
+ (syntax-case stx ()
+ [(define/with-syntax pattern rhs)
+ (let* ([pvar-env (get-match-vars #'define/with-syntax
+ stx
+ #'pattern
+ '())]
+ [depthmap (for/list ([x pvar-env])
+ (let loop ([x x] [d 0])
+ (if (pair? x)
+ (loop (car x) (add1 d))
+ (cons x d))))]
+ [pvars (map car depthmap)]
+ [depths (map cdr depthmap)]
+ [mark (make-syntax-introducer)])
+ (with-syntax ([(pvar ...) pvars]
+ [(depth ...) depths]
+ [(valvar ...) (generate-temporaries pvars)])
+ #'(begin (define-values (valvar ...)
+ (with-syntax ([pattern rhs])
+ (values (pvar-value pvar) ...)))
+ (define-syntax pvar
+ (make-auto-pvar 'depth (quote-syntax valvar)))
+ ...
+ (define-pvars pvar ...))))]))
+;; Ryan: alternative name: define/syntax-pattern ??
+
+;; auxiliary macro
+(define-syntax (pvar-value stx)
+ (syntax-case stx ()
+ [(_ pvar)
+ (identifier? #'pvar)
+ (let ([mapping (syntax-local-value #'pvar)])
+ (unless (syntax-pattern-variable? mapping)
+ (raise-syntax-error #f "not a pattern variable" #'pvar))
+ (syntax-mapping-valvar mapping))]))
+
+
+;; == Disappeared uses ==
+
+(define current-recorded-disappeared-uses (make-parameter #f))
+
+(define-syntax-rule (with-disappeared-uses body-expr ... stx-expr)
+ (let-values ([(stx disappeared-uses)
+ (parameterize ((current-recorded-disappeared-uses null))
+ (let ([result (let () body-expr ... stx-expr)])
+ (values result (current-recorded-disappeared-uses))))])
+ (syntax-property stx
+ 'disappeared-use
+ (append (or (syntax-property stx 'disappeared-use) null)
+ disappeared-uses))))
+
+(define (syntax-local-value/record id pred)
+ (unless (identifier? id)
+ (raise-argument-error 'syntax-local-value/record
+ "identifier?"
+ 0 id pred))
+ (unless (and (procedure? pred)
+ (procedure-arity-includes? pred 1))
+ (raise-argument-error 'syntax-local-value/record
+ "(-> any/c boolean?)"
+ 1 id pred))
+ (let ([value (syntax-local-value id (lambda () #f))])
+ (and (pred value)
+ (begin (record-disappeared-uses (list id))
+ value))))
+
+(define (record-disappeared-uses ids [intro? (syntax-transforming?)])
+ (cond
+ [(identifier? ids) (record-disappeared-uses (list ids) intro?)]
+ [(and (list? ids) (andmap identifier? ids))
+ (let ([uses (current-recorded-disappeared-uses)])
+ (when uses
+ (current-recorded-disappeared-uses
+ (append
+ (if intro?
+ (map syntax-local-introduce ids)
+ ids)
+ uses))))]
+ [else (raise-argument-error 'record-disappeared-uses
+ "(or/c identifier? (listof identifier?))"
+ ids)]))
+
+
+;; == Identifier formatting ==
+
+(define (format-id lctx
+ #:source [src #f]
+ #:props [props #f]
+ #:cert [cert #f]
+ fmt . args)
+ (define (convert x) (->atom x 'format-id))
+ (check-restricted-format-string 'format-id fmt)
+ (let* ([args (map convert args)]
+ [str (apply format fmt args)]
+ [sym (string->symbol str)])
+ (datum->syntax lctx sym src props cert)))
+;; Eli: This looks very *useful*, but I'd like to see it more convenient to
+;; "preserve everything". Maybe add a keyword argument that when #t makes
+;; all the others use values lctx, and when syntax makes the others use that
+;; syntax?
+;; Finally, if you get to add this, then another useful utility in the same
+;; spirit is one that concatenates symbols and/or strings and/or identifiers
+;; into a new identifier. I considered something like that, which expects a
+;; single syntax among its inputs, and will use it for the context etc, or
+;; throw an error if there's more or less than 1.
+
+(define (format-symbol fmt . args)
+ (define (convert x) (->atom x 'format-symbol))
+ (check-restricted-format-string 'format-symbol fmt)
+ (let ([args (map convert args)])
+ (string->symbol (apply format fmt args))))
+
+(define (restricted-format-string? fmt)
+ (regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt))
+
+(define (check-restricted-format-string who fmt)
+ (unless (restricted-format-string? fmt)
+ (raise-arguments-error who
+ (format "format string should have ~a placeholders"
+ fmt)
+ "format string" fmt)))
+
+(define (->atom x err)
+ (cond [(string? x) x]
+ [(symbol? x) x]
+ [(identifier? x) (syntax-e x)]
+ [(keyword? x) (keyword->string x)]
+ [(number? x) x]
+ [(char? x) x]
+ [else (raise-argument-error err
+ "(or/c string? symbol? identifier? keyword? char? number?)"
+ x)]))
+
+
+;; == Error reporting ==
+
+(define current-syntax-context
+ (make-parameter #f
+ (lambda (new-value)
+ (unless (or (syntax? new-value) (eq? new-value #f))
+ (raise-argument-error 'current-syntax-context
+ "(or/c syntax? #f)"
+ new-value))
+ new-value)))
+
+(define (wrong-syntax stx #:extra [extras null] format-string . args)
+ (unless (or (eq? stx #f) (syntax? stx))
+ (raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args)))
+ (let* ([ctx (current-syntax-context)]
+ [blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))])
+ (raise-syntax-error (if (symbol? blame) blame #f)
+ (apply format format-string args)
+ ctx
+ stx
+ extras)))
+;; Eli: The `report-error-as' thing seems arbitrary to me.
+
+
+;; == Other utilities ==
+
+;; generate-temporary : any -> identifier
+(define (generate-temporary [stx 'g])
+ (car (generate-temporaries (list stx))))
+
+;; Included for backwards compatibility.
+(define (internal-definition-context-apply intdefs stx)
+ ; The old implementation of internal-definition-context-apply implicitly converted its stx argument
+ ; to syntax, which some things seem to (possibly unintentionally) rely on, so replicate that
+ ; behavior here:
+ (internal-definition-context-introduce intdefs (datum->syntax #f stx) 'add))
+
+(define (syntax-local-eval stx [intdefs '()])
+ (let* ([name (generate-temporary)]
+ [intdef (syntax-local-make-definition-context)])
+ (syntax-local-bind-syntaxes (list name)
+ #`(call-with-values (lambda () #,stx) list)
+ intdef
+ intdefs)
+ (apply values
+ (syntax-local-value (internal-definition-context-introduce intdef name)
+ #f intdef))))
+
+(define-syntax (with-syntax* stx)
+ (syntax-case stx ()
+ [(_ () body ...) (syntax/loc stx (let () body ...))]
+ [(_ (cl) body ...) (syntax/loc stx (with-syntax (cl) body ...))]
+ [(_ (cl cls ...) body ...)
+ (with-syntax ([with-syntax/rest (syntax/loc stx (with-syntax* (cls ...) body ...))])
+ (syntax/loc stx (with-syntax (cl) with-syntax/rest)))]))
diff --git a/7-4/racket/collects/syntax/parse.rkt b/7-4/racket/collects/syntax/parse.rkt
new file mode 100644
index 0000000..643de4d
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse.rkt
@@ -0,0 +1,33 @@
+#lang racket/base
+(require (for-syntax racket/base)
+ racket/contract/base
+ "parse/pre.rkt"
+ "parse/experimental/provide.rkt"
+ "parse/experimental/contract.rkt")
+(provide (except-out (all-from-out "parse/pre.rkt")
+ static)
+ expr/c)
+(provide-syntax-class/contract
+ [static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])])
+
+(begin-for-syntax
+ (require racket/contract/base
+ syntax/parse/private/residual-ct)
+ (provide pattern-expander?
+ (contract-out
+ [prop:syntax-class
+ (struct-type-property/c (or/c identifier? (-> any/c identifier?)))]
+ [pattern-expander
+ (-> (-> syntax? syntax?) pattern-expander?)]
+ [prop:pattern-expander
+ (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
+ [syntax-local-syntax-parse-pattern-introduce
+ (-> syntax? syntax?)]))
+
+ (require (only-in (for-template syntax/parse) pattern-expander))
+ #;(define pattern-expander
+ (let ()
+ (struct pattern-expander (proc) #:transparent
+ #:omit-define-syntaxes
+ #:property prop:pattern-expander (λ (this) (pattern-expander-proc this)))
+ pattern-expander)))
diff --git a/7-4/racket/collects/syntax/parse/debug.rkt b/7-4/racket/collects/syntax/parse/debug.rkt
new file mode 100644
index 0000000..c62849b
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/debug.rkt
@@ -0,0 +1,129 @@
+#lang racket/base
+(require (for-syntax racket/base
+ syntax/stx
+ racket/syntax
+ syntax/parse/private/rep-data
+ "private/rep.rkt"
+ syntax/parse/private/kws)
+ racket/list
+ racket/pretty
+ "../parse.rkt"
+ (except-in stxparse-info/parse/private/residual
+ prop:syntax-class
+ prop:pattern-expander
+ syntax-local-syntax-parse-pattern-introduce)
+ "private/runtime.rkt"
+ "private/runtime-progress.rkt"
+ "private/runtime-report.rkt"
+ syntax/parse/private/kws)
+
+;; No lazy loading for this module's dependencies.
+
+(provide syntax-class-parse
+ syntax-class-attributes
+ syntax-class-arity
+ syntax-class-keywords
+
+ debug-rhs
+ debug-pattern
+ debug-parse
+ debug-syntax-parse!)
+
+(define-syntax (syntax-class-parse stx)
+ (syntax-case stx ()
+ [(_ s x arg ...)
+ (parameterize ((current-syntax-context stx))
+ (with-disappeared-uses
+ (let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
+ [stxclass
+ (get-stxclass/check-arity #'s stx
+ (length (arguments-pargs argu))
+ (arguments-kws argu))]
+ [attrs (stxclass-attrs stxclass)])
+ (with-syntax ([parser (stxclass-parser stxclass)]
+ [argu argu]
+ [(name ...) (map attr-name attrs)]
+ [(depth ...) (map attr-depth attrs)])
+ #'(let ([fh (lambda (undos fs) fs)])
+ (app-argu parser x x (ps-empty x x) #f null fh fh #f
+ (lambda (fh undos . attr-values)
+ (map vector '(name ...) '(depth ...) attr-values))
+ argu))))))]))
+
+(define-syntaxes (syntax-class-attributes
+ syntax-class-arity
+ syntax-class-keywords)
+ (let ()
+ (define ((mk handler) stx)
+ (syntax-case stx ()
+ [(_ s)
+ (parameterize ((current-syntax-context stx))
+ (with-disappeared-uses
+ (handler (get-stxclass #'s))))]))
+ (values (mk (lambda (s)
+ (let ([attrs (stxclass-attrs s)])
+ (with-syntax ([(a ...) (map attr-name attrs)]
+ [(d ...) (map attr-depth attrs)])
+ #'(quote ((a d) ...))))))
+ (mk (lambda (s)
+ (let ([a (stxclass-arity s)])
+ #`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a)))))
+ (mk (lambda (s)
+ (let ([a (stxclass-arity s)])
+ #`(values '#,(arity-minkws a) '#,(arity-maxkws a))))))))
+
+(define-syntax (debug-rhs stx)
+ (syntax-case stx ()
+ [(debug-rhs rhs)
+ (let ([rhs (parse-rhs #'rhs #f #:context stx)])
+ #`(quote #,rhs))]))
+
+(define-syntax (debug-pattern stx)
+ (syntax-case stx ()
+ [(debug-pattern p . rest)
+ (let-values ([(rest pattern defs)
+ (parse-pattern+sides #'p #'rest
+ #:splicing? #f
+ #:decls (new-declenv null)
+ #:context stx)])
+ (unless (stx-null? rest)
+ (raise-syntax-error #f "unexpected terms" stx rest))
+ #`(quote ((definitions . #,defs)
+ (pattern #,pattern))))]))
+
+(define-syntax-rule (debug-parse x p ...)
+ (let/ec escape
+ (parameterize ((current-failure-handler
+ (lambda (_ fs)
+ (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
+ (escape
+ `(parse-failure
+ #:raw-failures
+ ,raw-fs-sexpr
+ #:maximal-failures
+ ,maximal-fs-sexpr)))))
+ (syntax-parse x [p 'success] ...))))
+
+(define (fs->sexprs fs)
+ (let* ([raw-fs (map invert-failure (reverse (flatten fs)))]
+ [selected-groups (maximal-failures raw-fs)])
+ (values (failureset->sexpr raw-fs)
+ (let ([selected (map (lambda (fs)
+ (cons 'progress-class
+ (map failure->sexpr fs)))
+ selected-groups)])
+ (if (= (length selected) 1)
+ (car selected)
+ (cons 'union selected))))))
+
+(define (debug-syntax-parse!)
+ (define old-failure-handler (current-failure-handler))
+ (current-failure-handler
+ (lambda (ctx fs)
+ (define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
+ (eprintf "*** syntax-parse debug info ***\n")
+ (eprintf "Raw failures:\n")
+ (pretty-write raw-fs-sexpr (current-error-port))
+ (eprintf "Maximal failures:\n")
+ (pretty-write maximal-fs-sexpr (current-error-port))
+ (old-failure-handler ctx fs))))
diff --git a/7-4/racket/collects/syntax/parse/define.rkt b/7-4/racket/collects/syntax/parse/define.rkt
new file mode 100644
index 0000000..6392c75
--- /dev/null
+++ b/7-4/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 (macro:id . pattern) . body)
+ #`(define-syntax macro
+ (syntax-parser/template
+ #,((make-syntax-introducer) stx)
+ [((~var macro id) . pattern) . body]))]))
+
+(define-simple-macro (define-syntax-parser macro:id option-or-clause ...)
+ (define-syntax macro
+ (syntax-parser option-or-clause ...)))
+
diff --git a/7-4/racket/collects/syntax/parse/experimental/contract.rkt b/7-4/racket/collects/syntax/parse/experimental/contract.rkt
new file mode 100644
index 0000000..b0f932b
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/contract.rkt
@@ -0,0 +1,46 @@
+#lang racket/base
+(require stxparse-info/parse/pre
+ "provide.rkt"
+ syntax/contract
+ (only-in stxparse-info/parse/private/residual ;; keep abs. path
+ this-context-syntax
+ this-role)
+ racket/contract/base)
+
+(define not-given (gensym))
+
+(define-syntax-class (expr/c ctc-stx
+ #:arg? [arg? #t]
+ #:positive [pos-blame 'from-macro]
+ #:negative [neg-blame 'use-site]
+ #:macro [macro-name #f]
+ #:name [expr-name not-given]
+ #:context [ctx #f]
+ #:phase [phase (syntax-local-phase-level)])
+ #:attributes (c)
+ #:commit
+ (pattern y:expr
+ #:with
+ c (wrap-expr/c ctc-stx
+ #'y
+ #:arg? arg?
+ #:positive pos-blame
+ #:negative neg-blame
+ #:name (if (eq? expr-name not-given)
+ this-role
+ expr-name)
+ #:macro macro-name
+ #:context (or ctx (this-context-syntax))
+ #:phase phase)))
+
+(provide-syntax-class/contract
+ [expr/c (syntax-class/c (syntax?)
+ (#:arg? any/c
+ #:positive (or/c syntax? string? module-path-index?
+ 'from-macro 'use-site 'unknown)
+ #:negative (or/c syntax? string? module-path-index?
+ 'from-macro 'use-site 'unknown)
+ #:name (or/c identifier? string? symbol? #f)
+ #:macro (or/c identifier? string? symbol? #f)
+ #:context (or/c syntax? #f)
+ #:phase exact-integer?))])
diff --git a/7-4/racket/collects/syntax/parse/experimental/eh.rkt b/7-4/racket/collects/syntax/parse/experimental/eh.rkt
new file mode 100644
index 0000000..f8e1b09
--- /dev/null
+++ b/7-4/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)
diff --git a/7-4/racket/collects/syntax/parse/experimental/private/substitute.rkt b/7-4/racket/collects/syntax/parse/experimental/private/substitute.rkt
new file mode 100644
index 0000000..7bc35af
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/private/substitute.rkt
@@ -0,0 +1 @@
+#lang racket/base
diff --git a/7-4/racket/collects/syntax/parse/experimental/provide.rkt b/7-4/racket/collects/syntax/parse/experimental/provide.rkt
new file mode 100644
index 0000000..173d81e
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/provide.rkt
@@ -0,0 +1,156 @@
+#lang racket/base
+(require racket/contract/base
+ racket/contract/combinator
+ syntax/location
+ (for-syntax racket/base
+ racket/syntax
+ syntax/parse/private/minimatch
+ stxparse-info/parse/pre
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/kws
+ syntax/contract))
+(provide provide-syntax-class/contract
+ syntax-class/c
+ splicing-syntax-class/c)
+
+;; FIXME:
+;; - seems to get first-requiring-module wrong, not surprising
+;; - extend to contracts on attributes?
+;; - syntax-class/c etc just a made-up name, for now
+;; (connect to dynamic syntax-classes, eventually)
+
+(define-syntaxes (syntax-class/c splicing-syntax-class/c)
+ (let ([nope
+ (lambda (stx)
+ (raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))])
+ (values nope nope)))
+
+(begin-for-syntax
+ (define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab
+ #:omit-define-syntaxes))
+
+(begin-for-syntax
+ ;; do-one-contract : stx id stxclass ctcrec id -> stx
+ (define (do-one-contract stx scname stxclass rec pos-module-source)
+ ;; First, is the contract feasible?
+ (match (stxclass-arity stxclass)
+ [(arity minpos maxpos minkws maxkws)
+ (let* ([minpos* (length (ctcrec-mpcs rec))]
+ [maxpos* (+ minpos* (length (ctcrec-opcs rec)))]
+ [minkws* (sort (map syntax-e (ctcrec-mkws rec)) keyword<?)]
+ [maxkws* (sort (append minkws* (map syntax-e (ctcrec-okws rec))) keyword<?)])
+ (define (err msg . args)
+ (apply wrong-syntax scname msg args))
+ (unless (<= minpos minpos*)
+ (err (string-append "expected a syntax class with at most ~a "
+ "required positional arguments, got one with ~a")
+ minpos* minpos))
+ (unless (<= maxpos* maxpos)
+ (err (string-append "expected a syntax class with at least ~a "
+ "total positional arguments (required and optional), "
+ "got one with ~a")
+ maxpos* maxpos))
+ (unless (null? (diff/sorted/eq minkws minkws*))
+ (err (string-append "expected a syntax class with at most the "
+ "required keyword arguments ~a, got one with ~a")
+ (join-sep (map kw->string minkws*) "," "and")
+ (join-sep (map kw->string minkws) "," "and")))
+ (unless (null? (diff/sorted/eq maxkws* maxkws))
+ (err (string-append "expected a syntax class with at least the optional "
+ "keyword arguments ~a, got one with ~a")
+ (join-sep (map kw->string maxkws*) "," "and")
+ (join-sep (map kw->string maxkws) "," "and")))
+ (with-syntax ([scname scname]
+ [#s(stxclass name arity attrs parser splicing? opts inline)
+ stxclass]
+ [#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
+ (opc ...) (okw ...) (okwc ...))
+ rec]
+ [arity* (arity minpos* maxpos* minkws* maxkws*)]
+ [(parser-contract contracted-parser contracted-scname)
+ (generate-temporaries #`(contract parser #,scname))])
+ (with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))]
+ [(mkwc-id ...) (generate-temporaries #'(mkwc ...))]
+ [(opc-id ...) (generate-temporaries #'(opc ...))]
+ [(okwc-id ...) (generate-temporaries #'(okwc ...))])
+ (with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)]
+ [((okw-c-part ...) ...) #'((okw okwc-id) ...)]
+ [((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)]
+ [((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)])
+ #`(begin
+ (define parser-contract
+ (let ([mpc-id mpc] ...
+ [mkwc-id mkwc] ...
+ [opc-id opc] ...
+ [okwc-id okwc] ...)
+ (rename-contract
+ (->* (any/c any/c any/c any/c any/c any/c any/c any/c any/c
+ mpc-id ... mkw-c-part ... ...)
+ (okw-c-part ... ...)
+ any)
+ `(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c)
+ [,(contract-name mpc-id) ... mkw-name-part ... ...]
+ [okw-name-part ... ...]))))
+ (define-module-boundary-contract contracted-parser
+ parser parser-contract #:pos-source #,pos-module-source)
+ (define-syntax contracted-scname
+ (make-stxclass
+ (quote-syntax name)
+ 'arity*
+ 'attrs
+ (quote-syntax contracted-parser)
+ 'splicing?
+ 'opts #f)) ;; must disable inlining
+ (provide (rename-out [contracted-scname scname])))))))])))
+
+(define-syntax (provide-syntax-class/contract stx)
+
+ (define-syntax-class stxclass-ctc
+ #:description "syntax-class/c or splicing-syntax-class/c form"
+ #:literals (syntax-class/c splicing-syntax-class/c)
+ #:attributes (rec)
+ #:commit
+ (pattern ((~or syntax-class/c splicing-syntax-class/c)
+ mand:ctclist
+ (~optional opt:ctclist))
+ #:attr rec (make-ctcrec (attribute mand.pc.c)
+ (attribute mand.kw)
+ (attribute mand.kwc.c)
+ (or (attribute opt.pc.c) '())
+ (or (attribute opt.kw) '())
+ (or (attribute opt.kwc.c) '()))))
+
+ (define-syntax-class ctclist
+ #:attributes ([pc.c 1] [kw 1] [kwc.c 1])
+ #:commit
+ (pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...)
+ #:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))])
+ (wrap-expr/c #'contract? pc-expr))
+ #:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))])
+ (wrap-expr/c #'contract? kwc-expr))))
+
+ (syntax-parse stx
+ [(_ [scname c:stxclass-ctc] ...)
+ #:declare scname (static stxclass? "syntax class")
+ (parameterize ((current-syntax-context stx))
+ (with-disappeared-uses
+ #`(begin (define pos-module-source (quote-module-name))
+ #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
+ [stxclass (in-list (attribute scname.value))]
+ [rec (in-list (attribute c.rec))])
+ (do-one-contract stx scname stxclass rec #'pos-module-source)))))]))
+
+;; Copied from unstable/contract,
+;; which requires racket/contract, not racket/contract/base
+
+;; rename-contract : contract any/c -> contract
+;; If the argument is a flat contract, so is the result.
+(define (rename-contract ctc name)
+ (let ([ctc (coerce-contract 'rename-contract ctc)])
+ (if (flat-contract? ctc)
+ (flat-named-contract name (flat-contract-predicate ctc))
+ (let* ([ctc-fo (contract-first-order ctc)]
+ [late-neg-proj (contract-late-neg-projection ctc)])
+ (make-contract #:name name
+ #:late-neg-projection late-neg-proj
+ #:first-order ctc-fo)))))
diff --git a/7-4/racket/collects/syntax/parse/experimental/reflect.rkt b/7-4/racket/collects/syntax/parse/experimental/reflect.rkt
new file mode 100644
index 0000000..8f18781
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/reflect.rkt
@@ -0,0 +1,147 @@
+#lang racket/base
+(require (for-syntax racket/base
+ racket/lazy-require
+ racket/syntax
+ syntax/parse/private/residual-ct) ;; keep abs.path
+ racket/contract/base
+ racket/contract/combinator
+ syntax/parse/private/minimatch
+ syntax/parse/private/keywords
+ "../private/runtime-reflect.rkt"
+ syntax/parse/private/kws)
+(begin-for-syntax
+ (lazy-require
+ [syntax/parse/private/rep-data ;; keep abs. path
+ (get-stxclass)]))
+;; 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 (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-data)
+
+(define-syntax (reify-syntax-class stx)
+ (if (eq? (syntax-local-context) 'expression)
+ (syntax-case stx ()
+ [(rsc sc)
+ (with-disappeared-uses
+ (let* ([stxclass (get-stxclass #'sc)]
+ [splicing? (stxclass-splicing? stxclass)])
+ (unless (scopts-delimit-cut? (stxclass-opts stxclass))
+ (raise-syntax-error #f "cannot reify syntax class with #:no-delimit-cut option"
+ stx #'sc))
+ (with-syntax ([name (stxclass-name stxclass)]
+ [parser (stxclass-parser stxclass)]
+ [arity (stxclass-arity stxclass)]
+ [(#s(attr aname adepth _) ...) (stxclass-attrs stxclass)]
+ [ctor
+ (if splicing?
+ #'reified-splicing-syntax-class
+ #'reified-syntax-class)])
+ #'(ctor 'name parser 'arity '((aname adepth) ...)))))])
+ #`(#%expression #,stx)))
+
+(define (reified-syntax-class-arity r)
+ (match (reified-arity r)
+ [(arity minpos maxpos _ _)
+ (to-procedure-arity minpos maxpos)]))
+
+(define (reified-syntax-class-keywords r)
+ (match (reified-arity r)
+ [(arity _ _ minkws maxkws)
+ (values minkws maxkws)]))
+
+(define (reified-syntax-class-attributes r)
+ (reified-signature r))
+
+(define reified-syntax-class-curry
+ (make-keyword-procedure
+ (lambda (kws1 kwargs1 r . rest1)
+ (match r
+ [(reified name parser arity1 sig)
+ (let ()
+ (check-curry arity1 (length rest1) kws1
+ (lambda (msg)
+ (raise-mismatch-error 'reified-syntax-class-curry
+ (string-append msg ": ") r)))
+ (let* ([curried-arity
+ (match arity1
+ [(arity minpos maxpos minkws maxkws)
+ (let* ([rest1-length (length rest1)]
+ [minpos* (- minpos rest1-length)]
+ [maxpos* (- maxpos rest1-length)]
+ [minkws* (sort (remq* kws1 minkws) keyword<?)]
+ [maxkws* (sort (remq* kws1 maxkws) keyword<?)])
+ (arity minpos* maxpos* minkws* maxkws*))])]
+ [curried-parser
+ (make-keyword-procedure
+ (lambda (kws2 kwargs2 x cx pr es undos fh cp rl success . rest2)
+ (let-values ([(kws kwargs) (merge2 kws1 kws2 kwargs1 kwargs2)])
+ (keyword-apply parser kws kwargs x cx pr es undos fh cp rl success
+ (append rest1 rest2)))))]
+ [ctor
+ (cond [(reified-syntax-class? r)
+ reified-syntax-class]
+ [(reified-splicing-syntax-class? r)
+ reified-splicing-syntax-class]
+ [else
+ (error 'curry-reified-syntax-class "INTERNAL ERROR: ~e" r)])])
+ (ctor name curried-parser curried-arity sig)))]))))
+
+(define (merge2 kws1 kws2 kwargs1 kwargs2)
+ (cond [(null? kws1)
+ (values kws2 kwargs2)]
+ [(null? kws2)
+ (values kws1 kwargs1)]
+ [(keyword<? (car kws1) (car kws2))
+ (let-values ([(m-kws m-kwargs)
+ (merge2 (cdr kws1) kws2 (cdr kwargs1) kwargs2)])
+ (values (cons (car kws1) m-kws) (cons (car kwargs1) m-kwargs)))]
+ [else
+ (let-values ([(m-kws m-kwargs)
+ (merge2 kws1 (cdr kws2) kwargs1 (cdr kwargs2))])
+ (values (cons (car kws2) m-kws) (cons (car kwargs2) m-kwargs)))]))
+
+;; ----
+
+(provide reify-syntax-class
+ ~reflect
+ ~splicing-reflect)
+
+(provide/contract
+ [reified-syntax-class?
+ (-> any/c boolean?)]
+ [reified-splicing-syntax-class?
+ (-> any/c boolean?)]
+ [reified-syntax-class-attributes
+ (-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
+ (listof (list/c symbol? exact-nonnegative-integer?)))]
+ [reified-syntax-class-arity
+ (-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
+ procedure-arity?)]
+ [reified-syntax-class-keywords
+ (-> (or/c reified-syntax-class? reified-splicing-syntax-class?)
+ (values (listof keyword?)
+ (listof keyword?)))]
+ [reified-syntax-class-curry
+ (make-contract #:name '(->* ((or/c reified-syntax-class? reified-splicing-syntax-class/c))
+ (#:<kw> any/c ...)
+ #:rest list?
+ (or/c reified-syntax-class? reified-splicing-syntax-class/c))
+ #:late-neg-projection
+ (lambda (blame)
+ (let ([check-reified
+ ((contract-late-neg-projection
+ (or/c reified-syntax-class? reified-splicing-syntax-class?))
+ (blame-swap blame))])
+ (lambda (f neg-party)
+ (if (and (procedure? f)
+ (procedure-arity-includes? f 1))
+ (make-keyword-procedure
+ (lambda (kws kwargs r . args)
+ (keyword-apply f kws kwargs (check-reified r neg-party) args)))
+ (raise-blame-error
+ blame #:missing-party neg-party
+ f
+ "expected a procedure of at least one argument, given ~e"
+ f)))))
+ #:first-order
+ (lambda (f) (procedure? f)))])
diff --git a/7-4/racket/collects/syntax/parse/experimental/specialize.rkt b/7-4/racket/collects/syntax/parse/experimental/specialize.rkt
new file mode 100644
index 0000000..ad569c1
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/specialize.rkt
@@ -0,0 +1,40 @@
+#lang racket/base
+(require (for-syntax racket/base
+ racket/syntax
+ syntax/parse/private/kws
+ syntax/parse/private/rep-data
+ "../private/rep.rkt")
+ "../private/runtime.rkt")
+(provide define-syntax-class/specialize)
+
+(define-syntax (define-syntax-class/specialize stx)
+ (parameterize ((current-syntax-context stx))
+ (syntax-case stx ()
+ [(dscs header sc-expr)
+ (with-disappeared-uses
+ (let-values ([(name formals arity)
+ (let ([p (check-stxclass-header #'header stx)])
+ (values (car p) (cadr p) (caddr p)))]
+ [(target-scname argu)
+ (let ([p (check-stxclass-application #'sc-expr stx)])
+ (values (car p) (cdr p)))])
+ (let* ([pos-count (length (arguments-pargs argu))]
+ [kws (arguments-kws argu)]
+ [target (get-stxclass/check-arity target-scname target-scname pos-count kws)])
+ (with-syntax ([name name]
+ [formals formals]
+ [parser (generate-temporary (format-symbol "parser-~a" #'name))]
+ [splicing? (stxclass-splicing? target)]
+ [arity arity]
+ [attrs (stxclass-attrs target)]
+ [opts (stxclass-opts target)]
+ [target-parser (stxclass-parser target)]
+ [argu argu])
+ #`(begin (define-syntax name
+ (stxclass 'name 'arity 'attrs
+ (quote-syntax parser)
+ 'splicing?
+ 'opts #f))
+ (define-values (parser)
+ (lambda (x cx pr es undos fh0 cp0 rl success . formals)
+ (app-argu target-parser x cx pr es undos fh0 cp0 rl success argu))))))))])))
diff --git a/7-4/racket/collects/syntax/parse/experimental/splicing.rkt b/7-4/racket/collects/syntax/parse/experimental/splicing.rkt
new file mode 100644
index 0000000..56abbd5
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/splicing.rkt
@@ -0,0 +1,95 @@
+#lang racket/base
+(require (for-syntax racket/base
+ stxparse-info/parse
+ racket/lazy-require
+ syntax/parse/private/kws)
+ stxparse-info/parse/private/residual) ;; keep abs. path
+(provide define-primitive-splicing-syntax-class)
+
+(begin-for-syntax
+ (lazy-require
+ [syntax/parse/private/rep-attrs
+ (sort-sattrs)]))
+;; 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 (for-meta 2 '#%kernel))
+(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep-attrs)
+
+(define-syntax (define-primitive-splicing-syntax-class stx)
+
+ (define-syntax-class attr
+ #:commit
+ (pattern name:id
+ #:with depth #'0)
+ (pattern [name:id depth:nat]))
+
+ (syntax-parse stx
+ [(dssp (name:id param:id ...)
+ (~or (~once (~seq #:attributes (a:attr ...))
+ #:name "attributes declaration")
+ (~once (~seq #:description description)
+ #:name "description declaration")) ...
+ proc:expr)
+ #'(begin
+ (define (get-description param ...)
+ description)
+ (define parser
+ (let ([permute (mk-permute '(a.name ...))])
+ (lambda (x cx pr es undos fh _cp rl success param ...)
+ (let ([stx (datum->syntax cx x cx)])
+ (let ([result
+ (let/ec escape
+ (cons 'ok
+ (proc stx
+ (lambda ([msg #f] [stx #f])
+ (escape (list 'error msg stx))))))])
+ (case (car result)
+ ((ok)
+ (apply success
+ ((mk-check-result pr 'name (length '(a.name ...)) permute x cx undos fh)
+ (cdr result))))
+ ((error)
+ (let ([es
+ (es-add-message (cadr result)
+ (es-add-thing pr (get-description param ...) #f rl es))])
+ (fh undos (failure pr es))))))))))
+ (define-syntax name
+ (stxclass 'name (arity (length '(param ...)) (length '(param ...)) '() '())
+ (sort-sattrs '(#s(attr a.name a.depth #f) ...))
+ (quote-syntax parser)
+ #t
+ (scopts (length '(a.name ...)) #t #t #f)
+ #f)))]))
+
+(define (mk-permute unsorted-attrs)
+ (let ([sorted-attrs
+ (sort unsorted-attrs string<? #:key symbol->string #:cache-keys? #t)])
+ (if (equal? unsorted-attrs sorted-attrs)
+ values
+ (let* ([pos-table
+ (for/hasheq ([a (in-list unsorted-attrs)] [i (in-naturals)])
+ (values a i))]
+ [indexes
+ (for/vector ([a (in-list sorted-attrs)])
+ (hash-ref pos-table a))])
+ (lambda (result)
+ (for/list ([index (in-vector indexes)])
+ (list-ref result index)))))))
+
+(define (mk-check-result pr name attr-count permute x cx undos fh)
+ (lambda (result)
+ (unless (list? result)
+ (error name "parser returned non-list"))
+ (let ([rlength (length result)])
+ (unless (= rlength (+ 1 attr-count))
+ (error name "parser returned list of wrong length; expected length ~s, got ~e"
+ (+ 1 attr-count)
+ result))
+ (let ([skip (car result)])
+ ;; Compute rest-x & rest-cx from skip
+ (unless (exact-nonnegative-integer? skip)
+ (error name "expected exact nonnegative integer for first element of result list, got ~e"
+ skip))
+ (let-values ([(rest-x rest-cx) (stx-list-drop/cx x cx skip)])
+ (list* fh undos rest-x rest-cx (ps-add-cdr pr skip)
+ (permute (cdr result))))))))
diff --git a/7-4/racket/collects/syntax/parse/experimental/template.rkt b/7-4/racket/collects/syntax/parse/experimental/template.rkt
new file mode 100644
index 0000000..160eccc
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/experimental/template.rkt
@@ -0,0 +1,49 @@
+#lang racket/base
+(require (for-syntax racket/base
+ auto-syntax-e/utils)
+ (only-in racket/private/template
+ metafunction))
+(provide (rename-out [syntax template]
+ [syntax/loc template/loc]
+ [quasisyntax quasitemplate]
+ [quasisyntax/loc quasitemplate/loc]
+ [~? ??]
+ [~@ ?@])
+ define-template-metafunction)
+
+;; ============================================================
+;; Metafunctions
+
+(define-syntax (define-template-metafunction stx)
+ (syntax-case stx ()
+ [(dsm (id arg ...) . body)
+ #'(dsm id (lambda (arg ...) . body))]
+ [(dsm id expr)
+ (identifier? #'id)
+ (with-syntax ([(internal-id) (generate-temporaries #'(id))])
+ #'(begin (define internal-id (make-hygienic-metafunction expr))
+ (define-syntax id (metafunction (quote-syntax internal-id)))))]))
+
+(define current-template-metafunction-introducer
+ (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
+
+(define old-template-metafunction-introducer
+ (make-parameter #f))
+
+(define (syntax-local-template-metafunction-introduce stx)
+ (let ([mark (current-template-metafunction-introducer)]
+ [old-mark (old-template-metafunction-introducer)])
+ (unless old-mark
+ (error 'syntax-local-template-metafunction-introduce
+ "must be called within the dynamic extent of a template metafunction"))
+ (mark (old-mark stx))))
+
+(define ((make-hygienic-metafunction transformer) stx)
+ (define mark (make-syntax-introducer))
+ (define old-mark (current-template-metafunction-introducer))
+ (parameterize ((current-template-metafunction-introducer mark)
+ (old-template-metafunction-introducer old-mark))
+ (define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
+ (unless (syntax? r)
+ (raise-syntax-error #f "result of template metafunction was not syntax" stx))
+ (old-mark (mark r))))
diff --git a/7-4/racket/collects/syntax/parse/lib/function-header.rkt b/7-4/racket/collects/syntax/parse/lib/function-header.rkt
new file mode 100644
index 0000000..79e80f3
--- /dev/null
+++ b/7-4/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)))))))
diff --git a/7-4/racket/collects/syntax/parse/pre.rkt b/7-4/racket/collects/syntax/parse/pre.rkt
new file mode 100644
index 0000000..00bdaca
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/pre.rkt
@@ -0,0 +1,49 @@
+#lang racket/base
+(require "private/sc.rkt"
+ "private/litconv.rkt"
+ "private/lib.rkt"
+ "private/residual.rkt")
+(provide (except-out (all-from-out "private/sc.rkt")
+ define-integrable-syntax-class
+ syntax-parser/template)
+ (all-from-out "private/litconv.rkt")
+ (all-from-out "private/lib.rkt")
+ syntax-parse-state-ref
+ syntax-parse-state-set!
+ syntax-parse-state-update!
+ syntax-parse-state-cons!
+ syntax-parse-track-literals)
+
+(define not-given (gensym))
+
+(define (state-ref who key default)
+ (define state (current-state))
+ (if (eq? default not-given)
+ (if (hash-has-key? state key)
+ (hash-ref state key)
+ (error who "no value found for key\n key: ~e" key))
+ (hash-ref state key default)))
+
+(define (syntax-parse-state-ref key [default not-given])
+ (state-ref 'syntax-parse-state-ref key default))
+
+(define (check-update who)
+ (unless (current-state-writable?)
+ (error who "cannot update syntax-parse state outside of ~~do/#:do block")))
+
+(define (syntax-parse-state-set! key value)
+ (check-update 'syntax-parse-state-set!)
+ (current-state (hash-set (current-state) key value)))
+
+(define (syntax-parse-state-update! key update [default not-given])
+ (check-update 'syntax-parse-state-update!)
+ (define old (state-ref 'syntax-parse-state-update! key default))
+ (current-state (hash-set (current-state) key (update old))))
+
+(define (syntax-parse-state-cons! key value [default null])
+ (check-update 'syntax-parse-state-cons!)
+ (define old (hash-ref (current-state) key default))
+ (current-state (hash-set (current-state) key (cons value old))))
+
+(define (syntax-parse-track-literals stx #:introduce? [introduce? #t])
+ (track-literals 'syntax-parse-track-literals stx #:introduce? introduce?))
diff --git a/7-4/racket/collects/syntax/parse/private/3d-stx.rkt b/7-4/racket/collects/syntax/parse/private/3d-stx.rkt
new file mode 100644
index 0000000..b5083d5
--- /dev/null
+++ b/7-4/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))))))
diff --git a/7-4/racket/collects/syntax/parse/private/lib.rkt b/7-4/racket/collects/syntax/parse/private/lib.rkt
new file mode 100644
index 0000000..01e110c
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/lib.rkt
@@ -0,0 +1,96 @@
+#lang racket/base
+(require "sc.rkt"
+ syntax/parse/private/keywords
+ (only-in "residual.rkt" state-cons!)
+ (for-syntax syntax/parse/private/residual-ct)
+ (for-syntax racket/base))
+
+(provide identifier
+ boolean
+ str
+ character
+ keyword
+ number
+ integer
+ exact-integer
+ exact-nonnegative-integer
+ exact-positive-integer
+
+ id
+ nat
+ char
+
+ expr
+ static)
+
+
+(define (expr-stx? x)
+ (not (keyword-stx? x)))
+
+(define ((stxof pred?) x) (and (syntax? x) (pred? (syntax-e x))))
+(define keyword-stx? (stxof keyword?))
+(define boolean-stx? (stxof boolean?))
+(define string-stx? (stxof string?))
+(define bytes-stx? (stxof bytes?))
+(define char-stx? (stxof char?))
+(define number-stx? (stxof number?))
+(define integer-stx? (stxof integer?))
+(define exact-integer-stx? (stxof exact-integer?))
+(define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?))
+(define exact-positive-integer-stx? (stxof exact-positive-integer?))
+(define regexp-stx? (stxof regexp?))
+(define byte-regexp-stx? (stxof byte-regexp?))
+
+
+;; == Integrable syntax classes ==
+
+(define-integrable-syntax-class identifier (quote "identifier") identifier?)
+(define-integrable-syntax-class expr (quote "expression") expr-stx?)
+(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?)
+(define-integrable-syntax-class boolean (quote "boolean") boolean-stx?)
+(define-integrable-syntax-class character (quote "character") char-stx?)
+(define-integrable-syntax-class number (quote "number") number-stx?)
+(define-integrable-syntax-class integer (quote "integer") integer-stx?)
+(define-integrable-syntax-class exact-integer (quote "exact-integer") exact-integer-stx?)
+(define-integrable-syntax-class exact-nonnegative-integer
+ (quote "exact-nonnegative-integer")
+ exact-nonnegative-integer-stx?)
+(define-integrable-syntax-class exact-positive-integer
+ (quote "exact-positive-integer")
+ exact-positive-integer-stx?)
+
+(define-integrable-syntax-class -string (quote "string") string-stx?)
+(define-integrable-syntax-class -bytes (quote "bytes") bytes-stx?)
+(define-integrable-syntax-class -regexp (quote "regexp") regexp-stx?)
+(define-integrable-syntax-class -byte-regexp (quote "byte-regexp") byte-regexp-stx?)
+
+;; Overloading the meaning of existing identifiers
+(begin-for-syntax
+ (set-box! alt-stxclass-mapping
+ (list (cons #'string (syntax-local-value #'-string))
+ (cons #'bytes (syntax-local-value #'-bytes))
+ (cons #'regexp (syntax-local-value #'-regexp))
+ (cons #'byte-regexp (syntax-local-value #'-byte-regexp)))))
+
+;; Aliases
+(define-syntax id (make-rename-transformer #'identifier))
+(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
+(define-syntax char (make-rename-transformer #'character))
+(define-syntax str (make-rename-transformer #'-string))
+
+
+;; == Normal syntax classes ==
+
+(define notfound (box 'notfound))
+
+(define-syntax-class (static pred [name #f])
+ #:attributes (value)
+ #:description name
+ #:commit
+ (pattern x:id
+ #:fail-unless (syntax-transforming?)
+ "not within the dynamic extent of a macro transformation"
+ #:attr value (syntax-local-value #'x (lambda () notfound))
+ #:fail-when (eq? (attribute value) notfound) #f
+ #:fail-unless (pred (attribute value)) #f
+ #:do [(state-cons! 'literals #'x)]))
diff --git a/7-4/racket/collects/syntax/parse/private/litconv.rkt b/7-4/racket/collects/syntax/parse/private/litconv.rkt
new file mode 100644
index 0000000..9e25611
--- /dev/null
+++ b/7-4/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 (list (quote-syntax 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))
diff --git a/7-4/racket/collects/syntax/parse/private/make.rkt b/7-4/racket/collects/syntax/parse/private/make.rkt
new file mode 100644
index 0000000..8a4f744
--- /dev/null
+++ b/7-4/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)))]))
diff --git a/7-4/racket/collects/syntax/parse/private/opt.rkt b/7-4/racket/collects/syntax/parse/private/opt.rkt
new file mode 100644
index 0000000..12714d6
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/opt.rkt
@@ -0,0 +1,456 @@
+#lang racket/base
+(require racket/syntax
+ racket/pretty
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/minimatch
+ syntax/parse/private/rep-patterns
+ syntax/parse/private/kws)
+(provide (struct-out pk1)
+ (rename-out [optimize-matrix0 optimize-matrix]))
+
+;; ----
+
+;; A Matrix is a (listof PK) where each PK has same number of columns
+;; A PK is one of
+;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix
+;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out
+;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded
+;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded
+(struct pk1 (patterns k) #:prefab)
+(struct pk/same (pattern inner) #:prefab)
+(struct pk/pair (inner) #:prefab)
+(struct pk/and (inner) #:prefab)
+
+(define (pk-columns pk)
+ (match pk
+ [(pk1 patterns k) (length patterns)]
+ [(pk/same p inner) (add1 (pk-columns inner))]
+ [(pk/pair inner) (sub1 (pk-columns inner))]
+ [(pk/and inner) (sub1 (pk-columns inner))]))
+
+;; Can factor pattern P given clauses like
+;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
+;; [ P : | :] => [P | [ : | :] ]
+;; [ P PN ... | eN] [ | [PN ... | eN] ]
+;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking)
+
+;; Can unfold pair patterns as follows:
+;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
+;; [ : : | : ] => check pair, [ : | : ]
+;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
+
+;; Can unfold ~and patterns similarly; ~and patterns can hide
+;; factoring opportunities.
+
+;; ----
+
+;; FIXME: New (unimplemented) optimization ideas
+
+;; (1) When collecting pair patterns, can reorder rows with pair vs never-pair
+;; first columns:
+;; [ (P11 . P12) P1 ... | e1 ] [ (P11 . P12) P1 ... | e1 ]
+;; [ P21 P2 ... | e2 ] => [ (P31 . P32) P3 ... | e3 ]
+;; [ (P31 . P32) P3 ... | e3 ] [ P21 P2 ... | e2 ]
+;; provided P21 does not cut and cannot match a pair term.
+;; Likewise for literals and never-symbol patterns.
+
+;; (2) If a row has a non-rejecting pattern (ie, always matches) in its first
+;; column, then the rows above it do not need to produce failure information
+;; *for their first columns*. For example, in the following matrix
+;; [ P11 P1 ... | e1 ]
+;; [ P21 P2 ... | e2 ]
+;; [ P31 P3 ... | e3 ]
+;; Suppose that P21 always matches (eg _) and assume P{1,3}1 are cut-free. Then
+;; P{1,3}1 do not need to produce failure info (set es = #f, etc). Here's why.
+;; If control reaches row 2, then since P21 cannot fail, if it fails the
+;; progress must be greater than P11 or P31. FIXME: Must also check neither P11
+;; nor P31 use ~post (or call stxclass that uses ~post, etc)!
+
+
+;; ----
+
+(define (optimize-matrix0 rows)
+ (define now (current-inexact-milliseconds))
+ (when (and (> (length rows) 1))
+ (log-syntax-parse-debug "OPT matrix (~s rows)\n~a" (length rows)
+ (pretty-format (matrix->sexpr rows) #:mode 'print)))
+ (define result (optimize-matrix rows))
+ (define then (current-inexact-milliseconds))
+ (when (and (> (length rows) 1))
+ (cond [(= (length result) (length rows))
+ (log-syntax-parse-debug "OPT FAILED (~s ms)" (floor (- then now)))]
+ [else
+ (log-syntax-parse-debug "OPT ==> (~s ms)\n~a" (floor (- then now))
+ (pretty-format (matrix->sexpr result) #:mode 'print))]))
+ result)
+
+;; optimize-matrix : (listof pk1) -> Matrix
+(define (optimize-matrix rows)
+ (cond [(null? rows) null]
+ [(null? (cdr rows)) rows] ;; no opportunities for 1 row
+ [(null? (pk1-patterns (car rows))) rows]
+ [else
+ ;; first unfold and-patterns
+ (let-values ([(col1 col2)
+ (for/lists (col1 col2) ([row (in-list rows)])
+ (unfold-and (car (pk1-patterns row)) null))])
+ (cond [(ormap pair? col2)
+ (list
+ (pk/and
+ (optimize-matrix*
+ (for/list ([row (in-list rows)]
+ [col1 (in-list col1)]
+ [col2 (in-list col2)])
+ (pk1 (list* col1
+ (make-and-pattern col2)
+ (cdr (pk1-patterns row)))
+ (pk1-k row))))))]
+ [else (optimize-matrix* rows)]))]))
+
+;; optimize-matrix* : (listof pk1) -> Matrix
+;; The matrix is nonempty, and first column has no unfoldable pat:and.
+;; Split into submatrixes (sequences of rows) starting with similar patterns,
+;; handle according to similarity, then recursively optimize submatrixes.
+(define (optimize-matrix* rows)
+ (define row1 (car rows))
+ (define pat1 (car (pk1-patterns row1)))
+ (define k1 (pk1-k row1))
+ ;; Now accumulate rows starting with patterns like pat1
+ (define-values (like? combine) (pattern->partitioner pat1))
+ (let loop ([rows (cdr rows)] [rrows (list row1)])
+ (cond [(null? rows)
+ (cons (combine (reverse rrows)) null)]
+ [else
+ (define row1 (car rows))
+ (define pat1 (car (pk1-patterns row1)))
+ (cond [(like? pat1)
+ (loop (cdr rows) (cons row1 rrows))]
+ [else
+ (cons (combine (reverse rrows))
+ (optimize-matrix* rows))])])))
+
+;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
+(define (pattern->partitioner pat1)
+ (match pat1
+ [(pat:pair head tail)
+ (values (lambda (p) (pat:pair? p))
+ (lambda (rows)
+ (log-syntax-parse-debug "-- got ~s pair rows like ~e" (length rows) (pattern->sexpr pat1))
+ (cond [(> (length rows) 1)
+ (pk/pair (optimize-matrix
+ (for/list ([row (in-list rows)])
+ (let* ([patterns (pk1-patterns row)]
+ [pat1 (car patterns)])
+ (pk1 (list* (pat:pair-head pat1)
+ (pat:pair-tail pat1)
+ (cdr patterns))
+ (pk1-k row))))))]
+ [else (car rows)])))]
+ [(? pattern-factorable?)
+ (values (lambda (pat2) (pattern-equal? pat1 pat2))
+ (lambda (rows)
+ (log-syntax-parse-debug "-- got ~s factorable like ~e" (length rows) (pattern->sexpr pat1))
+ (cond [(> (length rows) 1)
+ (pk/same pat1
+ (optimize-matrix
+ (for/list ([row (in-list rows)])
+ (pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
+ [else (car rows)])))]
+ [_
+ (values (lambda (pat2) #f)
+ (lambda (rows)
+ ;; (length rows) = 1
+ (car rows)))]))
+
+;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
+(define (unfold-and p onto)
+ (match p
+ [(pat:and subpatterns)
+ ;; pat:and is worth unfolding if first subpattern is not pat:action
+ ;; if first subpattern is also pat:and, keep unfolding
+ (let* ([first-sub (car subpatterns)]
+ [rest-subs (cdr subpatterns)])
+ (cond [(not (pat:action? first-sub))
+ (unfold-and first-sub (*append rest-subs onto))]
+ [else (values p onto)]))]
+ [_ (values p onto)]))
+
+;; pattern-factorable? : *Pattern -> Boolean
+(define (pattern-factorable? p) (not (pattern-unfactorable? p)))
+
+;; pattern-unfactorable? : *Pattern -> Boolean
+(define (pattern-unfactorable? p)
+ ;; Cannot factor out p if
+ ;; - if p can succeed multiple times (factoring changes success order)
+ ;; - if p can cut (factoring changes which choice points are discarded (too few))
+ ;; Note: presence of sub-expressions handled by pattern-equal?.
+ (define (for-pattern p recur)
+ (match p
+ [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
+ [(pat:action _act _pat) #t]
+ [(pat:dots heads tail)
+ ;; Conservative approximation for common case: one head pattern
+ ;; In general, check if heads don't overlap, don't overlap with tail.
+ (or (> (length heads) 1)
+ (not (equal? tail (pat:datum '())))
+ (recur))]
+ [(pat:or _ patterns _) #t]
+ [(pat:not pattern) #t]
+ [(pat:commit pattern) #f]
+ [(? pat:reflect?) #t]
+ [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
+ [(hpat:commit inner) #f]
+ [(ehpat _ head repc _)
+ (or (not (equal? repc #f))
+ (recur))]
+ [_ (recur)]))
+ (pattern-ormap p for-pattern))
+
+(define (subpatterns-equal? as bs)
+ (and (= (length as) (length bs))
+ (for/and ([a (in-list as)]
+ [b (in-list bs)])
+ (pattern-equal? a b))))
+
+(define (pattern-equal? a b)
+ (define result
+ (cond [(and (pat:any? a) (pat:any? b)) #t]
+ [(and (pat:svar? a) (pat:svar? b))
+ (bound-identifier=? (pat:svar-name a) (pat:svar-name b))]
+ [(and (pat:var/p? a) (pat:var/p? b))
+ (and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
+ (bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b))
+ (equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b))
+ (equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
+ (expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
+ [(and (pat:integrated? a) (pat:integrated? b))
+ (and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b))
+ (free-identifier=? (pat:integrated-predicate a)
+ (pat:integrated-predicate b))
+ (expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
+ [(and (pat:literal? a) (pat:literal? b))
+ ;; literals are hard to compare, so compare gensyms attached to
+ ;; literal ids (see rep.rkt) instead
+ (let ([ka (syntax-property (pat:literal-id a) 'literal)]
+ [kb (syntax-property (pat:literal-id b) 'literal)])
+ (and ka kb (eq? ka kb)))]
+ [(and (pat:datum? a) (pat:datum? b))
+ (equal? (pat:datum-datum a)
+ (pat:datum-datum b))]
+ [(and (pat:head? a) (pat:head? b))
+ (and (pattern-equal? (pat:head-head a) (pat:head-head b))
+ (pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
+ [(and (pat:dots? a) (pat:dots? b))
+ (and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
+ (pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
+ [(and (pat:and? a) (pat:and? b))
+ (subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
+ [(and (pat:or? a) (pat:or? b))
+ (subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
+ [(and (pat:not? a) (pat:not? b))
+ (pattern-equal? (pat:not-pattern a) (pat:not-pattern b))]
+ [(and (pat:pair? a) (pat:pair? b))
+ (and (pattern-equal? (pat:pair-head a) (pat:pair-head b))
+ (pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))]
+ [(and (pat:vector? a) (pat:vector? b))
+ (pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))]
+ [(and (pat:box? a) (pat:box? b))
+ (pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
+ [(and (pat:pstruct? a) (pat:pstruct? b))
+ (and (equal? (pat:pstruct-key a)
+ (pat:pstruct-key b))
+ (pattern-equal? (pat:pstruct-pattern a)
+ (pat:pstruct-pattern b)))]
+ [(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
+ [(and (pat:delimit? a) (pat:delimit? b))
+ (pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
+ [(and (pat:commit? a) (pat:commit? b))
+ (pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
+ [(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
+ [(and (pat:ord? a) (pat:ord? b))
+ (and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b))
+ (equal? (pat:ord-group a) (pat:ord-group b))
+ (equal? (pat:ord-index a) (pat:ord-index b)))]
+ [(and (pat:post? a) (pat:post? b))
+ (pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
+ [(and (pat:seq-end? a) (pat:seq-end? b)) #t]
+ ;; ---
+ [(and (hpat:single? a) (hpat:single? b))
+ (pattern-equal? (hpat:single-pattern a) (hpat:single-pattern b))]
+ [(and (hpat:var/p? a) (hpat:var/p? b))
+ (and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
+ (bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
+ (equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b))
+ (equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
+ (expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
+ [(and (hpat:seq? a) (hpat:seq? b))
+ (pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
+ ;; ---
+ [(and (ehpat? a) (ehpat? b))
+ (and (equal? (ehpat-repc a) #f)
+ (equal? (ehpat-repc b) #f)
+ (pattern-equal? (ehpat-head a) (ehpat-head b)))]
+ ;; FIXME: more?
+ [else #f]))
+ (when (and (log-level? syntax-parse-logger 'debug)
+ (eq? result #f)
+ (equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
+ (log-syntax-parse-debug "** pattern-equal? failed on ~e" a))
+ result)
+
+(define (equal-iattrs? as bs)
+ (and (= (length as) (length bs))
+ ;; assumes attrs in same order
+ (for/and ([aa (in-list as)]
+ [ba (in-list bs)])
+ (and (bound-identifier=? (attr-name aa) (attr-name ba))
+ (equal? (attr-depth aa) (attr-depth ba))
+ (equal? (attr-syntax? aa) (attr-syntax? ba))))))
+
+(define (expr-equal? a b)
+ ;; Expression equality is undecidable in general. Especially difficult for unexpanded
+ ;; code, but it would be very difficult to set up correct env for local-expand because of
+ ;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
+ ;; FIXME: any other common cases?
+ (cond [(not (and (syntax? a) (syntax? b)))
+ (equal? a b)]
+ [(and (identifier? a) (identifier? b))
+ ;; note: "vars" might be identifier macros (unsafe to consider equal),
+ ;; so check var has no compile-time binding
+ (and (free-identifier=? a b)
+ (let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
+ [(syntax-case (list a b) (quote)
+ [((quote ad) (quote bd))
+ (cons (syntax->datum #'ad) (syntax->datum #'bd))]
+ [_ #f])
+ => (lambda (ad+bd)
+ (equal? (car ad+bd) (cdr ad+bd)))]
+ [else
+ ;; approx: equal? only if both simple data (bool, string, etc), no inner stx
+ (let ([ad (syntax-e a)]
+ [bd (syntax-e b)])
+ (and (equal? ad bd)
+ (free-identifier=? (datum->syntax a '#%datum) #'#%datum)
+ (free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
+
+(define (equal-argu? a b)
+ (define (unwrap-arguments x)
+ (match x
+ [(arguments pargs kws kwargs)
+ (values pargs kws kwargs)]))
+ (define (list-equal? as bs inner-equal?)
+ (and (= (length as) (length bs))
+ (andmap inner-equal? as bs)))
+ (let-values ([(apargs akws akwargs) (unwrap-arguments a)]
+ [(bpargs bkws bkwargs) (unwrap-arguments b)])
+ (and (list-equal? apargs bpargs expr-equal?)
+ (equal? akws bkws)
+ (list-equal? akwargs bkwargs expr-equal?))))
+
+(define (free-id/f-equal? a b)
+ (or (and (eq? a #f)
+ (eq? b #f))
+ (and (identifier? a)
+ (identifier? b)
+ (free-identifier=? a b))))
+
+(define (bound-id/f-equal? a b)
+ (or (and (eq? a #f)
+ (eq? b #f))
+ (and (identifier? a)
+ (identifier? b)
+ (bound-identifier=? a b))))
+
+(define (make-and-pattern subs)
+ (cond [(null? subs) (pat:any)] ;; shouldn't happen
+ [(null? (cdr subs)) (car subs)]
+ [else (pat:and subs)]))
+
+(define (*append a b) (if (null? b) a (append a b)))
+
+(define (stx-e x) (if (syntax? x) (syntax-e x) x))
+
+;; ----
+
+(define (matrix->sexpr rows)
+ (cond [(null? rows) ;; shouldn't happen
+ '(FAIL)]
+ [(null? (cdr rows))
+ (pk->sexpr (car rows))]
+ [else
+ (cons 'TRY (map pk->sexpr rows))]))
+(define (pk->sexpr pk)
+ (match pk
+ [(pk1 pats k)
+ (cons 'MATCH (map pattern->sexpr pats))]
+ [(pk/same pat inner)
+ (list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
+ [(pk/pair inner)
+ (list 'PAIR (matrix->sexpr inner))]
+ [(pk/and inner)
+ (list 'AND (matrix->sexpr inner))]))
+(define (pattern->sexpr p)
+ (match p
+ [(pat:any) '_]
+ [(pat:integrated name pred desc _)
+ (format-symbol "~a:~a" (or name '_) desc)]
+ [(pat:svar name)
+ (syntax-e name)]
+ [(pat:var/p name parser _ _ _ _)
+ (cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
+ => (lambda (m)
+ (format-symbol "~a:~a" (or name '_) (cadr m)))]
+ [else
+ (if name (syntax-e name) '_)])]
+ [(? pat:literal?) `(syntax ,(syntax->datum (pat:literal-id p)))]
+ [(pat:datum datum)
+ (cond [(or (symbol? datum) (pair? datum))
+ `(quote ,datum)]
+ [else datum])]
+ [(pat:action action (pat:any)) (pattern->sexpr action)]
+ [(pat:action action inner) (list '~AAND (pattern->sexpr action) (pattern->sexpr inner))]
+ [(pat:and patterns) (cons '~and (map pattern->sexpr patterns))]
+ [(pat:or _ patterns _) (cons '~or (map pattern->sexpr patterns))]
+ [(pat:not pattern) (list '~not (pattern->sexpr pattern))]
+ [(pat:pair head tail)
+ (cons (pattern->sexpr head) (pattern->sexpr tail))]
+ [(pat:head head tail)
+ (cons (pattern->sexpr head) (pattern->sexpr tail))]
+ [(pat:dots (list eh) tail)
+ (list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
+ [(pat:dots ehs tail)
+ (list* (cons '~alt (map pattern->sexpr ehs)) '... (pattern->sexpr tail))]
+ [(pat:describe sp _ _ _) (list '~describe (pattern->sexpr sp))]
+ [(pat:delimit sp) (list '~delimit-cut (pattern->sexpr sp))]
+ [(pat:commit sp) (list '~commit (pattern->sexpr sp))]
+ [(pat:ord pattern _ _) (list '~ord (pattern->sexpr pattern))]
+ [(pat:post sp) (list '~post (pattern->sexpr sp))]
+ [(pat:seq-end) '()]
+ [(action:cut) '~!]
+ [(action:fail cnd msg) (list '~fail)]
+ [(action:bind attr expr) (list '~bind)]
+ [(action:and as) (cons '~and (map pattern->sexpr as))]
+ [(action:parse sp expr) (list '~parse (pattern->sexpr sp))]
+ [(action:do stmts) (list '~do)]
+ [(action:undo stmts) (list '~undo)]
+ [(action:ord ap _ _) (list '~ord (pattern->sexpr ap))]
+ [(action:post ap) (list '~post (pattern->sexpr ap))]
+ [(hpat:single sp) (pattern->sexpr sp)]
+ [(hpat:var/p name parser _ _ _ _)
+ (cond [(and parser (regexp-match #rx"^parser-(.*)$" (symbol->string (syntax-e parser))))
+ => (lambda (m) (format-symbol "~a:~a" (or name '_) (cadr m)))]
+ [else (if name (syntax-e name) '_)])]
+ [(hpat:seq lp) (cons '~seq (pattern->sexpr lp))]
+ [(hpat:action ap hp) (list '~AAND (pattern->sexpr ap) (pattern->sexpr hp))]
+ [(hpat:and hp sp) (list '~and (pattern->sexpr hp) (pattern->sexpr sp))]
+ [(hpat:or _ hps _) (cons '~or (map pattern->sexpr hps))]
+ [(hpat:describe hp _ _ _) (list '~describe (pattern->sexpr hp))]
+ [(hpat:delimit hp) (list '~delimit-cut (pattern->sexpr hp))]
+ [(hpat:commit hp) (list '~commit (pattern->sexpr hp))]
+ [(hpat:ord hp _ _) (list '~ord (pattern->sexpr hp))]
+ [(hpat:post hp) (list '~post (pattern->sexpr hp))]
+ [(hpat:peek hp) (list '~peek (pattern->sexpr hp))]
+ [(hpat:peek-not hp) (list '~peek-not (pattern->sexpr hp))]
+ [(ehpat _as hpat repc _cn)
+ (if (eq? repc #f) (pattern->sexpr hpat) (list '~REPC (pattern->sexpr hpat)))]
+ [_ '<Pattern>]))
diff --git a/7-4/racket/collects/syntax/parse/private/parse.rkt b/7-4/racket/collects/syntax/parse/private/parse.rkt
new file mode 100644
index 0000000..7e5c61d
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/parse.rkt
@@ -0,0 +1,1206 @@
+#lang racket/base
+(require (for-syntax racket/base
+ syntax/stx
+ syntax/private/id-table
+ syntax/keyword
+ racket/syntax
+ syntax/parse/private/minimatch
+ syntax/parse/private/datum-to-expr
+ syntax/parse/private/rep-attrs
+ syntax/parse/private/rep-data
+ syntax/parse/private/rep-patterns
+ "rep.rkt"
+ syntax/parse/private/kws
+ "opt.rkt"
+ "txlift.rkt")
+ syntax/parse/private/keywords
+ racket/syntax
+ racket/stxparam
+ syntax/stx
+ stxparse-info/parse/private/residual ;; keep abs. path
+ "runtime.rkt"
+ stxparse-info/parse/private/runtime-reflect) ;; keep abs. path
+
+;; ============================================================
+
+(provide define-syntax-class
+ define-splicing-syntax-class
+ define-integrable-syntax-class
+ syntax-parse
+ syntax-parser
+ define/syntax-parse
+ syntax-parser/template
+ parser/rhs
+ define-eh-alternative-set
+ (for-syntax rhs->parser))
+
+(begin-for-syntax
+ ;; constant-desc : Syntax -> String/#f
+ (define (constant-desc stx)
+ (syntax-case stx (quote)
+ [(quote datum)
+ (let ([d (syntax-e #'datum)])
+ (and (string? d) d))]
+ [expr
+ (let ([d (syntax-e #'expr)])
+ (and (string? d)
+ (free-identifier=? #'#%datum (datum->syntax #'expr '#%datum))
+ d))]))
+
+ (define (tx:define-*-syntax-class stx splicing?)
+ (syntax-case stx ()
+ [(_ header . rhss)
+ (parameterize ((current-syntax-context stx))
+ (let-values ([(name formals arity)
+ (let ([p (check-stxclass-header #'header stx)])
+ (values (car p) (cadr p) (caddr p)))])
+ (let ([the-rhs (parse-rhs #'rhss splicing? #:context stx
+ #:default-description (symbol->string (syntax-e name)))])
+ (with-syntax ([name name]
+ [formals formals]
+ [desc (cond [(rhs-description the-rhs) => constant-desc] [else #f])]
+ [parser (generate-temporary (format-symbol "parse-~a" name))]
+ [arity arity]
+ [attrs (rhs-attrs the-rhs)]
+ [commit? (rhs-commit? the-rhs)]
+ [delimit-cut? (rhs-delimit-cut? the-rhs)]
+ [the-rhs-expr (datum->expression the-rhs)])
+ #`(begin (define-syntax name
+ (stxclass 'name 'arity
+ 'attrs
+ (quote-syntax parser)
+ '#,splicing?
+ (scopts (length 'attrs) 'commit? 'delimit-cut? desc)
+ #f))
+ (define-values (parser)
+ (parser/rhs name formals attrs the-rhs-expr #,splicing? #,stx)))))))])))
+
+(define-syntax define-syntax-class
+ (lambda (stx) (tx:define-*-syntax-class stx #f)))
+(define-syntax define-splicing-syntax-class
+ (lambda (stx) (tx:define-*-syntax-class stx #t)))
+
+(define-syntax (define-integrable-syntax-class stx)
+ (syntax-case stx (quote)
+ [(_ name (quote description) predicate)
+ (with-syntax ([parser (generate-temporary (format-symbol "parse-~a" (syntax-e #'name)))]
+ [no-arity no-arity])
+ #'(begin (define-syntax name
+ (stxclass 'name no-arity '()
+ (quote-syntax parser)
+ #f
+ (scopts 0 #t #t 'description)
+ (quote-syntax predicate)))
+ (define (parser x cx pr es undos fh0 cp0 rl success)
+ (if (predicate x)
+ (success fh0 undos)
+ (let ([es (es-add-thing pr 'description #t rl es)])
+ (fh0 undos (failure* pr es)))))))]))
+
+(define-syntax (parser/rhs stx)
+ (syntax-case stx ()
+ [(parser/rhs name formals relsattrs the-rhs-expr splicing? ctx)
+ (with-disappeared-uses
+ (let ()
+ (define the-rhs
+ (parameterize ((current-syntax-context #'ctx))
+ (fixup-rhs (syntax-local-eval
+ (syntax-local-introduce #'the-rhs-expr))
+ (syntax-e #'splicing?)
+ (syntax->datum #'relsattrs))))
+ (rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?) #'ctx)))]))
+
+(begin-for-syntax
+ (define (rhs->parser name formals relsattrs the-rhs splicing? [ctx #f])
+ (define-values (transparent? description variants defs commit? delimit-cut?)
+ (match the-rhs
+ [(rhs _ transparent? description variants defs commit? delimit-cut?)
+ (values transparent? description variants defs commit? delimit-cut?)]))
+ (define vdefss (map variant-definitions variants))
+ (define formals* (rewrite-formals formals #'x #'rl))
+ (define patterns (map variant-pattern variants))
+ (define no-fail?
+ (and (not splicing?) ;; FIXME: commit? needed?
+ (patterns-cannot-fail? patterns)))
+ (when no-fail? (log-syntax-parse-debug "(stxclass) cannot fail: ~e" ctx))
+ (define body
+ (cond [(null? patterns)
+ #'(fail (failure* pr es))]
+ [splicing?
+ (with-syntax ([(alternative ...)
+ (for/list ([pattern (in-list patterns)])
+ (with-syntax ([pattern pattern]
+ [relsattrs relsattrs]
+ [iattrs (pattern-attrs pattern)]
+ [commit? commit?]
+ [result-pr
+ (if transparent?
+ #'rest-pr
+ #'(ps-pop-opaque rest-pr))])
+ #'(parse:H x cx rest-x rest-cx rest-pr pattern pr es
+ (variant-success relsattrs iattrs (rest-x rest-cx result-pr)
+ success cp0 commit?))))])
+ #'(try alternative ...))]
+ [else
+ (with-syntax ([matrix
+ (optimize-matrix
+ (for/list ([pattern (in-list patterns)])
+ (with-syntax ([iattrs (pattern-attrs pattern)]
+ [relsattrs relsattrs]
+ [commit? commit?])
+ (pk1 (list pattern)
+ #'(variant-success relsattrs iattrs ()
+ success cp0 commit?)))))])
+ #'(parse:matrix ((x cx pr es)) matrix))]))
+ (with-syntax ([formals* formals*]
+ [(def ...) defs]
+ [((vdef ...) ...) vdefss]
+ [description description]
+ [transparent? transparent?]
+ [delimit-cut? delimit-cut?]
+ [body body])
+ #`(lambda (x cx pr es undos fh0 cp0 rl success . formals*)
+ (with ([this-syntax x]
+ [this-role rl])
+ def ...
+ vdef ... ...
+ (#%expression
+ (syntax-parameterize ((this-context-syntax
+ (syntax-rules ()
+ [(tbs) (ps-context-syntax pr)])))
+ (let ([es (es-add-thing pr description 'transparent? rl
+ #,(if no-fail? #'#f #'es))]
+ [pr (if 'transparent? pr (ps-add-opaque pr))])
+ (with ([fail-handler fh0]
+ [cut-prompt cp0]
+ [undo-stack undos])
+ ;; Update the prompt, if required
+ ;; FIXME: can be optimized away if no cut exposed within variants
+ (with-maybe-delimit-cut delimit-cut?
+ body))))))))))
+
+(define-syntax (syntax-parse stx)
+ (syntax-case stx ()
+ [(syntax-parse stx-expr . clauses)
+ (quasisyntax/loc stx
+ (let ([x (datum->syntax #f stx-expr)])
+ (with ([this-syntax x])
+ (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx)))))]))
+
+(define-syntax (syntax-parser stx)
+ (syntax-case stx ()
+ [(syntax-parser . clauses)
+ (quasisyntax/loc stx
+ (lambda (x)
+ (let ([x (datum->syntax #f x)])
+ (with ([this-syntax x])
+ (parse:clauses x clauses body-sequence #,((make-syntax-introducer) stx))))))]))
+
+(define-syntax (syntax-parser/template stx)
+ (syntax-case stx ()
+ [(syntax-parser/template ctx . clauses)
+ (quasisyntax/loc stx
+ (lambda (x)
+ (let ([x (datum->syntax #f x)])
+ (with ([this-syntax x])
+ (parse:clauses x clauses one-template ctx)))))]))
+
+(define-syntax (define/syntax-parse stx)
+ (syntax-case stx ()
+ [(define/syntax-parse pattern . rest)
+ (with-disappeared-uses
+ (let-values ([(rest pattern defs)
+ (parse-pattern+sides #'pattern
+ #'rest
+ #:splicing? #f
+ #:decls (new-declenv null)
+ #:context stx)])
+ (define no-fail? (patterns-cannot-fail? (list pattern)))
+ (let ([expr
+ (syntax-case rest ()
+ [( expr ) #'expr]
+ [_ (raise-syntax-error #f "bad syntax" stx)])]
+ [attrs (pattern-attrs pattern)])
+ (with-syntax ([(a ...) attrs]
+ [(#s(attr name _ _) ...) attrs]
+ [pattern pattern]
+ [es0 (if no-fail? #'#f #'#t)]
+ [(def ...) defs]
+ [expr expr])
+ #'(defattrs/unpack (a ...)
+ (let* ([x (datum->syntax #f expr)]
+ [cx x]
+ [pr (ps-empty x x)]
+ [es es0]
+ [fh0 (syntax-patterns-fail
+ (normalize-context 'define/syntax-parse
+ '|define/syntax-parse pattern|
+ x))])
+ (parameterize ((current-syntax-context x))
+ def ...
+ (#%expression
+ (with ([fail-handler fh0]
+ [cut-prompt fh0]
+ [undo-stack null])
+ (parse:S x cx pattern pr es
+ (list (attribute name) ...)))))))))))]))
+
+;; ============================================================
+
+#|
+Parsing protocols:
+
+(parse:<X> <X-args> pr es success-expr) : Ans
+
+ <S-args> : x cx
+ <H-args> : x cx rest-x rest-cx rest-pr
+ <EH-args> : x cx ???
+ <A-args> : x cx
+
+ x is term to parse, usually syntax but can be pair/null (stx-list?) in cdr patterns
+ cx is most recent syntax object: if x must be coerced to syntax, use cx as lexctx and src
+ pr, es are progress and expectstack, respectively
+ rest-x, rest-cx, rest-pr are variable names to bind in context of success-expr
+
+(stxclass-parser x cx pr es undos fail-handler cut-prompt role success-proc arg ...) : Ans
+
+ success-proc:
+ for stxclass, is (fail-handler undos attr-value ... -> Ans)
+ for splicing-stxclass, is (undos fail-handler rest-x rest-cx rest-pr attr-value -> Ans)
+ fail-handler, cut-prompt : undos failure -> Ans
+
+Fail-handler is normally represented with stxparam 'fail-handler', but must be
+threaded through stxclass calls (in through stxclass-parser, out through
+success-proc) to support backtracking. Cut-prompt is never changed within
+stxclass or within alternative, so no threading needed.
+
+The undo stack is normally represented with stxparam 'undo-stack', but must be
+threaded through stxclass calls (like fail-handler). A failure handler closes
+over a base undo stack and receives an extended current undo stack; the failure
+handler unwinds effects by performing every action in the difference between
+them and then restores the saved undo stack.
+
+Usually sub-patterns processed in tail position, but *can* do non-tail calls for:
+ - ~commit
+ - var of stxclass with ~commit
+It is also safe to keep normal tail-call protocol and just adjust fail-handler.
+There is no real benefit to specializing ~commit, since it does not involve
+creating a success closure.
+
+Some optimizations:
+ - commit protocol for stxclasses (but not ~commit, no point)
+ - avoid continue-vs-end choice point in (EH ... . ()) by eager pair check
+ - integrable stxclasses, specialize ellipses of integrable stxclasses
+ - pattern lists that cannot fail set es=#f to disable ExpectStack allocation
+|#
+
+;; ----
+
+(begin-for-syntax
+ (define (wash stx)
+ (syntax-e stx))
+ (define (wash-list washer stx)
+ (let ([l (stx->list stx)])
+ (unless l (raise-type-error 'wash-list "stx-list" stx))
+ (map washer l)))
+ (define (wash-iattr stx)
+ (with-syntax ([#s(attr name depth syntax?) stx])
+ (attr #'name (wash #'depth) (wash #'syntax?))))
+ (define (wash-sattr stx)
+ (with-syntax ([#s(attr name depth syntax?) stx])
+ (attr (wash #'name) (wash #'depth) (wash #'syntax?))))
+ (define (wash-iattrs stx)
+ (wash-list wash-iattr stx))
+ (define (wash-sattrs stx)
+ (wash-list wash-sattr stx))
+ (define (generate-n-temporaries n)
+ (generate-temporaries
+ (for/list ([i (in-range n)])
+ (string->symbol (format "g~sx" i))))))
+
+;; ----
+
+#|
+Conventions:
+ - rhs : RHS
+ - iattr : IAttr
+ - relsattr : SAttr
+ - splicing? : bool
+ - x : id (var)
+ - cx : id (var, may be shadowed)
+ - pr : id (var, may be shadowed)
+ - es : id (var, may be shadowed)
+ - success : var (bound to success procedure)
+ - k : expr
+ - rest-x, rest-cx, rest-pr : id (to be bound)
+ - fh, cp, rl : id (var)
+|#
+
+(begin-for-syntax
+ (define (rewrite-formals fstx x-id rl-id)
+ (with-syntax ([x x-id]
+ [rl rl-id])
+ (let loop ([fstx fstx])
+ (syntax-case fstx ()
+ [([kw arg default] . more)
+ (keyword? (syntax-e #'kw))
+ (cons #'(kw arg (with ([this-syntax x] [this-role rl]) default))
+ (loop #'more))]
+ [([arg default] . more)
+ (not (keyword? (syntax-e #'kw)))
+ (cons #'(arg (with ([this-syntax x] [this-role rl]) default))
+ (loop #'more))]
+ [(formal . more)
+ (cons #'formal (loop #'more))]
+ [_ fstx])))))
+
+;; (with-maybe-delimit-cut bool expr)
+(define-syntax with-maybe-delimit-cut
+ (syntax-rules ()
+ [(wmdc #t k)
+ (with ([cut-prompt fail-handler]) k)]
+ [(wmdc #f k)
+ k]))
+
+;; (variant-success relsattrs variant (also:id ...) success bool) : expr[Ans]
+(define-syntax (variant-success stx)
+ (syntax-case stx ()
+ [(variant-success relsattrs iattrs (also ...) success cp0 commit?)
+ #`(with-maybe-reset-fail commit? cp0
+ (base-success-expr iattrs relsattrs (also ...) success))]))
+
+;; (with-maybe-reset-fail bool id expr)
+(define-syntax with-maybe-reset-fail
+ (syntax-rules ()
+ [(wmrs #t cp0 k)
+ (with ([fail-handler cp0]) k)]
+ [(wmrs #f cp0 k)
+ k]))
+
+;; (base-success-expr iattrs relsattrs (also:id ...) success) : expr[Ans]
+(define-syntax (base-success-expr stx)
+ (syntax-case stx ()
+ [(base-success-expr iattrs relsattrs (also ...) success)
+ (let ([reliattrs
+ (reorder-iattrs (wash-sattrs #'relsattrs)
+ (wash-iattrs #'iattrs))])
+ (with-syntax ([(#s(attr name _ _) ...) reliattrs])
+ #'(success fail-handler undo-stack also ... (attribute name) ...)))]))
+
+;; ----
+
+;; (parse:clauses x clauses ctx)
+(define-syntax (parse:clauses stx)
+ (syntax-case stx ()
+ [(parse:clauses x clauses body-mode ctx)
+ ;; if templates? is true, expect one form after kwargs in clause, wrap it with syntax
+ ;; otherwise, expect non-empty body sequence (defs and exprs)
+ (with-disappeared-uses
+ (with-txlifts
+ (lambda ()
+ (define who
+ (syntax-case #'ctx ()
+ [(m . _) (identifier? #'m) #'m]
+ [_ 'syntax-parse]))
+ (define-values (chunks clauses-stx)
+ (parse-keyword-options #'clauses parse-directive-table
+ #:context #'ctx
+ #:no-duplicates? #t))
+ (define context
+ (options-select-value chunks '#:context #:default #'x))
+ (define colon-notation?
+ (not (assq '#:disable-colon-notation chunks)))
+ (define track-literals?
+ (or (assq '#:track-literals chunks)
+ (eq? (syntax-e #'body-mode) 'one-template)))
+ (define-values (decls0 defs)
+ (get-decls+defs chunks #:context #'ctx))
+ ;; for-clause : stx -> (values pattern stx (listof stx))
+ (define (for-clause clause)
+ (syntax-case clause ()
+ [[p . rest]
+ (let-values ([(rest pattern defs2)
+ (parameterize ((stxclass-colon-notation? colon-notation?))
+ (parse-pattern+sides #'p #'rest
+ #:splicing? #f
+ #:decls decls0
+ #:context #'ctx))])
+ (let ([body-expr
+ (case (syntax-e #'body-mode)
+ ((one-template)
+ (syntax-case rest ()
+ [(template)
+ #'(syntax template)]
+ [_ (raise-syntax-error #f "expected exactly one template" #'ctx)]))
+ ((body-sequence)
+ (syntax-case rest ()
+ [(e0 e ...)
+ ;; Should we use a shadower (works on the whole file, unhygienically),
+ ;; or use the context of the syntax-parse identifier?
+ (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)])
+ (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro
+ #`(let () (#,the-#%intdef-begin e0 e ...))
+ #'(let () e0 e ...)))]
+ [_ (raise-syntax-error #f "expected non-empty clause body"
+ #'ctx clause)]))
+ (else
+ (raise-syntax-error #f "internal error: unknown body mode" #'ctx #'body-mode)))])
+ (values pattern body-expr defs2)))]
+ [_ (raise-syntax-error #f "expected clause" #'ctx clause)]))
+ (define (wrap-track-literals stx)
+ (if track-literals? (quasisyntax/loc stx (track-literals '#,who #,stx)) stx))
+ (unless (stx-list? clauses-stx)
+ (raise-syntax-error #f "expected sequence of clauses" #'ctx))
+ (define-values (patterns body-exprs defs2s)
+ (for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))])
+ (for-clause clause)))
+ (define no-fail? (patterns-cannot-fail? patterns))
+ (when no-fail? (log-syntax-parse-debug "cannot fail: ~e" #'ctx))
+ (with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)])
+ #`(let* ([ctx0 (normalize-context '#,who #,context x)]
+ [pr (ps-empty x (cadr ctx0))]
+ [es #,(if no-fail? #'#f #'#t)]
+ [cx x]
+ [fh0 (syntax-patterns-fail ctx0)])
+ def ...
+ (parameterize ((current-syntax-context (cadr ctx0))
+ (current-state '#hasheq())
+ (current-state-writable? #f))
+ #,(wrap-track-literals
+ #`(with ([fail-handler fh0]
+ [cut-prompt fh0]
+ [undo-stack null])
+ #,(cond [(pair? patterns)
+ (with-syntax ([matrix
+ (optimize-matrix
+ (for/list ([pattern (in-list patterns)]
+ [body-expr (in-list body-exprs)])
+ (pk1 (list pattern) body-expr)))])
+ #'(parse:matrix ((x cx pr es)) matrix))
+ #|
+ (with-syntax ([(alternative ...)
+ (for/list ([pattern (in-list patterns)]
+ [body-expr (in-list body-exprs)])
+ #`(parse:S x cx #,pattern pr es #,body-expr))])
+ #`(try alternative ...))
+ |#]
+ [else
+ #`(fail (failure* pr es))])))))))))]))
+
+;; ----
+
+;; (parse:matrix ((x cx pr es) ...) (PK ...)) : expr[Ans]
+;; (parse:matrix (in1 ... inN) (#s(pk1 (P11 ... P1N) e1) ... #s(pk1 (PM1 ... PMN) eM)))
+;; represents the matching matrix
+;; [_in1_..._inN_|____]
+;; [ P11 ... P1N | e1 ]
+;; [ : : | : ]
+;; [ PM1 ... PMN | eM ]
+
+(define-syntax (parse:matrix stx)
+ (syntax-case stx ()
+ [(parse:matrix ins (pk ...))
+ #'(try (parse:pk ins pk) ...)]))
+
+(define-syntax (parse:pk stx)
+ (syntax-case stx ()
+ [(parse:pk () #s(pk1 () k))
+ #'k]
+ [(parse:pk ((x cx pr es) . ins) #s(pk1 (pat1 . pats) k))
+ #'(parse:S x cx pat1 pr es (parse:pk ins #s(pk1 pats k)))]
+ [(parse:pk ((x cx pr es) . ins) #s(pk/same pat1 inner))
+ #'(parse:S x cx pat1 pr es (parse:matrix ins inner))]
+ [(parse:pk ((x cx pr es) . ins) #s(pk/pair inner))
+ #'(let-values ([(datum tcx)
+ (if (syntax? x)
+ (values (syntax-e x) x)
+ (values x cx))])
+ (if (pair? datum)
+ (let ([hx (car datum)]
+ [hcx (car datum)]
+ [hpr (ps-add-car pr)]
+ [tx (cdr datum)]
+ [tpr (ps-add-cdr pr)])
+ (parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner))
+ (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)])
+ (fail (failure* pr es*)))))]
+ [(parse:pk (in1 . ins) #s(pk/and inner))
+ #'(parse:matrix (in1 in1 . ins) inner)]))
+
+(define-syntax (first-desc:matrix stx)
+ (syntax-case stx ()
+ [(fdm (#s(pk1 (pat1 . pats) k)))
+ #'(first-desc:S pat1)]
+ [(fdm (#s(pk/same pat1 pks)))
+ #'(first-desc:S pat1)]
+ [(fdm (pk ...)) ;; FIXME
+ #'#f]))
+
+;; ----
+
+;; (parse:S x cx S-pattern pr es k) : expr[Ans]
+;; In k: attrs(S-pattern) are bound.
+(define-syntax (parse:S stx)
+ (syntax-case stx ()
+ [(parse:S x cx pattern0 pr es k)
+ (syntax-case #'pattern0 ()
+ [#s(pat:seq-end)
+ #`(k x cx pr)]
+ [#s(pat:any)
+ #'k]
+ [#s(pat:svar name)
+ #'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
+ k)]
+ [#s(pat:var/p name parser argu (nested-a ...) role
+ #s(scopts attr-count commit? _delimit? _desc))
+ (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
+ [(name-attr ...)
+ (if (identifier? #'name)
+ #'([#s(attr name 0 #t) (datum->syntax cx x cx)])
+ #'())])
+ (if (not (syntax-e #'commit?))
+ ;; The normal protocol
+ #'(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role
+ (lambda (fh undos av ...)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ (with ([fail-handler fh] [undo-stack undos])
+ k))))
+ argu)
+ ;; The commit protocol
+ ;; (Avoids putting k in procedure)
+ #'(let-values ([(fs undos av ...)
+ (with ([fail-handler
+ (lambda (undos fs)
+ (unwind-to undos undo-stack)
+ (values fs undo-stack (let ([av #f]) av) ...))])
+ (with ([cut-prompt fail-handler])
+ (app-argu parser x cx pr es undo-stack
+ fail-handler cut-prompt role
+ (lambda (fh undos av ...) (values #f undos av ...))
+ argu)))])
+ (if fs
+ (fail fs)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ (with ([undo-stack undos])
+ k)))))))]
+ [#s(pat:reflect obj argu attr-decls name (nested-a ...))
+ (with-syntax ([(name-attr ...)
+ (if (identifier? #'name)
+ #'([#s(attr name 0 #t) (datum->syntax cx x cx)])
+ #'())])
+ (with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
+ #'(let ([parser (reflect-parser obj 'arity 'attr-decls #f)])
+ (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f
+ (lambda (fh undos . result)
+ (let-attributes (name-attr ...)
+ (let/unpack ((nested-a ...) result)
+ (with ([fail-handler fh] [undo-stack undos])
+ k))))
+ argu))))]
+ [#s(pat:datum datum)
+ (with-syntax ([unwrap-x
+ (if (atomic-datum-stx? #'datum)
+ #'(if (syntax? x) (syntax-e x) x)
+ #'(syntax->datum (datum->syntax #f x)))])
+ #`(let ([d unwrap-x])
+ (if (equal? d (quote datum))
+ k
+ (fail (failure* pr (es-add-atom 'datum es))))))]
+ [#s(pat:literal literal input-phase lit-phase)
+ #`(if (and (identifier? x)
+ (free-identifier=? x (quote-syntax literal) input-phase lit-phase))
+ (with ([undo-stack (cons (current-state) undo-stack)])
+ (state-cons! 'literals x)
+ k)
+ (fail (failure* pr (es-add-literal (quote-syntax literal) es))))]
+ [#s(pat:action action subpattern)
+ #'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))]
+ [#s(pat:head head tail)
+ #`(parse:H x cx rest-x rest-cx rest-pr head pr es
+ (parse:S rest-x rest-cx tail rest-pr es k))]
+ [#s(pat:dots head tail)
+ #`(parse:dots x cx head tail pr es k)]
+ [#s(pat:and subpatterns)
+ (for/fold ([k #'k]) ([subpattern (in-list (reverse (syntax->list #'subpatterns)))])
+ #`(parse:S x cx #,subpattern pr es #,k))]
+ [#s(pat:or (a ...) (subpattern ...) (subattrs ...))
+ (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
+ #`(let ([success
+ (lambda (fh undos id ...)
+ (let-attributes ([a id] ...)
+ (with ([fail-handler fh] [undo-stack undos])
+ k)))])
+ (try (parse:S x cx subpattern pr es
+ (disjunct subattrs success () (id ...)))
+ ...)))]
+ [#s(pat:not subpattern)
+ #`(let* ([fh0 fail-handler]
+ [pr0 pr]
+ [es0 es]
+ [fail-to-succeed
+ (lambda (undos fs) (unwind-to undos undo-stack) k)])
+ ;; ~not implicitly prompts to be safe,
+ ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
+ ;; (statically checked!)
+ (with ([fail-handler fail-to-succeed]
+ [cut-prompt fail-to-succeed]) ;; to be safe
+ (parse:S x cx subpattern pr es
+ (fh0 undo-stack (failure* pr0 es0)))))]
+ [#s(pat:pair head tail)
+ #`(let ([datum (if (syntax? x) (syntax-e x) x)]
+ [cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?!
+ (if (pair? datum)
+ (let ([hx (car datum)]
+ [hcx (car datum)]
+ [hpr (ps-add-car pr)]
+ [tx (cdr datum)]
+ [tpr (ps-add-cdr pr)])
+ (parse:S hx hcx head hpr es
+ (parse:S tx cx tail tpr es k)))
+ (let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)])
+ (fail (failure* pr es*)))))]
+ [#s(pat:vector subpattern)
+ #`(let ([datum (if (syntax? x) (syntax-e x) x)])
+ (if (vector? datum)
+ (let ([datum (vector->list datum)]
+ [vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ???
+ [pr* (ps-add-unvector pr)])
+ (parse:S datum vcx subpattern pr* es k))
+ (fail (failure* pr es))))]
+ [#s(pat:box subpattern)
+ #`(let ([datum (if (syntax? x) (syntax-e x) x)])
+ (if (box? datum)
+ (let ([datum (unbox datum)]
+ [bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ???
+ [pr* (ps-add-unbox pr)])
+ (parse:S datum bcx subpattern pr* es k))
+ (fail (failure* pr es))))]
+ [#s(pat:pstruct key subpattern)
+ #`(let ([datum (if (syntax? x) (syntax-e x) x)])
+ (if (let ([xkey (prefab-struct-key datum)])
+ (and xkey (equal? xkey 'key)))
+ (let ([datum (cdr (vector->list (struct->vector datum)))]
+ [scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ???
+ [pr* (ps-add-unpstruct pr)])
+ (parse:S datum scx subpattern pr* es k))
+ (fail (failure* pr es))))]
+ [#s(pat:describe pattern description transparent? role)
+ #`(let ([es* (es-add-thing pr description transparent? role es)]
+ [pr* (if 'transparent? pr (ps-add-opaque pr))])
+ (parse:S x cx pattern pr* es* k))]
+ [#s(pat:delimit pattern)
+ #`(let ([cp0 cut-prompt])
+ (with ([cut-prompt fail-handler])
+ (parse:S x cx pattern pr es (with ([cut-prompt cp0]) k))))]
+ [#s(pat:commit pattern)
+ #`(let ([fh0 fail-handler]
+ [cp0 cut-prompt])
+ (with ([cut-prompt fh0])
+ (parse:S x cx pattern pr es
+ (with ([cut-prompt cp0]
+ [fail-handler fh0])
+ k))))]
+ [#s(pat:ord pattern group index)
+ #`(let ([pr* (ps-add pr '#s(ord group index))])
+ (parse:S x cx pattern pr* es k))]
+ [#s(pat:post pattern)
+ #`(let ([pr* (ps-add-post pr)])
+ (parse:S x cx pattern pr* es k))]
+ [#s(pat:integrated name predicate description role)
+ (with-syntax ([(name-attr ...)
+ (if (identifier? #'name)
+ #'([#s(attr name 0 #t) x*])
+ #'())])
+ #'(let ([x* (datum->syntax cx x cx)])
+ (if (predicate x*)
+ (let-attributes (name-attr ...) k)
+ (let ([es* (es-add-thing pr 'description #t role es)])
+ (fail (failure* pr es*))))))]
+ [_ (wrong-syntax stx "internal error: bad S pattern: ~e" #'pattern0)])]))
+
+;; (first-desc:S S-pattern) : expr[FirstDesc]
+(define-syntax (first-desc:S stx)
+ (syntax-case stx ()
+ [(fds p)
+ (syntax-case #'p ()
+ [#s(pat:any)
+ #''(any)]
+ [#s(pat:svar name)
+ #''(any)]
+ [#s(pat:var/p _ _ _ _ _ #s(scopts _ _ _ desc))
+ #'(quote desc)]
+ [#s(pat:datum d)
+ #''(datum d)]
+ [#s(pat:literal id _ip _lp)
+ #''(literal id)]
+ [#s(pat:describe _p desc _t? _role)
+ #`(quote #,(or (constant-desc #'desc) #'#f))]
+ [#s(pat:delimit pattern)
+ #'(first-desc:S pattern)]
+ [#s(pat:commit pattern)
+ #'(first-desc:S pattern)]
+ [#s(pat:ord pattern _ _)
+ #'(first-desc:S pattern)]
+ [#s(pat:post pattern)
+ #'(first-desc:S pattern)]
+ [#s(pat:integrated _name _pred description _role)
+ #''description]
+ [_ #'#f])]))
+
+;; (first-desc:H HeadPattern) : Expr
+(define-syntax (first-desc:H stx)
+ (syntax-case stx ()
+ [(fdh hpat)
+ (syntax-case #'hpat ()
+ [#s(hpat:single sp) #'(first-desc:S sp)]
+ [#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)]
+ [#s(hpat:seq lp) #'(first-desc:L lp)]
+ [#s(hpat:describe _hp desc _t? _r)
+ #`(quote #,(or (constant-desc #'desc) #'#f))]
+ [#s(hpat:delimit hp) #'(first-desc:H hp)]
+ [#s(hpat:commit hp) #'(first-desc:H hp)]
+ [#s(hpat:ord hp _ _) #'(first-desc:H hp)]
+ [#s(hpat:post hp) #'(first-desc:H hp)]
+ [_ #'#f])]))
+
+(define-syntax (first-desc:L stx)
+ (syntax-case stx ()
+ [(fdl lpat)
+ (syntax-case #'lpat ()
+ [#s(pat:pair sp lp) #'(first-desc:S sp)]
+ [_ #'#f])]))
+
+;; (disjunct (iattr ...) success (pre:expr ...) (id:id ...)) : expr[Ans]
+(define-syntax (disjunct stx)
+ (syntax-case stx ()
+ [(disjunct (#s(attr sub-id _ _) ...) success (pre ...) (id ...))
+ (with-syntax ([(alt-sub-id ...) (generate-temporaries #'(sub-id ...))])
+ #`(let ([alt-sub-id (attribute sub-id)] ...)
+ (let ([id #f] ...)
+ (let ([sub-id alt-sub-id] ...)
+ (success fail-handler undo-stack pre ... id ...)))))]))
+
+;; (parse:A x cx A-pattern pr es k) : expr[Ans]
+;; In k: attrs(A-pattern) are bound.
+(define-syntax (parse:A stx)
+ (syntax-case stx ()
+ [(parse:A x cx pattern0 pr es k)
+ (syntax-case #'pattern0 ()
+ [#s(action:and (action ...))
+ (for/fold ([k #'k]) ([action (in-list (reverse (syntax->list #'(action ...))))])
+ #`(parse:A x cx #,action pr es #,k))]
+ [#s(action:cut)
+ #'(with ([fail-handler cut-prompt]) k)]
+ [#s(action:bind a expr)
+ #'(let-attributes ([a (wrap-user-code expr)]) k)]
+ [#s(action:fail condition message)
+ #`(let ([c (wrap-user-code condition)])
+ (if c
+ (let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)]
+ [es* (es-add-message message es)])
+ (fail (failure* pr* es*)))
+ k))]
+ [#s(action:parse pattern expr)
+ #`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))]
+ [cy y]
+ [pr* (ps-add-stx pr y)])
+ (parse:S y cy pattern pr* es k))]
+ [#s(action:do (stmt ...))
+ #'(parameterize ((current-state-writable? #t))
+ (let ([init-state (current-state)])
+ (no-shadow stmt) ...
+ (parameterize ((current-state-writable? #f))
+ (with ([undo-stack (maybe-add-state-undo init-state (current-state) undo-stack)])
+ (#%expression k)))))]
+ [#s(action:undo (stmt ...))
+ #'(with ([undo-stack (cons (lambda () stmt ... (void)) undo-stack)]
+ [cut-prompt illegal-cut-error])
+ k)]
+ [#s(action:ord pattern group index)
+ #'(let ([pr* (ps-add pr '#s(ord group index))])
+ (parse:A x cx pattern pr* es k))]
+ [#s(action:post pattern)
+ #'(let ([pr* (ps-add-post pr)])
+ (parse:A x cx pattern pr* es k))]
+ [_ (wrong-syntax stx "internal error: bad A pattern: ~e" #'pattern0)])]))
+
+;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k)
+;; In k: rest, rest-pr, attrs(H-pattern) are bound.
+(define-syntax (parse:H stx)
+ (syntax-case stx ()
+ [(parse:H x cx rest-x rest-cx rest-pr head pr es k)
+ (syntax-case #'head ()
+ [#s(hpat:single pattern)
+ #'(parse:S x cx
+ ;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
+ #s(pat:pair pattern #s(pat:seq-end))
+ pr es (lambda (rest-x rest-cx rest-pr) k))]
+ [#s(hpat:describe pattern description transparent? role)
+ #`(let ([es* (es-add-thing pr description transparent? role es)]
+ [pr* (if 'transparent? pr (ps-add-opaque pr))])
+ (parse:H x cx rest-x rest-cx rest-pr pattern pr* es*
+ (let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
+ k)))]
+ [#s(hpat:var/p name parser argu (nested-a ...) role
+ #s(scopts attr-count commit? _delimit? _desc))
+ (with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
+ [(name-attr ...)
+ (if (identifier? #'name)
+ #'([#s(attr name 0 #t)
+ (stx-list-take x (ps-difference pr rest-pr))])
+ #'())])
+ (if (not (syntax-e #'commit?))
+ ;; The normal protocol
+ #`(app-argu parser x cx pr es undo-stack fail-handler cut-prompt role
+ (lambda (fh undos rest-x rest-cx rest-pr av ...)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ (with ([fail-handler fh] [undo-stack undos])
+ k))))
+ argu)
+ ;; The commit protocol
+ ;; (Avoids putting k in procedure)
+ #'(let-values ([(fs undos rest-x rest-cx rest-pr av ...)
+ (with ([fail-handler
+ (lambda (undos fs)
+ (unwind-to undos undo-stack)
+ (values fs undo-stack #f #f #f (let ([av #f]) av) ...))])
+ (with ([cut-prompt fail-handler])
+ (app-argu parser x cx pr es undo-stack
+ fail-handler cut-prompt role
+ (lambda (fh undos rest-x rest-cx rest-pr av ...)
+ (values #f undos rest-x rest-cx rest-pr av ...))
+ argu)))])
+ (if fs
+ (fail fs)
+ (let-attributes (name-attr ...)
+ (let-attributes* ((nested-a ...) (av ...))
+ (with ([undo-stack undos])
+ k)))))))]
+ [#s(hpat:reflect obj argu attr-decls name (nested-a ...))
+ (with-syntax ([(name-attr ...)
+ (if (identifier? #'name)
+ #'([#s(attr name 0 #t)
+ (stx-list-take x (ps-difference pr rest-pr))])
+ #'())])
+ (with-syntax ([arity (arguments->arity (syntax->datum #'argu))])
+ #'(let ([parser (reflect-parser obj 'arity 'attr-decls #t)])
+ (app-argu parser x cx pr es undo-stack fail-handler cut-prompt #f
+ (lambda (fh undos rest-x rest-cx rest-pr . result)
+ (let-attributes (name-attr ...)
+ (let/unpack ((nested-a ...) result)
+ (with ([fail-handler fh] [undo-stack undos])
+ k))))
+ argu))))]
+ [#s(hpat:and head single)
+ #`(let ([cx0 cx])
+ (parse:H x cx rest-x rest-cx rest-pr head pr es
+ (let ([lst (stx-list-take x (ps-difference pr rest-pr))])
+ (parse:S lst cx0 single pr es k))))]
+ [#s(hpat:or (a ...) (subpattern ...) (subattrs ...))
+ (with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
+ #`(let ([success
+ (lambda (fh undos rest-x rest-cx rest-pr id ...)
+ (let-attributes ([a id] ...)
+ (with ([fail-handler fh] [undo-stack undos])
+ k)))])
+ (try (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
+ (disjunct subattrs success (rest-x rest-cx rest-pr) (id ...)))
+ ...)))]
+ [#s(hpat:seq pattern)
+ #'(parse:S x cx pattern pr es (lambda (rest-x rest-cx rest-pr) k))]
+ [#s(hpat:action action subpattern)
+ #'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))]
+ [#s(hpat:delimit pattern)
+ #'(let ([cp0 cut-prompt])
+ (with ([cut-prompt fail-handler])
+ (parse:H x cx rest-x rest-cx rest-pr pattern pr es
+ (with ([cut-prompt cp0]) k))))]
+ [#s(hpat:commit pattern)
+ #`(let ([fh0 fail-handler]
+ [cp0 cut-prompt])
+ (with ([cut-prompt fh0])
+ (parse:H x cx rest-x rest-cx rest-pr pattern pr es
+ (with ([cut-prompt cp0]
+ [fail-handler fh0])
+ k))))]
+ [#s(hpat:ord pattern group index)
+ #`(let ([pr* (ps-add pr '#s(ord group index))])
+ (parse:H x cx rest-x rest-cx rest-pr pattern pr* es
+ (let ([rest-pr (ps-pop-ord rest-pr)]) k)))]
+ [#s(hpat:post pattern)
+ #'(let ([pr* (ps-add-post pr)])
+ (parse:H x cx rest-x rest-cx rest-pr pattern pr* es
+ (let ([rest-pr (ps-pop-post rest-pr)]) k)))]
+ [#s(hpat:peek pattern)
+ #`(let ([saved-x x] [saved-cx cx] [saved-pr pr])
+ (parse:H x cx dummy-x dummy-cx dummy-pr pattern pr es
+ (let ([rest-x saved-x] [rest-cx saved-cx] [rest-pr saved-pr])
+ k)))]
+ [#s(hpat:peek-not subpattern)
+ #`(let* ([fh0 fail-handler]
+ [pr0 pr]
+ [es0 es]
+ [fail-to-succeed
+ (lambda (undos fs)
+ (unwind-to undos undo-stack)
+ (let ([rest-x x]
+ [rest-cx cx]
+ [rest-pr pr])
+ k))])
+ ;; ~not implicitly prompts to be safe,
+ ;; but ~! not allowed within ~not (unless within ~delimit-cut, etc)
+ ;; (statically checked!)
+ (with ([fail-handler fail-to-succeed]
+ [cut-prompt fail-to-succeed]) ;; to be safe
+ (parse:H x cx rest-x rest-cx rest-pr subpattern pr es
+ (fh0 undo-stack (failure* pr0 es0)))))]
+ [_ (wrong-syntax stx "internal error: bad H pattern: ~e" #'head)])]))
+
+;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans]
+;; In k: attrs(EH-pattern, S-pattern) are bound.
+(define-syntax (parse:dots stx)
+ (syntax-case stx ()
+ ;; == Specialized cases
+ ;; -- (x ... . ())
+ [(parse:dots x cx (#s(ehpat (attr0) #s(hpat:single #s(pat:svar name)) #f #f))
+ #s(pat:datum ()) pr es k)
+ #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)])
+ (case status
+ ((ok) (let-attributes ([attr0 result]) k))
+ (else (fail result))))]
+ ;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
+ [(parse:dots x cx (#s(ehpat (attr0) #s(hpat:single #s(pat:integrated _name pred? desc role)) #f #f))
+ #s(pat:datum ()) pr es k)
+ #'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)])
+ (case status
+ ((ok) (let-attributes ([attr0 result]) k))
+ (else (fail result))))]
+ ;; -- (x:sc ... . ()) where sc is a stxclass with commit
+ ;; Since head pattern does commit, no need to thread fail-handler, cut-prompt through.
+ ;; Microbenchmark suggests this isn't a useful specialization
+ ;; (probably try-or-pair/null-check already does the useful part)
+ ;; == General case
+ [(parse:dots x cx (#s(ehpat head-attrs head head-repc check-null?) ...) tail pr es k)
+ (let ()
+ (define repcs (wash-list wash #'(head-repc ...)))
+ (define rep-ids (for/list ([repc (in-list repcs)])
+ (and repc (generate-temporary 'rep))))
+ (define rel-repcs (filter values repcs))
+ (define rel-rep-ids (filter values rep-ids))
+ (define rel-heads (for/list ([head (in-list (syntax->list #'(head ...)))]
+ [repc (in-list repcs)]
+ #:when repc)
+ head))
+ (define aattrs
+ (for/list ([head-attrs (in-list (syntax->list #'(head-attrs ...)))]
+ [repc (in-list repcs)]
+ #:when #t
+ [a (in-list (wash-iattrs head-attrs))])
+ (cons a repc)))
+ (define attrs (map car aattrs))
+ (define attr-repcs (map cdr aattrs))
+ (define ids (map attr-name attrs))
+ (define tail-pattern-is-null? (equal? (syntax->datum #'tail) '#s(pat:datum ())))
+ (with-syntax ([(id ...) ids]
+ [(alt-id ...) (generate-temporaries ids)]
+ [reps rel-rep-ids]
+ [(head-rep ...) rep-ids]
+ [(rel-rep ...) rel-rep-ids]
+ [(rel-repc ...) rel-repcs]
+ [(rel-head ...) rel-heads]
+ [(a ...) attrs]
+ [(attr-repc ...) attr-repcs]
+ [do-pair/null?
+ ;; FIXME: do pair/null check only if no nullable head patterns
+ ;; (and tail-pattern-is-null? (andmap not (syntax->datum #'(nullable? ...))))
+ tail-pattern-is-null?])
+ (define/with-syntax alt-map #'((id . alt-id) ...))
+ (define/with-syntax loop-k
+ #'(dots-loop dx* dcx* loop-pr* undo-stack fail-handler rel-rep ... alt-id ...))
+ #`(let ()
+ ;; dots-loop : stx progress rel-rep ... alt-id ... -> Ans
+ (define (dots-loop dx dcx loop-pr undos fh rel-rep ... alt-id ...)
+ (with ([fail-handler fh] [undo-stack undos])
+ (try-or-pair/null-check do-pair/null? dx dcx loop-pr es
+ (try (parse:EH dx dcx loop-pr head-attrs check-null? head-repc dx* dcx* loop-pr*
+ alt-map head-rep head es loop-k)
+ ...)
+ (cond [(< rel-rep (rep:min-number rel-repc))
+ (let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)])
+ (fail (failure* loop-pr es)))]
+ ...
+ [else
+ (let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
+ (parse:S dx dcx tail loop-pr es k))]))))
+ (let ([rel-rep 0] ...
+ [alt-id (rep:initial-value attr-repc)] ...)
+ (dots-loop x cx pr undo-stack fail-handler rel-rep ... alt-id ...)))))]))
+
+;; (try-or-pair/null-check bool x cx es pr pair-alt maybe-null-alt)
+(define-syntax try-or-pair/null-check
+ (syntax-rules ()
+ [(topc #t x cx pr es pair-alt null-alt)
+ (cond [(stx-pair? x) pair-alt]
+ [(stx-null? x) null-alt]
+ [else (fail (failure* pr es))])]
+ [(topc _ x cx pr es alt1 alt2)
+ (try alt1 alt2)]))
+
+;; (parse:EH x cx pr repc x* cx* pr* alts rep H-pattern es k) : expr[Ans]
+;; In k: x*, cx*, pr*, alts`attrs(H-pattern) are bound and rep is shadowed.
+(define-syntax (parse:EH stx)
+ (syntax-case stx ()
+ [(parse:EH x cx pr attrs check-null? repc x* cx* pr* alts rep head es k)
+ (let ()
+ (define/with-syntax k*
+ (let* ([main-attrs (wash-iattrs #'attrs)]
+ [ids (map attr-name main-attrs)]
+ [alt-ids
+ (let ([table (make-bound-id-table)])
+ (for ([entry (in-list (syntax->list #'alts))])
+ (let ([entry (syntax-e entry)])
+ (bound-id-table-set! table (car entry) (cdr entry))))
+ (for/list ([id (in-list ids)]) (bound-id-table-ref table id)))])
+ (with-syntax ([(id ...) ids]
+ [(alt-id ...) alt-ids])
+ #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
+ #,(if (syntax->datum #'check-null?)
+ #'(if (zero? (ps-difference pr pr*)) (error/null-eh-match) k)
+ #'k)))))
+ (syntax-case #'repc ()
+ [#f #`(parse:H x cx x* cx* pr* head pr es k*)]
+ [_ #`(parse:H x cx x* cx* pr* head pr es
+ (if (< rep (rep:max-number repc))
+ (let ([rep (add1 rep)]) k*)
+ (let ([es* (expectation-of-reps/too-many es rep repc)])
+ (fail (failure* pr* es*)))))]))]))
+
+;; (rep:initial-value RepConstraint) : expr
+(define-syntax (rep:initial-value stx)
+ (syntax-case stx ()
+ [(_ #s(rep:once _ _ _)) #'#f]
+ [(_ #s(rep:optional _ _ _)) #'#f]
+ [(_ _) #'null]))
+
+;; (rep:finalize RepConstraint expr) : expr
+(define-syntax (rep:finalize stx)
+ (syntax-case stx ()
+ [(_ a #s(rep:optional _ _ defaults) v)
+ (with-syntax ([#s(attr name _ _) #'a]
+ [(#s(action:bind da de) ...) #'defaults])
+ (let ([default
+ (for/or ([da (in-list (syntax->list #'(da ...)))]
+ [de (in-list (syntax->list #'(de ...)))])
+ (with-syntax ([#s(attr dname _ _) da])
+ (and (bound-identifier=? #'name #'dname) de)))])
+ (if default
+ #`(or v #,default)
+ #'v)))]
+ [(_ a #s(rep:once _ _ _) v) #'v]
+ [(_ a _ v) #'(reverse v)]))
+
+;; (rep:min-number RepConstraint) : expr
+(define-syntax (rep:min-number stx)
+ (syntax-case stx ()
+ [(_ #s(rep:once _ _ _)) #'1]
+ [(_ #s(rep:optional _ _ _)) #'0]
+ [(_ #s(rep:bounds min max _ _ _)) #'min]))
+
+;; (rep:max-number RepConstraint) : expr
+(define-syntax (rep:max-number stx)
+ (syntax-case stx ()
+ [(_ #s(rep:once _ _ _)) #'1]
+ [(_ #s(rep:optional _ _ _)) #'1]
+ [(_ #s(rep:bounds min max _ _ _)) #'max]))
+
+;; (rep:combine RepConstraint expr expr) : expr
+(define-syntax (rep:combine stx)
+ (syntax-case stx ()
+ [(_ #s(rep:once _ _ _) a b) #'a]
+ [(_ #s(rep:optional _ _ _) a b) #'a]
+ [(_ _ a b) #'(cons a b)]))
+
+;; ----
+
+(define-syntax expectation-of-reps/too-few
+ (syntax-rules ()
+ [(_ es rep #s(rep:once name too-few-msg too-many-msg) hpat)
+ (cond [(or too-few-msg (name->too-few/once name))
+ => (lambda (msg) (es-add-message msg es))]
+ [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))]
+ [else es])]
+ [(_ es rep #s(rep:optional name too-many-msg _) hpat)
+ (error 'syntax-parse "INTERNAL ERROR: impossible (too-few)")]
+ [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg) hpat)
+ (cond [(or too-few-msg (name->too-few name))
+ => (lambda (msg) (es-add-message msg es))]
+ [(first-desc:H hpat) => (lambda (fd) (es-add-proper-pair fd es))]
+ [else es])]))
+
+(define-syntax expectation-of-reps/too-many
+ (syntax-rules ()
+ [(_ es rep #s(rep:once name too-few-msg too-many-msg))
+ (es-add-message (or too-many-msg (name->too-many name)) es)]
+ [(_ es rep #s(rep:optional name too-many-msg _))
+ (es-add-message (or too-many-msg (name->too-many name)) es)]
+ [(_ es rep #s(rep:bounds min max name too-few-msg too-many-msg))
+ (es-add-message (or too-many-msg (name->too-many name)) es)]))
+
+;; ====
+
+(define-syntax (define-eh-alternative-set stx)
+ (define (parse-alt x)
+ (syntax-case x (pattern)
+ [(pattern alt)
+ #'alt]
+ [else
+ (wrong-syntax x "expected eh-alternative-set alternative")]))
+ (parameterize ((current-syntax-context stx))
+ (syntax-case stx ()
+ [(_ name a ...)
+ (unless (identifier? #'name)
+ (wrong-syntax #'name "expected identifier"))
+ (let* ([alts (map parse-alt (syntax->list #'(a ...)))]
+ [decls (new-declenv null #:conventions null)]
+ [ehpat+hstx-list
+ (apply append
+ (for/list ([alt (in-list alts)])
+ (parse-EH-variant alt decls #t #:context stx)))]
+ [eh-alt+defs-list
+ (for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
+ (let ([ehpat (car ehpat+hstx)]
+ [hstx (cadr ehpat+hstx)])
+ (cond [(syntax? hstx)
+ (define the-pattern (ehpat-head ehpat))
+ (define attrs (iattrs->sattrs (pattern-attrs the-pattern)))
+ (define the-variant (variant hstx attrs the-pattern null))
+ (define the-rhs (rhs attrs #t #f (list the-variant) null #f #f))
+ (with-syntax ([(parser) (generate-temporaries '(eh-alt-parser))]
+ [the-rhs-expr (datum->expression the-rhs)])
+ (list (eh-alternative (ehpat-repc ehpat) attrs #'parser)
+ (list #`(define parser
+ (parser/rhs parser () #,attrs
+ the-rhs-expr #t #,stx)))))]
+ [(eh-alternative? hstx)
+ (list hstx null)]
+ [else
+ (error 'define-eh-alternative-set "internal error: unexpected ~e"
+ hstx)])))]
+ [eh-alts (map car eh-alt+defs-list)]
+ [defs (apply append (map cadr eh-alt+defs-list))])
+ (with-syntax ([(def ...) defs]
+ [(alt-expr ...)
+ (for/list ([alt (in-list eh-alts)])
+ (with-syntax ([repc-expr
+ (datum->expression (eh-alternative-repc alt))]
+ [attrs-expr
+ #`(quote #,(eh-alternative-attrs alt))]
+ [parser-expr
+ #`(quote-syntax #,(eh-alternative-parser alt))])
+ #'(eh-alternative repc-expr attrs-expr parser-expr)))])
+ #'(begin def ...
+ (define-syntax name
+ (eh-alternative-set (list alt-expr ...))))))])))
diff --git a/7-4/racket/collects/syntax/parse/private/rep.rkt b/7-4/racket/collects/syntax/parse/private/rep.rkt
new file mode 100644
index 0000000..be08bc3
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/rep.rkt
@@ -0,0 +1,1965 @@
+#lang racket/base
+(require (for-template racket/base
+ syntax/parse/private/keywords
+ stxparse-info/parse/private/residual ;; keep abs. path
+ stxparse-info/parse/private/runtime)
+ racket/list
+ racket/contract/base
+ "make.rkt"
+ syntax/parse/private/minimatch
+ syntax/apply-transformer
+ syntax/private/id-table
+ syntax/stx
+ syntax/keyword
+ racket/syntax
+ racket/struct
+ "txlift.rkt"
+ syntax/parse/private/rep-attrs
+ syntax/parse/private/rep-data
+ syntax/parse/private/rep-patterns
+ syntax/parse/private/residual-ct ;; keep abs. path
+ syntax/parse/private/kws)
+
+;; Error reporting
+;; All entry points should have explicit, mandatory #:context arg
+;; (mandatory from outside, at least)
+
+(provide/contract
+ [atomic-datum-stx?
+ (-> syntax?
+ boolean?)]
+ [parse-rhs
+ (->* [syntax? boolean? #:context (or/c false/c syntax?)]
+ [#:default-description (or/c #f string?)]
+ rhs?)]
+ [parse-pattern+sides
+ (-> syntax? syntax?
+ #:splicing? boolean?
+ #:decls DeclEnv/c
+ #:context syntax?
+ any)]
+ [parse-EH-variant
+ (-> syntax? DeclEnv/c boolean?
+ #:context syntax?
+ any)]
+ [parse-directive-table any/c]
+ [get-decls+defs
+ (-> list? #:context (or/c false/c syntax?)
+ (values DeclEnv/c (listof syntax?)))]
+ [create-aux-def
+ (-> DeclEntry/c
+ (values DeclEntry/c (listof syntax?)))]
+ [parse-argu
+ (-> (listof syntax?)
+ #:context syntax?
+ arguments?)]
+ [parse-kw-formals
+ (-> syntax?
+ #:context syntax?
+ arity?)]
+ [check-stxclass-header
+ (-> syntax? syntax?
+ (list/c identifier? syntax? arity?))]
+ [check-stxclass-application
+ (-> syntax? syntax?
+ (cons/c identifier? arguments?))]
+ [check-conventions-rules
+ (-> syntax? syntax?
+ (listof (list/c regexp? any/c)))]
+ [check-datum-literals-list
+ (-> syntax? syntax?
+ (listof den:datum-lit?))]
+ [check-attr-arity-list
+ (-> syntax? syntax?
+ (listof sattr?))]
+ [stxclass-colon-notation?
+ (parameter/c boolean?)]
+ [fixup-rhs
+ (-> rhs? boolean? (listof sattr?) rhs?)])
+
+;; ----
+
+(define (atomic-datum-stx? stx)
+ (let ([datum (syntax-e stx)])
+ (or (null? datum)
+ (boolean? datum)
+ (string? datum)
+ (number? datum)
+ (keyword? datum)
+ (bytes? datum)
+ (char? datum)
+ (regexp? datum)
+ (byte-regexp? datum))))
+
+(define (id-predicate kw)
+ (lambda (stx)
+ (and (identifier? stx)
+ (free-identifier=? stx kw)
+ (begin (disappeared! stx) #t))))
+
+(define wildcard? (id-predicate (quote-syntax _)))
+(define epsilon? (id-predicate (quote-syntax ||)))
+(define dots? (id-predicate (quote-syntax ...)))
+(define plus-dots? (id-predicate (quote-syntax ...+)))
+
+(define keywords
+ (list (quote-syntax _)
+ (quote-syntax ||)
+ (quote-syntax ...)
+ (quote-syntax ~var)
+ (quote-syntax ~datum)
+ (quote-syntax ~literal)
+ (quote-syntax ~and)
+ (quote-syntax ~or)
+ (quote-syntax ~or*)
+ (quote-syntax ~alt)
+ (quote-syntax ~not)
+ (quote-syntax ~seq)
+ (quote-syntax ~rep)
+ (quote-syntax ~once)
+ (quote-syntax ~optional)
+ (quote-syntax ~between)
+ (quote-syntax ~rest)
+ (quote-syntax ~describe)
+ (quote-syntax ~!)
+ (quote-syntax ~bind)
+ (quote-syntax ~fail)
+ (quote-syntax ~parse)
+ (quote-syntax ~do)
+ (quote-syntax ~undo)
+ (quote-syntax ...+)
+ (quote-syntax ~delimit-cut)
+ (quote-syntax ~commit)
+ (quote-syntax ~reflect)
+ (quote-syntax ~splicing-reflect)
+ (quote-syntax ~eh-var)
+ (quote-syntax ~peek)
+ (quote-syntax ~peek-not)))
+
+(define (reserved? stx)
+ (and (identifier? stx)
+ (for/or ([kw (in-list keywords)])
+ (free-identifier=? stx kw))))
+
+(define (safe-name? stx)
+ (and (identifier? stx)
+ (not (regexp-match? #rx"^~" (symbol->string (syntax-e stx))))))
+
+;; cut-allowed? : (paramter/c boolean?)
+;; Used to detect ~cut within ~not pattern.
+;; (Also #:no-delimit-cut stxclass within ~not)
+(define cut-allowed? (make-parameter #t))
+
+;; A LookupConfig is one of 'no, 'try, 'yes
+;; 'no means don't lookup, always use dummy (no nested attrs)
+;; 'try means lookup, but on failure use dummy (-> nested attrs only from prev.)
+;; 'yes means lookup, raise error on failure
+
+;; stxclass-lookup-config : parameterof LookupConfig
+(define stxclass-lookup-config (make-parameter 'yes))
+
+;; stxclass-colon-notation? : (parameterof boolean)
+;; if #t, then x:sc notation means (~var x sc)
+;; otherwise, just a var
+(define stxclass-colon-notation? (make-parameter #t))
+
+;; disappeared! : (U Identifier (Stxpair Identifier Any)) -> Void
+(define (disappeared! x)
+ (cond [(identifier? x)
+ (record-disappeared-uses (list x))]
+ [(and (stx-pair? x) (identifier? (stx-car x)))
+ (record-disappeared-uses (list (stx-car x)))]
+ [else
+ (raise-type-error 'disappeared!
+ "identifier or syntax with leading identifier"
+ x)]))
+
+(define (propagate-disappeared! stx)
+ (cond [(and (syntax? stx) (syntax-property stx 'disappeared-use))
+ => (lambda (xs) (record-disappeared-uses (filter identifier? (flatten xs)) #f))]))
+
+
+;; ============================================================
+;; Entry points to pattern/rhs parsing
+
+;; parse-rhs : Syntax Boolean #:context Syntax #:default-description (U String #f) -> RHS
+(define (parse-rhs stx splicing? #:context ctx #:default-description [default-description #f])
+ (call/txlifts
+ (lambda ()
+ (parameterize ((current-syntax-context ctx))
+ (define-values (rest description transp? attributes auto-nested? colon-notation?
+ decls defs commit? delimit-cut?)
+ (parse-rhs/part1 stx splicing?))
+ (define variants
+ (parameterize ((stxclass-lookup-config (if auto-nested? 'try 'no))
+ (stxclass-colon-notation? colon-notation?))
+ (parse-variants rest decls splicing?)))
+ (define sattrs
+ (or attributes
+ (filter (lambda (a) (symbol-interned? (attr-name a)))
+ (intersect-sattrss (map variant-attrs variants)))))
+ (make rhs sattrs transp? (or description #`(quote #,default-description)) variants
+ (append (get-txlifts-as-definitions) defs)
+ commit? delimit-cut?)))))
+
+(define (parse-rhs/part1 stx splicing?)
+ (define-values (chunks rest)
+ (parse-keyword-options stx rhs-directive-table
+ #:context (current-syntax-context)
+ #:incompatible '((#:attributes #:auto-nested-attributes)
+ (#:commit #:no-delimit-cut))
+ #:no-duplicates? #t))
+ (define description (options-select-value chunks '#:description #:default #f))
+ (define opaque? (and (assq '#:opaque chunks) #t))
+ (define transparent? (not opaque?))
+ (define auto-nested? (and (assq '#:auto-nested-attributes chunks) #t))
+ (define colon-notation? (not (assq '#:disable-colon-notation chunks)))
+ (define commit?
+ (and (assq '#:commit chunks) #t))
+ (define delimit-cut?
+ (not (assq '#:no-delimit-cut chunks)))
+ (define attributes (options-select-value chunks '#:attributes #:default #f))
+ (define-values (decls defs) (get-decls+defs chunks))
+ (values rest description transparent? attributes auto-nested? colon-notation?
+ decls defs commit? delimit-cut?))
+
+(define (parse-variants rest decls splicing?)
+ (define (gather-variants stx)
+ (syntax-case stx (pattern)
+ [((pattern . _) . rest)
+ (begin (disappeared! (stx-car stx))
+ (cons (parse-variant (stx-car stx) splicing? decls)
+ (gather-variants #'rest)))]
+ [(bad-variant . rest)
+ (wrong-syntax #'bad-variant "expected syntax-class variant")]
+ [()
+ null]))
+ (gather-variants rest))
+
+;; get-decls+defs : chunks boolean -> (values DeclEnv (listof syntax))
+(define (get-decls+defs chunks #:context [ctx (current-syntax-context)])
+ (parameterize ((current-syntax-context ctx))
+ (let*-values ([(decls defs1) (get-decls chunks)]
+ [(decls defs2) (decls-create-defs decls)])
+ (values decls (append defs1 defs2)))))
+
+;; get-decls : chunks -> (values DeclEnv (listof syntax))
+(define (get-decls chunks)
+ (define lits (options-select-value chunks '#:literals #:default null))
+ (define datum-lits (options-select-value chunks '#:datum-literals #:default null))
+ (define litsets (options-select-value chunks '#:literal-sets #:default null))
+ (define convs (options-select-value chunks '#:conventions #:default null))
+ (define localconvs (options-select-value chunks '#:local-conventions #:default null))
+ (define literals
+ (append/check-lits+litsets lits datum-lits litsets))
+ (define-values (convs-rules convs-defs)
+ (for/fold ([convs-rules null] [convs-defs null])
+ ([conv-entry (in-list convs)])
+ (let* ([c (car conv-entry)]
+ [argu (cdr conv-entry)]
+ [get-parser-id (conventions-get-procedures c)]
+ [rules ((conventions-get-rules c))])
+ (values (append rules convs-rules)
+ (cons (make-conventions-def (map cadr rules) get-parser-id argu)
+ convs-defs)))))
+ (define convention-rules (append localconvs convs-rules))
+ (values (new-declenv literals #:conventions convention-rules)
+ (reverse convs-defs)))
+
+;; make-conventions-def : (listof den:delay) id Argument -> syntax
+(define (make-conventions-def dens get-parsers-id argu)
+ (with-syntax ([(parser ...) (map den:delayed-parser dens)]
+ [get-parsers get-parsers-id]
+ [argu argu])
+ #'(define-values (parser ...)
+ (apply values (app-argu get-parsers argu)))))
+
+;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx))
+(define (decls-create-defs decls0)
+ (define (updater key value defs)
+ (let-values ([(value newdefs) (create-aux-def value)])
+ (values value (append newdefs defs))))
+ (declenv-update/fold decls0 updater null))
+
+;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx))
+;; FIXME: replace with txlift mechanism
+(define (create-aux-def entry)
+ (match entry
+ [(? den:lit?)
+ (values entry null)]
+ [(? den:datum-lit?)
+ (values entry null)]
+ [(? den:magic-class?)
+ (values entry null)]
+ [(den:class name scname argu)
+ (with-syntax ([parser (generate-temporary scname)])
+ (values (make den:delayed #'parser scname)
+ (list #`(define-values (parser) (curried-stxclass-parser #,scname #,argu)))))]
+ [(? den:delayed?)
+ (values entry null)]))
+
+;; append/check-lits+litsets : .... -> (listof (U den:lit den:datum-lit))
+(define (append/check-lits+litsets lits datum-lits litsets)
+ (define seen (make-bound-id-table))
+ (define (check-id id [blame-ctx id])
+ (if (bound-id-table-ref seen id #f)
+ (wrong-syntax blame-ctx "duplicate literal declaration: ~s" (syntax-e id))
+ (bound-id-table-set! seen id #t))
+ id)
+ (let* ([litsets*
+ (for/list ([entry (in-list litsets)])
+ (let ([litset-id (first entry)]
+ [litset (second entry)]
+ [lctx (third entry)]
+ [input-phase (fourth entry)])
+ (define (get/check-id sym)
+ (check-id (datum->syntax lctx sym) litset-id))
+ (for/list ([lse (in-list (literalset-literals litset))])
+ (match lse
+ [(lse:lit internal external lit-phase)
+ (let ([internal (get/check-id internal)]
+ [external (syntax-property external 'literal (gensym))])
+ (make den:lit internal external input-phase lit-phase))]
+ [(lse:datum-lit internal external)
+ (let ([internal (get/check-id internal)])
+ (make den:datum-lit internal external))]))))]
+ [lits*
+ (for/list ([lit (in-list lits)])
+ (check-id (den:lit-internal lit))
+ lit)]
+ [datum-lits*
+ (for/list ([datum-lit (in-list datum-lits)])
+ (check-id (den:datum-lit-internal datum-lit))
+ datum-lit)])
+ (apply append lits* datum-lits* litsets*)))
+
+;; parse-variant : stx boolean DeclEnv -> RHS
+(define (parse-variant stx splicing? decls0)
+ (syntax-case stx (pattern)
+ [(pattern p . rest)
+ (let-values ([(rest pattern defs)
+ (parse-pattern+sides #'p #'rest
+ #:simplify? #f
+ #:splicing? splicing?
+ #:decls decls0
+ #:context stx)])
+ (disappeared! stx)
+ (unless (stx-null? rest)
+ (wrong-syntax (if (pair? rest) (car rest) rest)
+ "unexpected terms after pattern directives"))
+ (let* ([attrs (pattern-attrs pattern)]
+ [sattrs (iattrs->sattrs attrs)])
+ (make variant stx sattrs pattern defs)))]))
+
+;; parse-EH-variant : Syntax DeclEnv Boolean
+;; -> (Listof (list EllipsisHeadPattern Syntax/EH-Alternative))
+(define (parse-EH-variant stx decls allow-or? #:context [ctx (current-syntax-context)])
+ (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx))
+
+;; parse-pattern+sides : stx stx <options> -> (values stx Pattern (listof stx))
+;; Parses pattern, side clauses; desugars side clauses & merges with pattern
+(define (parse-pattern+sides p-stx s-stx
+ #:splicing? splicing?
+ #:decls decls0
+ #:context ctx
+ #:simplify? [simplify? #t])
+ (let-values ([(rest decls defs sides)
+ (parse-pattern-directives s-stx
+ #:allow-declare? #t
+ #:decls decls0
+ #:context ctx)])
+ (let* ([pattern0 (parse-whole-pattern p-stx decls splicing? #:context ctx #:kind 'main)]
+ [pattern (combine-pattern+sides pattern0 sides splicing?)]
+ [pattern (if simplify? (simplify-pattern pattern) pattern)])
+ (values rest pattern defs))))
+
+;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
+;; kind is either 'main or 'with, indicates what kind of pattern declare affects
+(define (parse-whole-pattern stx decls [splicing? #f]
+ #:kind kind
+ #:context [ctx (current-syntax-context)])
+ (parameterize ((current-syntax-context ctx))
+ (define pattern
+ (if splicing?
+ (parse-head-pattern stx decls)
+ (parse-single-pattern stx decls)))
+ (define pvars (map attr-name (pattern-attrs pattern)))
+ (define excess-domain (declenv-domain-difference decls pvars))
+ (when (pair? excess-domain)
+ (wrong-syntax (car excess-domain)
+ (string-append
+ "identifier in #:declare clause does not appear in pattern"
+ (case kind
+ [(main) ""] ;; ";\n this #:declare clause affects only the main pattern"]
+ [(with) ";\n this #:declare clause affects only the preceding #:with pattern"]))))
+ pattern))
+
+;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern
+(define (combine-pattern+sides pattern sides splicing?)
+ (check-pattern
+ (cond [splicing? (hpat:andu (cons pattern sides))]
+ [else (pat:andu (cons pattern sides))])))
+
+;; gensym* : -> UninternedSymbol
+;; Like gensym, but with deterministic name from compilation-local counter.
+(define gensym*-counter 0)
+(define (gensym*)
+ (set! gensym*-counter (add1 gensym*-counter))
+ (string->uninterned-symbol (format "group~a" gensym*-counter)))
+
+
+;; ============================================================
+;; Parsing patterns
+
+;; parse-single-pattern : stx DeclEnv -> SinglePattern
+(define (parse-single-pattern stx decls)
+ (parse-*-pattern stx decls #f #f))
+
+;; parse-head-pattern : stx DeclEnv -> HeadPattern
+(define (parse-head-pattern stx decls)
+ (coerce-head-pattern (parse-*-pattern stx decls #t #f)))
+
+;; parse-action-pattern : Stx DeclEnv -> ActionPattern
+(define (parse-action-pattern stx decls)
+ (define p (parse-*-pattern stx decls #f #t))
+ (unless (action-pattern? p)
+ (wrong-syntax stx "expected action pattern"))
+ p)
+
+(define ((make-not-shadowed? decls) id)
+ ;; Returns #f if id is in literals/datum-literals list.
+ ;; Conventions to not shadow pattern-form bindings, under the
+ ;; theory that conventions only apply to things already determined
+ ;; to be pattern variables.
+ (not (declenv-lookup decls id)))
+;; suitable as id=? argument to syntax-case*
+(define ((make-not-shadowed-id=? decls) lit-id pat-id)
+ (and (free-identifier=? lit-id pat-id)
+ (not (declenv-lookup decls pat-id))))
+
+;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern
+(define (parse-*-pattern stx decls allow-head? allow-action?)
+ (define (recur stx)
+ (parse-*-pattern stx decls allow-head? allow-action?))
+ (define (check-head! x)
+ (unless allow-head?
+ (wrong-syntax stx "head pattern not allowed here"))
+ x)
+ (define (check-action! x)
+ ;; Coerce to S-pattern IF only S-patterns allowed
+ (cond [allow-action? x]
+ [(not allow-head?) (action-pattern->single-pattern x)]
+ [else
+ (wrong-syntax stx "action pattern not allowed here")]))
+ (define not-shadowed? (make-not-shadowed? decls))
+ (propagate-disappeared! stx)
+ (check-pattern
+ (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe
+ ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo
+ ~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
+ ~splicing-reflect)
+ (make-not-shadowed-id=? decls)
+ [id
+ (and (identifier? #'id)
+ (not-shadowed? #'id)
+ (pattern-expander? (syntax-local-value #'id (λ () #f))))
+ (begin (disappeared! #'id)
+ (recur (expand-pattern (syntax-local-value #'id) stx)))]
+ [(id . rst)
+ (and (identifier? #'id)
+ (not-shadowed? #'id)
+ (pattern-expander? (syntax-local-value #'id (λ () #f))))
+ (begin (disappeared! #'id)
+ (recur (expand-pattern (syntax-local-value #'id) stx)))]
+ [wildcard
+ (and (wildcard? #'wildcard)
+ (not-shadowed? #'wildcard))
+ (begin (disappeared! stx)
+ (pat:any))]
+ [~!
+ (disappeared! stx)
+ (begin
+ (unless (cut-allowed?)
+ (wrong-syntax stx
+ "cut (~~!) not allowed within ~~not pattern"))
+ (check-action!
+ (action:cut)))]
+ [reserved
+ (and (reserved? #'reserved)
+ (not-shadowed? #'reserved))
+ (wrong-syntax stx "pattern keyword not allowed here")]
+ [id
+ (identifier? #'id)
+ (parse-pat:id stx decls allow-head?)]
+ [datum
+ (atomic-datum-stx? #'datum)
+ (pat:datum (syntax->datum #'datum))]
+ [(~var . rest)
+ (disappeared! stx)
+ (parse-pat:var stx decls allow-head?)]
+ [(~datum . rest)
+ (disappeared! stx)
+ (syntax-case stx (~datum)
+ [(~datum d)
+ (pat:datum (syntax->datum #'d))]
+ [_ (wrong-syntax stx "bad ~~datum form")])]
+ [(~literal . rest)
+ (disappeared! stx)
+ (parse-pat:literal stx decls)]
+ [(~and . rest)
+ (disappeared! stx)
+ (parse-pat:and stx decls allow-head? allow-action?)]
+ [(~or . rest)
+ (disappeared! stx)
+ (parse-pat:or stx decls allow-head?)]
+ [(~or* . rest)
+ (disappeared! stx)
+ (parse-pat:or stx decls allow-head?)]
+ [(~alt . rest)
+ (wrong-syntax stx "ellipsis-head pattern allowed only before ellipsis")]
+ [(~not . rest)
+ (disappeared! stx)
+ (parse-pat:not stx decls)]
+ [(~rest . rest)
+ (disappeared! stx)
+ (parse-pat:rest stx decls)]
+ [(~describe . rest)
+ (disappeared! stx)
+ (parse-pat:describe stx decls allow-head?)]
+ [(~delimit-cut . rest)
+ (disappeared! stx)
+ (parse-pat:delimit stx decls allow-head?)]
+ [(~commit . rest)
+ (disappeared! stx)
+ (parse-pat:commit stx decls allow-head?)]
+ [(~reflect . rest)
+ (disappeared! stx)
+ (parse-pat:reflect stx decls #f)]
+ [(~seq . rest)
+ (disappeared! stx)
+ (check-head!
+ (parse-hpat:seq stx #'rest decls))]
+ [(~optional . rest)
+ (disappeared! stx)
+ (check-head!
+ (parse-hpat:optional stx decls))]
+ [(~splicing-reflect . rest)
+ (disappeared! stx)
+ (check-head!
+ (parse-pat:reflect stx decls #t))]
+ [(~bind . rest)
+ (disappeared! stx)
+ (check-action!
+ (parse-pat:bind stx decls))]
+ [(~fail . rest)
+ (disappeared! stx)
+ (check-action!
+ (parse-pat:fail stx decls))]
+ [(~post . rest)
+ (disappeared! stx)
+ (parse-pat:post stx decls allow-head? allow-action?)]
+ [(~peek . rest)
+ (disappeared! stx)
+ (check-head!
+ (parse-pat:peek stx decls))]
+ [(~peek-not . rest)
+ (disappeared! stx)
+ (check-head!
+ (parse-pat:peek-not stx decls))]
+ [(~parse . rest)
+ (disappeared! stx)
+ (check-action!
+ (parse-pat:parse stx decls))]
+ [(~do . rest)
+ (disappeared! stx)
+ (check-action!
+ (parse-pat:do stx decls))]
+ [(~undo . rest)
+ (disappeared! stx)
+ (check-action!
+ (parse-pat:undo stx decls))]
+ [(head dots . tail)
+ (and (dots? #'dots) (not-shadowed? #'dots))
+ (begin (disappeared! #'dots)
+ (parse-pat:dots stx #'head #'tail decls))]
+ [(head plus-dots . tail)
+ (and (plus-dots? #'plus-dots) (not-shadowed? #'plus-dots))
+ (begin (disappeared! #'plus-dots)
+ (parse-pat:plus-dots stx #'head #'tail decls))]
+ [(head . tail)
+ (let ([headp (parse-*-pattern #'head decls #t #t)]
+ [tailp (parse-single-pattern #'tail decls)])
+ (cond [(action-pattern? headp)
+ (pat:action headp tailp)]
+ [else (pat:head (coerce-head-pattern headp) tailp)]))]
+ [#(a ...)
+ (let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
+ (pat:vector lp))]
+ [b
+ (box? (syntax-e #'b))
+ (let ([bp (parse-single-pattern (unbox (syntax-e #'b)) decls)])
+ (pat:box bp))]
+ [s
+ (and (struct? (syntax-e #'s)) (prefab-struct-key (syntax-e #'s)))
+ (let* ([s (syntax-e #'s)]
+ [key (prefab-struct-key s)]
+ [contents (struct->list s)])
+ (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)])
+ (pat:pstruct key lp)))])))
+
+;; expand-pattern : pattern-expander Syntax -> Syntax
+(define (expand-pattern pe stx)
+ (let ([proc (pattern-expander-proc pe)])
+ (local-apply-transformer proc stx 'expression)))
+
+;; parse-ellipsis-head-pattern : stx DeclEnv -> (listof EllipsisHeadPattern)
+(define (parse-ellipsis-head-pattern stx decls)
+ (for/list ([ehpat+hstx (in-list (parse*-ellipsis-head-pattern stx decls #t))])
+ (car ehpat+hstx)))
+
+;; parse*-ellipsis-head-pattern : stx DeclEnv bool
+;; -> (listof (list EllipsisHeadPattern stx/eh-alternative))
+(define (parse*-ellipsis-head-pattern stx decls allow-or?
+ #:context [ctx (current-syntax-context)])
+ (define (recur stx) (parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx))
+ (define (recur-cdr-list stx)
+ (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns"))
+ (apply append (map recur (cdr (stx->list stx)))))
+ (define not-shadowed? (make-not-shadowed? decls))
+ (propagate-disappeared! stx)
+ (syntax-case* stx (~eh-var ~or ~alt ~between ~optional ~once)
+ (make-not-shadowed-id=? decls)
+ [id
+ (and (identifier? #'id)
+ (not-shadowed? #'id)
+ (pattern-expander? (syntax-local-value #'id (lambda () #f))))
+ (begin (disappeared! #'id)
+ (recur (expand-pattern (syntax-local-value #'id) stx)))]
+ [(id . rst)
+ (and (identifier? #'id)
+ (not-shadowed? #'id)
+ (pattern-expander? (syntax-local-value #'id (lambda () #f))))
+ (begin (disappeared! #'id)
+ (recur (expand-pattern (syntax-local-value #'id) stx)))]
+ [(~eh-var name eh-alt-set-id)
+ (disappeared! stx)
+ (let ()
+ (define prefix (name->prefix #'name "."))
+ (define eh-alt-set (get-eh-alternative-set #'eh-alt-set-id))
+ (for/list ([alt (in-list (eh-alternative-set-alts eh-alt-set))])
+ (let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
+ [attr-count (length iattrs)])
+ (list (create-ehpat
+ (hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs #f
+ (scopts attr-count #f #t #f))
+ (eh-alternative-repc alt)
+ #f)
+ (replace-eh-alternative-attrs
+ alt (iattrs->sattrs iattrs))))))]
+ [(~or . _)
+ (disappeared! stx)
+ (recur-cdr-list stx)]
+ [(~alt . _)
+ (disappeared! stx)
+ (recur-cdr-list stx)]
+ [(~optional . _)
+ (disappeared! stx)
+ (list (parse*-ehpat/optional stx decls))]
+ [(~once . _)
+ (disappeared! stx)
+ (list (parse*-ehpat/once stx decls))]
+ [(~between . _)
+ (disappeared! stx)
+ (list (parse*-ehpat/bounds stx decls))]
+ [_
+ (let ([head (parse-head-pattern stx decls)])
+ (list (list (create-ehpat head #f stx) stx)))]))
+
+(define (replace-eh-alternative-attrs alt sattrs)
+ (match alt
+ [(eh-alternative repc _attrs parser)
+ (eh-alternative repc sattrs parser)]))
+
+;; ----------------------------------------
+;; Identifiers, ~var, and stxclasses
+
+(define (check-no-delimit-cut-in-not id delimit-cut?)
+ (unless (or delimit-cut? (cut-allowed?))
+ (wrong-syntax id
+ (string-append "syntax class with #:no-delimit-cut option "
+ "not allowed within ~~not pattern"))))
+
+(define (parse-pat:id id decls allow-head?)
+ (cond [(declenv-lookup decls id)
+ => (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
+ [(not (safe-name? id))
+ (wrong-syntax id "expected identifier not starting with ~~ character")]
+ [(and (stxclass-colon-notation?) (split-id id))
+ => (match-lambda
+ [(cons name suffix)
+ (declenv-check-unbound decls name (syntax-e suffix) #:blame-declare? #t)
+ (define entry (declenv-lookup decls suffix))
+ (cond [(or (den:lit? entry) (den:datum-lit? entry))
+ (pat:andu (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))]
+ [else (parse-stxclass-use id allow-head? name suffix no-arguments "." #f)])])]
+ [(declenv-apply-conventions decls id)
+ => (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
+ [else (pat:svar id)]))
+
+(define (split-id id0)
+ (cond [(regexp-match #rx"^([^:]*):(.+)$" (symbol->string (syntax-e id0)))
+ => (lambda (m)
+ (define src (syntax-source id0))
+ (define ln (syntax-line id0))
+ (define col (syntax-column id0))
+ (define pos (syntax-position id0))
+ (define span (syntax-span id0))
+ (define id-str (cadr m))
+ (define id-len (string-length id-str))
+ (define suffix-str (caddr m))
+ (define suffix-len (string-length suffix-str))
+ (define id
+ (datum->syntax id0 (string->symbol id-str)
+ (list src ln col pos id-len)
+ id0))
+ (define suffix
+ (datum->syntax id0 (string->symbol suffix-str)
+ (list src ln (and col (+ col id-len 1)) (and pos (+ pos id-len 1)) suffix-len)
+ id0))
+ (cons id suffix))]
+ [else #f]))
+
+;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern
+;; Handle when meaning of identifier pattern is given by declenv entry.
+(define (parse-pat:id/entry id allow-head? entry)
+ (match entry
+ [(den:lit internal literal input-phase lit-phase)
+ (pat:literal literal input-phase lit-phase)]
+ [(den:datum-lit internal sym)
+ (pat:datum sym)]
+ [(den:magic-class name scname argu role)
+ (parse-stxclass-use scname allow-head? id scname argu "." role)]
+ [(den:class _n _c _a)
+ (error 'parse-pat:id
+ "(internal error) decls had leftover stxclass entry: ~s"
+ entry)]
+ [(den:delayed parser scname)
+ (parse-stxclass-use id allow-head? id scname no-arguments "." #f parser)]))
+
+(define (parse-pat:var stx decls allow-head?)
+ (define name0
+ (syntax-case stx ()
+ [(_ name . _)
+ (unless (identifier? #'name)
+ (wrong-syntax #'name "expected identifier"))
+ #'name]
+ [_
+ (wrong-syntax stx "bad ~~var form")]))
+ (define-values (scname sc+args-stx argu pfx role)
+ (syntax-case stx ()
+ [(_ _name)
+ (values #f #f null #f #f)]
+ [(_ _name sc/sc+args . rest)
+ (let-values ([(sc argu)
+ (let ([p (check-stxclass-application #'sc/sc+args stx)])
+ (values (car p) (cdr p)))])
+ (define chunks
+ (parse-keyword-options/eol #'rest var-pattern-directive-table
+ #:no-duplicates? #t
+ #:context stx))
+ (define sep
+ (options-select-value chunks '#:attr-name-separator #:default #f))
+ (define role (options-select-value chunks '#:role #:default #'#f))
+ (values sc #'sc/sc+args argu (if sep (syntax-e sep) ".") role))]
+ [_
+ (wrong-syntax stx "bad ~~var form")]))
+ (cond [(and (epsilon? name0) (not scname))
+ (wrong-syntax name0 "illegal pattern variable name")]
+ [(and (wildcard? name0) (not scname))
+ (pat:any)]
+ [scname
+ (parse-stxclass-use stx allow-head? name0 scname argu pfx role)]
+ [else ;; Just proper name
+ (pat:svar name0)]))
+
+;; ----
+
+(define (parse-stxclass-use stx allow-head? varname scname argu pfx role [parser* #f])
+ (define config (stxclass-lookup-config))
+ (cond [(and (memq config '(yes try)) (get-stxclass scname (eq? config 'try)))
+ => (lambda (sc)
+ (unless parser*
+ (check-stxclass-arity sc stx (length (arguments-pargs argu)) (arguments-kws argu)))
+ (parse-stxclass-use* stx allow-head? varname sc argu pfx role parser*))]
+ [else
+ (define bind (name->bind varname))
+ (pat:fixup stx bind varname scname argu pfx role parser*)]))
+
+;; ----
+
+(define (parse-stxclass-use* stx allow-head? name sc argu pfx role parser*)
+ ;; if parser* not #f, overrides sc parser
+ (check-no-delimit-cut-in-not stx (scopts-delimit-cut? (stxclass-opts sc)))
+ (define bind (name->bind name))
+ (define prefix (name->prefix name pfx))
+ (define parser (or parser* (stxclass-parser sc)))
+ (define nested-attrs (id-pattern-attrs (stxclass-attrs sc) prefix))
+ (define opts (stxclass-opts sc))
+ (cond [(and (stxclass/s? sc) (stxclass-inline sc) (equal? argu no-arguments))
+ (pat:integrated bind (stxclass-inline sc) (scopts-desc opts) role)]
+ [(stxclass/s? sc)
+ (pat:var/p bind parser argu nested-attrs role opts)]
+ [(stxclass/h? sc)
+ (unless allow-head?
+ (wrong-syntax stx "splicing syntax class not allowed here"))
+ (hpat:var/p bind parser argu nested-attrs role opts)]))
+
+(define (name->prefix id pfx)
+ (cond [(wildcard? id) #f]
+ [(epsilon? id) id]
+ [else (format-id id "~a~a" (syntax-e id) pfx #:source id)]))
+
+(define (name->bind id)
+ (cond [(wildcard? id) #f]
+ [(epsilon? id) #f]
+ [else id]))
+
+;; id-pattern-attrs : (listof SAttr)IdPrefix -> (listof IAttr)
+(define (id-pattern-attrs sattrs prefix)
+ (if prefix
+ (for/list ([a (in-list sattrs)])
+ (prefix-attr a prefix))
+ null))
+
+;; prefix-attr : SAttr identifier -> IAttr
+(define (prefix-attr a prefix)
+ (make attr (prefix-attr-name prefix (attr-name a))
+ (attr-depth a)
+ (attr-syntax? a)))
+
+;; prefix-attr-name : id symbol -> id
+(define (prefix-attr-name prefix name)
+ (orig (format-id prefix "~a~a" (syntax-e prefix) name #:source prefix)))
+
+(define (orig stx)
+ (syntax-property stx 'original-for-check-syntax #t))
+
+;; ----------------------------------------
+;; Other pattern forms
+
+(define (parse-pat:reflect stx decls splicing?)
+ (syntax-case stx ()
+ [(_ name (obj arg ...) . maybe-signature)
+ (let ()
+ (unless (identifier? #'var)
+ (raise-syntax-error #f "expected identifier" stx #'name))
+ (define attr-decls
+ (syntax-case #'maybe-signature ()
+ [(#:attributes attr-decls)
+ (check-attr-arity-list #'attr-decls stx)]
+ [() null]
+ [_ (raise-syntax-error #f "bad syntax" stx)]))
+ (define prefix (name->prefix #'name "."))
+ (define bind (name->bind #'name))
+ (define ctor (if splicing? hpat:reflect pat:reflect))
+ (ctor #'obj (parse-argu (syntax->list #'(arg ...))) attr-decls bind
+ (id-pattern-attrs attr-decls prefix)))]))
+
+(define (parse-pat:literal stx decls)
+ (syntax-case stx ()
+ [(_ lit . more)
+ (unless (identifier? #'lit)
+ (wrong-syntax #'lit "expected identifier"))
+ (let* ([chunks (parse-keyword-options/eol #'more phase-directive-table
+ #:no-duplicates? #t
+ #:context stx)]
+ [phase (options-select-value chunks '#:phase #:default #f)]
+ [phase (if phase (txlift phase) #'(syntax-local-phase-level))])
+ (pat:literal #'lit phase phase))]
+ [_
+ (wrong-syntax stx "bad ~~literal pattern")]))
+
+(define (parse-pat:describe stx decls allow-head?)
+ (syntax-case stx ()
+ [(_ . rest)
+ (let-values ([(chunks rest)
+ (parse-keyword-options #'rest describe-option-table
+ #:no-duplicates? #t
+ #:context stx)])
+ (define transparent? (not (assq '#:opaque chunks)))
+ (define role (options-select-value chunks '#:role #:default #'#f))
+ (syntax-case rest ()
+ [(description pattern)
+ (let ([p (parse-*-pattern #'pattern decls allow-head? #f)])
+ (if (head-pattern? p)
+ (hpat:describe p #'description transparent? role)
+ (pat:describe p #'description transparent? role)))]))]))
+
+(define (parse-pat:delimit stx decls allow-head?)
+ (syntax-case stx ()
+ [(_ pattern)
+ (let ([p (parameterize ((cut-allowed? #t))
+ (parse-*-pattern #'pattern decls allow-head? #f))])
+ (if (head-pattern? p)
+ (hpat:delimit p)
+ (pat:delimit p)))]))
+
+(define (parse-pat:commit stx decls allow-head?)
+ (syntax-case stx ()
+ [(_ pattern)
+ (let ([p (parameterize ((cut-allowed? #t))
+ (parse-*-pattern #'pattern decls allow-head? #f))])
+ (if (head-pattern? p)
+ (hpat:commit p)
+ (pat:commit p)))]))
+
+(define (parse-pat:and stx decls allow-head? allow-action?)
+ ;; allow-action? = allowed to *return* pure action pattern;
+ ;; all ~and patterns are allowed to *contain* action patterns
+ (define patterns (parse-cdr-patterns stx decls allow-head? #t))
+ (cond [(andmap action-pattern? patterns)
+ (cond [allow-action?
+ (action:and patterns)]
+ [allow-head?
+ (wrong-syntax stx "expected at least one head or single-term pattern")]
+ [else
+ (wrong-syntax stx "expected at least one single-term pattern")])]
+ [(memq (stxclass-lookup-config) '(no try))
+ (pat:and/fixup stx patterns)]
+ [else (parse-pat:and/k stx patterns)]))
+
+(define (parse-pat:and/k stx patterns)
+ ;; PRE: patterns not all action patterns
+ (cond [(ormap head-pattern? patterns)
+ ;; Check to make sure *all* are head patterns (and action patterns)
+ (for ([pattern (in-list patterns)]
+ [pattern-stx (in-list (stx->list (stx-cdr stx)))])
+ (unless (or (action-pattern? pattern) (head-pattern? pattern))
+ (wrong-syntax pattern-stx "single-term pattern not allowed after head pattern")))
+ (hpat:andu patterns)]
+ [else (pat:andu patterns)]))
+
+(define (split-prefix xs pred)
+ (let loop ([xs xs] [rprefix null])
+ (cond [(and (pair? xs) (pred (car xs)))
+ (loop (cdr xs) (cons (car xs) rprefix))]
+ [else
+ (values (reverse rprefix) xs)])))
+
+(define (add-actions actions p)
+ (if (head-pattern? p)
+ (for/fold ([p p]) ([action (in-list (reverse actions))])
+ (hpat:action action p))
+ (for/fold ([p p]) ([action (in-list (reverse actions))])
+ (pat:action action p))))
+
+(define (parse-pat:or stx decls allow-head?)
+ (define patterns (parse-cdr-patterns stx decls allow-head? #f))
+ (cond [(null? (cdr patterns))
+ (car patterns)]
+ [else
+ (cond [(ormap head-pattern? patterns)
+ (create-hpat:or (map coerce-head-pattern patterns))]
+ [else
+ (create-pat:or patterns)])]))
+
+(define (parse-pat:not stx decls)
+ (syntax-case stx ()
+ [(_ pattern)
+ (let ([p (parameterize ((cut-allowed? #f))
+ (parse-single-pattern #'pattern decls))])
+ (pat:not p))]
+ [_
+ (wrong-syntax stx "expected a single subpattern")]))
+
+(define (parse-hpat:seq stx list-stx decls)
+ (define pattern (parse-single-pattern list-stx decls))
+ (unless (proper-list-pattern? pattern)
+ (wrong-syntax stx "expected proper list pattern"))
+ (hpat:seq pattern))
+
+(define (parse-cdr-patterns stx decls allow-head? allow-action?)
+ (unless (stx-list? stx)
+ (wrong-syntax stx "expected sequence of patterns"))
+ (let ([result
+ (for/list ([sub (in-list (cdr (stx->list stx)))])
+ (parse-*-pattern sub decls allow-head? allow-action?))])
+ (when (null? result)
+ (wrong-syntax stx "expected at least one pattern"))
+ result))
+
+(define (parse-pat:dots stx head tail decls)
+ (define headps (parse-ellipsis-head-pattern head decls))
+ (define tailp (parse-single-pattern tail decls))
+ (unless (pair? headps)
+ (wrong-syntax head "expected at least one pattern"))
+ (pat:dots headps tailp))
+
+(define (parse-pat:plus-dots stx head tail decls)
+ (define headp (parse-head-pattern head decls))
+ (define tailp (parse-single-pattern tail decls))
+ (define head/rep (create-ehpat headp (make-rep:bounds 1 +inf.0 #f #f #f) head))
+ (pat:dots (list head/rep) tailp))
+
+(define (parse-pat:bind stx decls)
+ (syntax-case stx ()
+ [(_ clause ...)
+ (let ([clauses (check-bind-clause-list #'(clause ...) stx)])
+ (action:and clauses))]))
+
+(define (parse-pat:fail stx decls)
+ (syntax-case stx ()
+ [(_ . rest)
+ (let-values ([(chunks rest)
+ (parse-keyword-options #'rest fail-directive-table
+ #:context stx
+ #:incompatible '((#:when #:unless))
+ #:no-duplicates? #t)])
+ (let ([condition
+ (cond [(options-select-value chunks '#:when #:default #f)
+ => values]
+ [(options-select-value chunks '#:unless #:default #f)
+ => (lambda (expr) #`(not #,expr))]
+ [else #'#t])])
+ (syntax-case rest ()
+ [(message)
+ (action:fail condition #'message)]
+ [()
+ (action:fail condition #''#f)]
+ [_
+ (wrong-syntax stx "bad ~~fail pattern")])))]))
+
+(define (parse-pat:post stx decls allow-head? allow-action?)
+ (syntax-case stx ()
+ [(_ pattern)
+ (let ([p (parse-*-pattern #'pattern decls allow-head? allow-action?)])
+ (cond [(action-pattern? p)
+ (cond [allow-action? (action:post p)]
+ [(not allow-head?) (pat:post (action-pattern->single-pattern p))]
+ [else (wrong-syntax stx "action pattern not allowed here")])]
+ [(head-pattern? p)
+ (cond [allow-head? (hpat:post p)]
+ [else (wrong-syntax stx "head pattern not allowed here")])]
+ [else (pat:post p)]))]))
+
+(define (parse-pat:peek stx decls)
+ (syntax-case stx ()
+ [(_ pattern)
+ (let ([p (parse-head-pattern #'pattern decls)])
+ (hpat:peek p))]))
+
+(define (parse-pat:peek-not stx decls)
+ (syntax-case stx ()
+ [(_ pattern)
+ (let ([p (parse-head-pattern #'pattern decls)])
+ (hpat:peek-not p))]))
+
+(define (parse-pat:parse stx decls)
+ (syntax-case stx ()
+ [(_ pattern expr)
+ (let ([p (parse-single-pattern #'pattern decls)])
+ (action:parse p #'expr))]
+ [_
+ (wrong-syntax stx "bad ~~parse pattern")]))
+
+(define (parse-pat:do stx decls)
+ (syntax-case stx ()
+ [(_ stmt ...)
+ (action:do (syntax->list #'(stmt ...)))]
+ [_
+ (wrong-syntax stx "bad ~~do pattern")]))
+
+(define (parse-pat:undo stx decls)
+ (syntax-case stx ()
+ [(_ stmt ...)
+ (action:undo (syntax->list #'(stmt ...)))]
+ [_
+ (wrong-syntax stx "bad ~~undo pattern")]))
+
+(define (parse-pat:rest stx decls)
+ (syntax-case stx ()
+ [(_ pattern)
+ (parse-single-pattern #'pattern decls)]))
+
+(define (parse-hpat:optional stx decls)
+ (define-values (head-stx head iattrs _name _tmm defaults)
+ (parse*-optional-pattern stx decls h-optional-directive-table))
+ (create-hpat:or
+ (list head
+ (hpat:action (action:and defaults)
+ (hpat:seq (pat:datum '()))))))
+
+;; parse*-optional-pattern : stx DeclEnv table
+;; -> (values Syntax HeadPattern IAttrs Stx Stx (Listof BindClause))
+(define (parse*-optional-pattern stx decls optional-directive-table)
+ (syntax-case stx ()
+ [(_ p . options)
+ (let* ([head (parse-head-pattern #'p decls)]
+ [chunks
+ (parse-keyword-options/eol #'options optional-directive-table
+ #:no-duplicates? #t
+ #:context stx)]
+ [too-many-msg
+ (options-select-value chunks '#:too-many #:default #'#f)]
+ [name
+ (options-select-value chunks '#:name #:default #'#f)]
+ [defaults
+ (options-select-value chunks '#:defaults #:default '())]
+ [pattern-iattrs (pattern-attrs head)]
+ [defaults-iattrs
+ (append-iattrs (map pattern-attrs defaults))]
+ [all-iattrs
+ (union-iattrs (list pattern-iattrs defaults-iattrs))])
+ (when (eq? (stxclass-lookup-config) 'yes)
+ ;; Only check that attrs in defaults clause agree with attrs
+ ;; in pattern when attrs in pattern are known to be complete.
+ (check-iattrs-subset defaults-iattrs pattern-iattrs stx))
+ (values #'p head all-iattrs name too-many-msg defaults))]))
+
+;; -- EH patterns
+;; Only parse the rep-constraint part; don't parse the head pattern within.
+;; (To support eh-alternative-sets.)
+
+;; parse*-ehpat/optional : stx DeclEnv -> (list EllipsisHeadPattern stx)
+(define (parse*-ehpat/optional stx decls)
+ (define-values (head-stx head iattrs name too-many-msg defaults)
+ (parse*-optional-pattern stx decls eh-optional-directive-table))
+ (list (create-ehpat head (make rep:optional name too-many-msg defaults) head-stx)
+ head-stx))
+
+;; parse*-ehpat/once : stx DeclEnv -> (list EllipsisHeadPattern stx)
+(define (parse*-ehpat/once stx decls)
+ (syntax-case stx ()
+ [(_ p . options)
+ (let* ([head (parse-head-pattern #'p decls)]
+ [chunks
+ (parse-keyword-options/eol #'options
+ (list (list '#:too-few check-expression)
+ (list '#:too-many check-expression)
+ (list '#:name check-expression))
+ #:context stx)]
+ [too-few-msg
+ (options-select-value chunks '#:too-few #:default #'#f)]
+ [too-many-msg
+ (options-select-value chunks '#:too-many #:default #'#f)]
+ [name
+ (options-select-value chunks '#:name #:default #'#f)])
+ (list (create-ehpat head (make rep:once name too-few-msg too-many-msg) #'p)
+ #'p))]))
+
+;; parse*-ehpat/bounds : stx DeclEnv -> (list EllipsisHeadPattern stx)
+(define (parse*-ehpat/bounds stx decls)
+ (syntax-case stx ()
+ [(_ p min max . options)
+ (let ()
+ (define head (parse-head-pattern #'p decls))
+ (define minN (syntax-e #'min))
+ (define maxN (syntax-e #'max))
+ (unless (exact-nonnegative-integer? minN)
+ (wrong-syntax #'min
+ "expected exact nonnegative integer"))
+ (unless (or (exact-nonnegative-integer? maxN) (equal? maxN +inf.0))
+ (wrong-syntax #'max
+ "expected exact nonnegative integer or +inf.0"))
+ (when (> minN maxN)
+ (wrong-syntax stx "minimum larger than maximum repetition constraint"))
+ (let* ([chunks (parse-keyword-options/eol
+ #'options
+ (list (list '#:too-few check-expression)
+ (list '#:too-many check-expression)
+ (list '#:name check-expression))
+ #:context stx)]
+ [too-few-msg
+ (options-select-value chunks '#:too-few #:default #'#f)]
+ [too-many-msg
+ (options-select-value chunks '#:too-many #:default #'#f)]
+ [name
+ (options-select-value chunks '#:name #:default #'#f)])
+ (list (create-ehpat head
+ (make rep:bounds #'min #'max
+ name too-few-msg too-many-msg)
+ #'p)
+ #'p)))]))
+
+
+;; ============================================================
+;; Fixup pass (also does simplify-pattern)
+
+(define (fixup-rhs the-rhs head? expected-attrs)
+ (match the-rhs
+ [(rhs attrs tr? desc vs defs commit? delimit-cut?)
+ (define vs* (for/list ([v (in-list vs)]) (fixup-variant v head? expected-attrs)))
+ (rhs attrs tr? desc vs* defs commit? delimit-cut?)]))
+
+(define (fixup-variant v head? expected-attrs)
+ (match v
+ [(variant stx sattrs p defs)
+ (parameterize ((current-syntax-context stx))
+ (define p1
+ (parameterize ((stxclass-lookup-config 'yes))
+ (fixup-pattern p head?)))
+ ;; (eprintf "~v\n===>\n~v\n\n" p p1)
+ (unless (if head? (wf-H? p1) (wf-S? p1))
+ (error 'fixup-variant "result is not well-formed"))
+ (define p* (simplify-pattern p1))
+ ;; (eprintf "=2=>\n~v\n\n" p*)
+ ;; Called just for error-reporting
+ (reorder-iattrs expected-attrs (pattern-attrs p*))
+ (variant stx sattrs p* defs))]))
+
+(define (fixup-pattern p0 head?)
+ (define (S p) (fixup p #f))
+ (define (S* p) (fixup p #t))
+ (define (A/S p) (if (action-pattern? p) (A p) (S p)))
+ (define (A/H p) (if (action-pattern? p) (A p) (H p)))
+
+ (define (A p)
+ (match p
+ ;; [(action:cut)
+ ;; (action:cut)]
+ ;; [(action:fail when msg)
+ ;; (action:fail when msg)]
+ ;; [(action:bind attr expr)
+ ;; (action:bind attr expr)]
+ [(action:and ps)
+ (action:and (map A ps))]
+ [(action:parse sp expr)
+ (action:parse (S sp) expr)]
+ ;; [(action:do stmts)
+ ;; (action:do stmts)]
+ ;; [(action:undo stmts)
+ ;; (action:undo stmts)]
+ [(action:ord sp group index)
+ (create-ord-pattern (A sp) group index)]
+ [(action:post sp)
+ (create-post-pattern (A sp))]
+ ;; ----
+ ;; Default: no sub-patterns, just return
+ [p p]))
+ (define (EH p)
+ (match p
+ [(ehpat iattrs hp repc check-null?)
+ (create-ehpat (H hp) repc #f)]))
+
+ (define (fixup p allow-head?)
+ (define (I p) (fixup p allow-head?))
+ (match p
+ [(pat:fixup stx bind varname scname argu pfx role parser*)
+ (parse-stxclass-use stx allow-head? varname scname argu pfx role parser*)]
+ ;; ----
+ ;; [(pat:any)
+ ;; (pat:any)]
+ ;; [(pat:svar name)
+ ;; (pat:svar name)]
+ ;; [(pat:var/p name parser argu nested-attrs role opts)
+ ;; (pat:var/p name parser argu nested-attrs role opts)]
+ ;; [(pat:integrated name predicate desc role)
+ ;; (pat:integrated name predicate desc role)]
+ ;; [(pat:reflect obj argu attr-decls name nested-attrs)
+ ;; (pat:reflect obj argu attr-decls name nested-attrs)]
+ ;; [(pat:datum d)
+ ;; (pat:datum d)]
+ ;; [(pat:literal id input-phase lit-phase)
+ ;; (pat:literal id input-phase lit-phase)]
+ [(pat:vector sp)
+ (pat:vector (S sp))]
+ [(pat:box sp)
+ (pat:box (S sp))]
+ [(pat:pstruct key sp)
+ (pat:pstruct key (S sp))]
+ [(pat:not sp)
+ (parameterize ((cut-allowed? #f))
+ (pat:not (S sp)))]
+ [(pat:dots headps tailp)
+ (pat:dots (map EH headps) (S tailp))]
+ [(pat:head headp tailp)
+ (pat:head (H headp) (S tailp))]
+ ;; --- The following patterns may change if a subpattern switches to head pattern ----
+ [(pat:pair headp tailp) (error 'fixup-pattern "internal error: pat:pair in stage 0")]
+ [(pat:action a sp)
+ (let ([a (A a)] [sp (I sp)])
+ (if (head-pattern? sp) (hpat:action a sp) (pat:action a sp)))]
+ [(pat:describe sp desc tr? role)
+ (let ([sp (I sp)])
+ (if (head-pattern? sp) (hpat:describe sp desc tr? role) (pat:describe sp desc tr? role)))]
+ [(pat:andu ps)
+ (let ([ps (map A/S ps)])
+ (pat:andu ps))]
+ [(pat:and/fixup stx ps)
+ (let ([ps (for/list ([p (in-list ps)])
+ (cond [(action-pattern? p) (A p)]
+ [(head-pattern? p) (H p)]
+ [else (I p)]))])
+ (parse-pat:and/k stx ps))]
+ [(pat:or _ ps _)
+ (let ([ps (map I ps)])
+ (if (ormap head-pattern? ps) (create-hpat:or ps) (create-pat:or ps)))]
+ [(pat:delimit sp)
+ (let ([sp (parameterize ((cut-allowed? #t)) (I sp))])
+ (if (head-pattern? sp) (hpat:delimit sp) (pat:delimit sp)))]
+ [(pat:commit sp)
+ (let ([sp (parameterize ((cut-allowed? #t)) (I sp))])
+ (if (head-pattern? sp) (hpat:commit sp) (pat:commit sp)))]
+ [(pat:ord sp group index)
+ (create-ord-pattern (I sp) group index)]
+ [(pat:post sp)
+ (create-post-pattern (I sp))]
+ ;; ----
+ ;; Default: no sub-patterns, just return
+ [p p]))
+
+ (define (H p)
+ (match p
+ [(hpat:single sp)
+ (let ([sp (fixup sp #t)])
+ (if (head-pattern? sp) sp (hpat:single sp)))]
+ ;; [(hpat:var/p name parser argu nested-attrs role scopts)
+ ;; (hpat:var/p name parser argu nested-attrs role scopts)]
+ ;; [(hpat:reflect obj argu attr-decls name nested-attrs)
+ ;; (hpat:reflect obj argu attr-decls name nested-attrs)]
+ [(hpat:seq lp)
+ (hpat:seq (S lp))]
+ [(hpat:action a hp)
+ (hpat:action (A a) (H hp))]
+ [(hpat:describe hp desc tr? role)
+ (hpat:describe (H hp) desc tr? role)]
+ [(hpat:andu ps)
+ (let ([ps (map A/H ps)])
+ (hpat:andu ps))]
+ [(hpat:or _ ps _)
+ (create-hpat:or (map H ps))]
+ [(hpat:delimit hp)
+ (parameterize ((cut-allowed? #t))
+ (hpat:delimit (H hp)))]
+ [(hpat:commit hp)
+ (parameterize ((cut-allowed? #t))
+ (hpat:commit (H hp)))]
+ [(hpat:ord hp group index)
+ (create-ord-pattern (H hp) group index)]
+ [(hpat:post hp)
+ (create-post-pattern (H hp))]
+ [(hpat:peek hp)
+ (hpat:peek (H hp))]
+ [(hpat:peek-not hp)
+ (hpat:peek-not (H hp))]
+ [(? pattern? sp)
+ (S* sp)]
+ ;; ----
+ ;; Default: no sub-patterns, just return
+ [p p]))
+
+ (if head? (H p0) (S p0)))
+
+
+;; ============================================================
+;; Simplify pattern
+
+;;(begin (require racket/pretty) (pretty-print-columns 160))
+
+;; simplify-pattern : *Pattern -> *Pattern
+(define (simplify-pattern p0)
+ ;;(eprintf "-- simplify --\n")
+ ;;(eprintf "~a\n" (pretty-format p0))
+ (define p1 (simplify:specialize-pairs p0))
+ ;; (eprintf "=1=>\n~a\n" (pretty-format p1))
+ (define p2 (simplify:normalize-and p1))
+ ;;(eprintf "=2=>\n~a\n" (pretty-format p2))
+ (define p3 (simplify:order-and p2))
+ ;;(eprintf "=3=>\n~a\n" (pretty-format p3))
+ (define p4 (simplify:add-seq-end p3))
+ ;;(eprintf "=4=>\n~a\n" (pretty-format p4))
+ p4)
+
+;; ----------------------------------------
+;; Add pair patterns
+
+(define (simplify:specialize-pairs p)
+ (define (for-pattern p)
+ (match p
+ [(pat:head (hpat:single headp) tailp)
+ (pat:pair headp tailp)]
+ [(pat:head (hpat:seq lp) tailp)
+ (list-pattern-replace-end lp tailp)]
+ [_ p]))
+ (pattern-transform p for-pattern))
+
+;; list-pattern-replace-end : ListPattern {L,S}Pattern -> {L,S}Pattern
+(define (list-pattern-replace-end lp endp)
+ (let loop ([lp lp])
+ (match lp
+ [(pat:datum '()) endp]
+ [(pat:seq-end) endp]
+ [(pat:action ap sp) (pat:action ap (loop sp))]
+ [(pat:head hp tp) (pat:head hp (loop tp))]
+ [(pat:dots hs tp) (pat:dots hs (loop tp))]
+ [(pat:ord sp group index)
+ ;; This is awkward, but it is needed to pop the ORD progress frame on success.
+ (define sp* (list-pattern-replace-end sp (pat:seq-end)))
+ (pat:head (hpat:ord (hpat:seq sp*) group index) endp)]
+ [(pat:pair hp tp) (pat:pair hp (loop tp))])))
+
+;; ----------------------------------------
+;; Normalize *:andu patterns, drop useless actions
+
+(define (simplify:normalize-and p)
+ (define (pattern->list p)
+ (match p
+ [(pat:any) null]
+ [(pat:action ap sp) (append (pattern->list ap) (pattern->list sp))]
+ [(pat:andu ps) (apply append (map pattern->list ps))]
+ [(hpat:action ap hp) (append (pattern->list ap) (pattern->list hp))]
+ [(hpat:andu ps) (apply append (map pattern->list ps))]
+ [(action:and as) (apply append (map pattern->list as))]
+ [(action:do '()) null]
+ [(action:undo '()) null]
+ [_ (list p)]))
+ (define (for-pattern p)
+ (match p
+ [(pat:action ap sp)
+ (pat:andu (append (pattern->list ap) (pattern->list sp)))]
+ [(pat:andu ps)
+ (pat:andu (apply append (map pattern->list ps)))]
+ [(hpat:action ap hp)
+ (hpat:andu (append (pattern->list ap) (pattern->list hp)))]
+ [(hpat:andu ps)
+ (hpat:andu (apply append (map pattern->list ps)))]
+ [(action:post ap)
+ (match (pattern->list ap)
+ ['() (action:and '())]
+ [(list ap*) (action:post ap*)]
+ [as* (action:post (action:and as*))])]
+ [_ p]))
+ (pattern-transform p for-pattern))
+
+;; ----------------------------------------
+;; Add *:ord and translate back to *:and, *:action
+
+(define (simplify:order-and p)
+ (define (A->S p) (if (action-pattern? p) (pat:action p (pat:any)) p))
+ (define (for-pattern p)
+ (match p
+ [(pat:andu ps0)
+ (define ord-ps (ord-and-patterns ps0 (gensym*)))
+ (define-values (as ps) (split-pred action-pattern? ord-ps))
+ (define sp* (list->single-pattern (map A->S ps)))
+ (add-action-patterns as sp*)]
+ [(hpat:andu ps0)
+ (define ord-ps (ord-and-patterns ps0 (gensym*)))
+ (define-values (as ps) (split-pred action-pattern? ord-ps))
+ (match ps
+ ['() (error 'simplify:order-ands "internal error: no head pattern")]
+ [(list hp) (add-action-patterns as hp)]
+ [(cons hp1 hps)
+ (define sp* (list->single-pattern (map action/head-pattern->list-pattern hps)))
+ (define hp* (hpat:and hp1 sp*))
+ (add-action-patterns as hp*)])]
+ [_ p]))
+ (pattern-transform p for-pattern))
+
+;; add-action-patterns : (Listof ActionPattern) *Pattern -> *Pattern
+(define (add-action-patterns as p)
+ (if (pair? as)
+ (let ([ap (list->action-pattern as)])
+ (cond [(single-pattern? p) (pat:action ap p)]
+ [(head-pattern? p) (hpat:action ap p)]))
+ p))
+
+;; list->action-pattern : (Listof ActionPattern) -> ActionPattern
+(define (list->action-pattern as)
+ (match as
+ [(list ap) ap]
+ [_ (action:and as)]))
+
+;; list->single-pattern : (Listof SinglePattern) -> SinglePattern
+(define (list->single-pattern ps)
+ (match ps
+ ['() (pat:any)]
+ [(list p) p]
+ [_ (pat:and ps)]))
+
+(define (split-pred pred? xs)
+ (let loop ([xs xs] [acc null])
+ (if (and (pair? xs) (pred? (car xs)))
+ (loop (cdr xs) (cons (car xs) acc))
+ (values (reverse acc) xs))))
+
+;; ----------------------------------------
+;; Add pat:seq-end to end of list-patterns in seq
+
+(define (simplify:add-seq-end p)
+ (define (for-pattern p)
+ (match p
+ [(hpat:seq lp)
+ (hpat:seq (list-pattern-replace-end lp (pat:seq-end)))]
+ [_ p]))
+ (pattern-transform p for-pattern))
+
+;; ============================================================
+;; Parsing pattern directives
+
+;; parse-pattern-directives : stxs(PatternDirective) <kw-args>
+;; -> stx DeclEnv (listof stx) (listof SideClause)
+(define (parse-pattern-directives stx
+ #:allow-declare? allow-declare?
+ #:decls decls
+ #:context ctx)
+ (parameterize ((current-syntax-context ctx))
+ (define-values (chunks rest)
+ (parse-keyword-options stx pattern-directive-table #:context ctx))
+ (define-values (decls2 chunks2)
+ (if allow-declare?
+ (grab-decls chunks decls)
+ (values decls chunks)))
+ (define sides
+ ;; NOTE: use *original* decls
+ ;; because decls2 has #:declares for *above* pattern
+ (parse-pattern-sides chunks2 decls))
+ (define-values (decls3 defs)
+ (decls-create-defs decls2))
+ (values rest decls3 defs sides)))
+
+;; parse-pattern-sides : (listof chunk) DeclEnv -> (listof SideClause)
+;; Invariant: decls contains only literals bindings
+(define (parse-pattern-sides chunks decls)
+ (match chunks
+ [(cons (list '#:declare declare-stx _ _) rest)
+ (wrong-syntax declare-stx
+ "#:declare can only appear immediately after pattern or #:with clause")]
+ [(cons (list '#:role role-stx _) rest)
+ (wrong-syntax role-stx "#:role can only appear immediately after #:declare clause")]
+ [(cons (list '#:fail-when fw-stx when-expr msg-expr) rest)
+ (cons (create-post-pattern (action:fail when-expr msg-expr))
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:fail-unless fu-stx unless-expr msg-expr) rest)
+ (cons (create-post-pattern (action:fail #`(not #,unless-expr) msg-expr))
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:when w-stx unless-expr) rest)
+ (cons (create-post-pattern (action:fail #`(not #,unless-expr) #'#f))
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:with with-stx pattern expr) rest)
+ (let-values ([(decls2 rest) (grab-decls rest decls)])
+ (let-values ([(decls2a defs) (decls-create-defs decls2)])
+ (list* (action:do defs)
+ (create-post-pattern
+ (action:parse (parse-whole-pattern pattern decls2a #:kind 'with) expr))
+ (parse-pattern-sides rest decls))))]
+ [(cons (list '#:attr attr-stx a expr) rest)
+ (cons (action:bind a expr) ;; no POST wrapper, cannot fail
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:post post-stx pattern) rest)
+ (cons (create-post-pattern (parse-action-pattern pattern decls))
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:and and-stx pattern) rest)
+ (cons (parse-action-pattern pattern decls) ;; no POST wrapper
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:do do-stx stmts) rest)
+ (cons (action:do stmts)
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:undo undo-stx stmts) rest)
+ (cons (action:undo stmts)
+ (parse-pattern-sides rest decls))]
+ [(cons (list '#:cut cut-stx) rest)
+ (cons (action:cut)
+ (parse-pattern-sides rest decls))]
+ ['()
+ '()]))
+
+;; grab-decls : (listof chunk) DeclEnv
+;; -> (values DeclEnv (listof chunk))
+(define (grab-decls chunks decls0)
+ (define (add-decl stx role-stx decls)
+ (let ([role
+ (and role-stx
+ (syntax-case role-stx ()
+ [(#:role role) #'role]))])
+ (syntax-case stx ()
+ [(#:declare name sc)
+ (identifier? #'sc)
+ (add-decl* decls #'name #'sc (parse-argu null) role)]
+ [(#:declare name (sc expr ...))
+ (identifier? #'sc)
+ (add-decl* decls #'name #'sc (parse-argu (syntax->list #'(expr ...))) role)]
+ [(#:declare name bad-sc)
+ (wrong-syntax #'bad-sc
+ "expected syntax class name (possibly with parameters)")])))
+ (define (add-decl* decls id sc-name argu role)
+ (declenv-put-stxclass decls id sc-name argu role))
+ (define (loop chunks decls)
+ (match chunks
+ [(cons (cons '#:declare decl-stx)
+ (cons (cons '#:role role-stx) rest))
+ (loop rest (add-decl decl-stx role-stx decls))]
+ [(cons (cons '#:declare decl-stx) rest)
+ (loop rest (add-decl decl-stx #f decls))]
+ [_ (values decls chunks)]))
+ (loop chunks decls0))
+
+
+;; ============================================================
+;; Arguments and Arities
+
+;; parse-argu : (listof stx) -> Arguments
+(define (parse-argu args #:context [ctx (current-syntax-context)])
+ (parameterize ((current-syntax-context ctx))
+ (define (loop args rpargs rkws rkwargs)
+ (cond [(null? args)
+ (arguments (reverse rpargs) (reverse rkws) (reverse rkwargs))]
+ [(keyword? (syntax-e (car args)))
+ (let ([kw (syntax-e (car args))]
+ [rest (cdr args)])
+ (cond [(memq kw rkws)
+ (wrong-syntax (car args) "duplicate keyword")]
+ [(null? rest)
+ (wrong-syntax (car args)
+ "missing argument expression after keyword")]
+ #| Overzealous, perhaps?
+ [(keyword? (syntax-e (car rest)))
+ (wrong-syntax (car rest) "expected expression following keyword")]
+ |#
+ [else
+ (loop (cdr rest) rpargs (cons kw rkws) (cons (car rest) rkwargs))]))]
+ [else
+ (loop (cdr args) (cons (car args) rpargs) rkws rkwargs)]))
+ (loop args null null null)))
+
+;; parse-kw-formals : stx -> Arity
+(define (parse-kw-formals formals #:context [ctx (current-syntax-context)])
+ (parameterize ((current-syntax-context ctx))
+ (define id-h (make-bound-id-table))
+ (define kw-h (make-hasheq)) ;; keyword => 'mandatory or 'optional
+ (define pos 0)
+ (define opts 0)
+ (define (add-id! id)
+ (when (bound-id-table-ref id-h id #f)
+ (wrong-syntax id "duplicate formal parameter" ))
+ (bound-id-table-set! id-h id #t))
+ (define (loop formals)
+ (cond [(and (stx-pair? formals) (keyword? (syntax-e (stx-car formals))))
+ (let* ([kw-stx (stx-car formals)]
+ [kw (syntax-e kw-stx)]
+ [rest (stx-cdr formals)])
+ (cond [(hash-ref kw-h kw #f)
+ (wrong-syntax kw-stx "duplicate keyword")]
+ [(stx-null? rest)
+ (wrong-syntax kw-stx "missing formal parameter after keyword")]
+ [else
+ (let-values ([(formal opt?) (parse-formal (stx-car rest))])
+ (add-id! formal)
+ (hash-set! kw-h kw (if opt? 'optional 'mandatory)))
+ (loop (stx-cdr rest))]))]
+ [(stx-pair? formals)
+ (let-values ([(formal opt?) (parse-formal (stx-car formals))])
+ (when (and (positive? opts) (not opt?))
+ (wrong-syntax (stx-car formals)
+ "mandatory argument may not follow optional argument"))
+ (add-id! formal)
+ (set! pos (add1 pos))
+ (when opt? (set! opts (add1 opts)))
+ (loop (stx-cdr formals)))]
+ [(identifier? formals)
+ (add-id! formals)
+ (finish #t)]
+ [(stx-null? formals)
+ (finish #f)]
+ [else
+ (wrong-syntax formals "bad argument sequence")]))
+ (define (finish has-rest?)
+ (arity (- pos opts)
+ (if has-rest? +inf.0 pos)
+ (sort (for/list ([(k v) (in-hash kw-h)]
+ #:when (eq? v 'mandatory))
+ k)
+ keyword<?)
+ (sort (hash-map kw-h (lambda (k v) k))
+ keyword<?)))
+ (loop formals)))
+
+;; parse-formal : stx -> (values id bool)
+(define (parse-formal formal)
+ (syntax-case formal ()
+ [param
+ (identifier? #'param)
+ (values #'param #f)]
+ [(param default)
+ (identifier? #'param)
+ (values #'param #t)]
+ [_
+ (wrong-syntax formal
+ "expected formal parameter with optional default")]))
+
+;; ============================================================
+;; Keyword Options & Checkers
+
+;; check-attr-arity-list : stx stx -> (listof SAttr)
+(define (check-attr-arity-list stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected list of attribute declarations" ctx stx))
+ (let ([iattrs
+ (for/list ([x (in-list (stx->list stx))])
+ (check-attr-arity x ctx))])
+ (iattrs->sattrs (append-iattrs (map list iattrs)))))
+
+;; check-attr-arity : stx stx -> IAttr
+(define (check-attr-arity stx ctx)
+ (syntax-case stx ()
+ [attr
+ (identifier? #'attr)
+ (make-attr #'attr 0 #f)]
+ [(attr depth)
+ (begin (unless (identifier? #'attr)
+ (raise-syntax-error #f "expected attribute name" ctx #'attr))
+ (unless (exact-nonnegative-integer? (syntax-e #'depth))
+ (raise-syntax-error #f "expected depth (nonnegative integer)" ctx #'depth))
+ (make-attr #'attr (syntax-e #'depth) #f))]
+ [_
+ (raise-syntax-error #f "expected attribute name with optional depth declaration" ctx stx)]))
+
+;; check-literals-list : stx stx -> (listof den:lit)
+;; - txlifts defs of phase expressions
+;; - txlifts checks that literals are bound
+(define (check-literals-list stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected literals list" ctx stx))
+ (for/list ([x (in-list (stx->list stx))])
+ (check-literal-entry x ctx)))
+
+;; check-literal-entry : stx stx -> den:lit
+(define (check-literal-entry stx ctx)
+ (define (go internal external phase)
+ (txlift #`(check-literal #,external #,phase #,ctx))
+ (let ([external (syntax-property external 'literal (gensym))])
+ (make den:lit internal external phase phase)))
+ (syntax-case stx ()
+ [(internal external #:phase phase)
+ (and (identifier? #'internal) (identifier? #'external))
+ (go #'internal #'external (txlift #'phase))]
+ [(internal external)
+ (and (identifier? #'internal) (identifier? #'external))
+ (go #'internal #'external #'(syntax-local-phase-level))]
+ [id
+ (identifier? #'id)
+ (go #'id #'id #'(syntax-local-phase-level))]
+ [_
+ (raise-syntax-error #f "expected literal entry" ctx stx)]))
+
+;; check-datum-literals-list : stx stx -> (listof den:datum-lit)
+(define (check-datum-literals-list stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected datum-literals list" ctx stx))
+ (for/list ([x (in-list (stx->list stx))])
+ (check-datum-literal-entry x ctx)))
+
+;; check-datum-literal-entry : stx stx -> den:datum-lit
+(define (check-datum-literal-entry stx ctx)
+ (syntax-case stx ()
+ [(internal external)
+ (and (identifier? #'internal) (identifier? #'external))
+ (make den:datum-lit #'internal (syntax-e #'external))]
+ [id
+ (identifier? #'id)
+ (make den:datum-lit #'id (syntax-e #'id))]
+ [_
+ (raise-syntax-error #f "expected datum-literal entry" ctx stx)]))
+
+;; Literal sets - Import
+
+;; check-literal-sets-list : stx stx -> (listof (list id literalset stx stx))
+(define (check-literal-sets-list stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected literal-set list" ctx stx))
+ (for/list ([x (in-list (stx->list stx))])
+ (check-literal-set-entry x ctx)))
+
+;; check-literal-set-entry : stx stx -> (list id literalset stx stx)
+(define (check-literal-set-entry stx ctx)
+ (define (elaborate litset-id lctx phase)
+ (let ([litset (syntax-local-value/record litset-id literalset?)])
+ (unless litset
+ (raise-syntax-error #f "expected identifier defined as a literal-set"
+ ctx litset-id))
+ (list litset-id litset lctx phase)))
+ (syntax-case stx ()
+ [(litset . more)
+ (and (identifier? #'litset))
+ (let* ([chunks (parse-keyword-options/eol #'more litset-directive-table
+ #:no-duplicates? #t
+ #:context ctx)]
+ [lctx (options-select-value chunks '#:at #:default #'litset)]
+ [phase (options-select-value chunks '#:phase #:default #f)])
+ (elaborate #'litset lctx (if phase (txlift phase) #'(syntax-local-phase-level))))]
+ [litset
+ (identifier? #'litset)
+ (elaborate #'litset #'litset #'(syntax-local-phase-level))]
+ [_
+ (raise-syntax-error #f "expected literal-set entry" ctx stx)]))
+
+;; Conventions
+
+;; returns (listof (cons Conventions (listof syntax)))
+(define (check-conventions-list stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected conventions list" ctx stx))
+ (for/list ([x (in-list (stx->list stx))])
+ (check-conventions x ctx)))
+
+;; returns (cons Conventions (listof syntax))
+(define (check-conventions stx ctx)
+ (define (elaborate conventions-id argu)
+ (let ([cs (syntax-local-value/record conventions-id conventions?)])
+ (unless cs
+ (raise-syntax-error #f "expected identifier defined as a conventions"
+ ctx conventions-id))
+ (cons cs argu)))
+ (syntax-case stx ()
+ [(conventions arg ...)
+ (identifier? #'conventions)
+ (elaborate #'conventions (parse-argu (syntax->list #'(arg ...))))]
+ [conventions
+ (identifier? #'conventions)
+ (elaborate #'conventions no-arguments)]
+ [_
+ (raise-syntax-error "expected conventions entry" ctx stx)]))
+
+;; returns (listof (list regexp DeclEntry))
+(define (check-conventions-rules stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected convention rule list" ctx stx))
+ (for/list ([x (in-list (stx->list stx))])
+ (check-conventions-rule x ctx)))
+
+;; returns (list regexp DeclEntry)
+(define (check-conventions-rule stx ctx)
+ (define (check-conventions-pattern x blame)
+ (cond [(symbol? x)
+ (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))]
+ [(regexp? x) x]
+ [else
+ (raise-syntax-error #f "expected identifier convention pattern"
+ ctx blame)]))
+ (define (check-sc-expr x rx)
+ (let ([x (check-stxclass-application x ctx)])
+ (make den:class rx (car x) (cdr x))))
+ (syntax-case stx ()
+ [(rx sc)
+ (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)])
+ (list name-pattern (check-sc-expr #'sc name-pattern)))]))
+
+(define (check-stxclass-header stx ctx)
+ (syntax-case stx ()
+ [name
+ (identifier? #'name)
+ (list #'name #'() no-arity)]
+ [(name . formals)
+ (identifier? #'name)
+ (list #'name #'formals (parse-kw-formals #'formals #:context ctx))]
+ [_ (raise-syntax-error #f "expected syntax class header" stx ctx)]))
+
+(define (check-stxclass-application stx ctx)
+ ;; Doesn't check "operator" is actually a stxclass
+ (syntax-case stx ()
+ [op
+ (identifier? #'op)
+ (cons #'op no-arguments)]
+ [(op arg ...)
+ (identifier? #'op)
+ (cons #'op (parse-argu (syntax->list #'(arg ...))))]
+ [_ (raise-syntax-error #f "expected syntax class use" ctx stx)]))
+
+;; bind clauses
+(define (check-bind-clause-list stx ctx)
+ (unless (stx-list? stx)
+ (raise-syntax-error #f "expected sequence of bind clauses" ctx stx))
+ (for/list ([clause (in-list (stx->list stx))])
+ (check-bind-clause clause ctx)))
+
+(define (check-bind-clause clause ctx)
+ (syntax-case clause ()
+ [(attr-decl expr)
+ (action:bind (check-attr-arity #'attr-decl ctx) #'expr)]
+ [_ (raise-syntax-error #f "expected bind clause" ctx clause)]))
+
+(define (check-stmt-list stx ctx)
+ (syntax-case stx ()
+ [(e ...)
+ (syntax->list #'(e ...))]
+ [_
+ (raise-syntax-error #f "expected list of expressions and definitions" ctx stx)]))
+
+
+;; ============================================================
+;; Directive tables
+
+;; common-parse-directive-table
+(define common-parse-directive-table
+ (list (list '#:disable-colon-notation)
+ (list '#:literals check-literals-list)
+ (list '#:datum-literals check-datum-literals-list)
+ (list '#:literal-sets check-literal-sets-list)
+ (list '#:conventions check-conventions-list)
+ (list '#:local-conventions check-conventions-rules)))
+
+;; parse-directive-table
+(define parse-directive-table
+ (list* (list '#:context check-expression)
+ (list '#:track-literals)
+ common-parse-directive-table))
+
+;; rhs-directive-table
+(define rhs-directive-table
+ (list* (list '#:description check-expression)
+ (list '#:transparent)
+ (list '#:opaque)
+ (list '#:attributes check-attr-arity-list)
+ (list '#:auto-nested-attributes)
+ (list '#:commit)
+ (list '#:no-delimit-cut)
+ common-parse-directive-table))
+
+;; pattern-directive-table
+(define pattern-directive-table
+ (list (list '#:declare check-identifier check-expression)
+ (list '#:role check-expression) ;; attached to preceding #:declare
+ (list '#:fail-when check-expression check-expression)
+ (list '#:fail-unless check-expression check-expression)
+ (list '#:when check-expression)
+ (list '#:with check-expression check-expression)
+ (list '#:attr check-attr-arity check-expression)
+ (list '#:and check-expression)
+ (list '#:post check-expression)
+ (list '#:do check-stmt-list)
+ (list '#:undo check-stmt-list)
+ (list '#:cut)))
+
+;; fail-directive-table
+(define fail-directive-table
+ (list (list '#:when check-expression)
+ (list '#:unless check-expression)))
+
+;; describe-option-table
+(define describe-option-table
+ (list (list '#:opaque)
+ (list '#:role check-expression)))
+
+;; eh-optional-directive-table
+(define eh-optional-directive-table
+ (list (list '#:too-many check-expression)
+ (list '#:name check-expression)
+ (list '#:defaults check-bind-clause-list)))
+
+;; h-optional-directive-table
+(define h-optional-directive-table
+ (list (list '#:defaults check-bind-clause-list)))
+
+;; phase-directive-table
+(define phase-directive-table
+ (list (list '#:phase check-expression)))
+
+;; litset-directive-table
+(define litset-directive-table
+ (cons (list '#:at (lambda (stx ctx) stx))
+ phase-directive-table))
+
+;; var-pattern-directive-table
+(define var-pattern-directive-table
+ (list (list '#:attr-name-separator check-stx-string)
+ (list '#:role check-expression)))
diff --git a/7-4/racket/collects/syntax/parse/private/residual.rkt b/7-4/racket/collects/syntax/parse/private/residual.rkt
new file mode 100644
index 0000000..1624b63
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/residual.rkt
@@ -0,0 +1,302 @@
+#lang racket/base
+(require (for-syntax racket/base)
+ racket/stxparam
+ racket/lazy-require
+ racket/private/promise)
+
+;; ============================================================
+;; Compile-time
+
+(require (for-syntax racket/private/sc syntax/parse/private/residual-ct))
+(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
+
+(require "../../case/template.rkt")
+(provide (for-syntax attribute-mapping attribute-mapping?))
+
+;; ============================================================
+;; Run-time
+
+(require "runtime-progress.rkt"
+ "3d-stx.rkt"
+ auto-syntax-e
+ syntax/stx
+ stxparse-info/current-pvars)
+
+(provide (all-from-out "runtime-progress.rkt")
+
+ this-syntax
+ this-role
+ this-context-syntax
+ attribute
+ attribute-binding
+ check-attr-value
+ stx-list-take
+ stx-list-drop/cx
+ datum->syntax/with-clause
+ check-literal*
+ error/null-eh-match
+ begin-for-syntax/once
+
+ name->too-few/once
+ name->too-few
+ name->too-many
+ normalize-context
+ syntax-patterns-fail)
+
+;; == from runtime.rkt
+
+;; this-syntax
+;; Bound to syntax being matched inside of syntax class
+(define-syntax-parameter this-syntax
+ (lambda (stx)
+ (raise-syntax-error #f "used out of context: not within a syntax class" stx)))
+
+(define-syntax-parameter this-role
+ (lambda (stx)
+ (raise-syntax-error #f "used out of context: not within a syntax class" stx)))
+
+;; this-context-syntax
+;; Bound to (expression that extracts) context syntax (bottom frame in progress)
+(define-syntax-parameter this-context-syntax
+ (lambda (stx)
+ (raise-syntax-error #f "used out of context: not within a syntax class" stx)))
+
+(define-syntax (attribute stx)
+ (syntax-case stx ()
+ [(attribute name)
+ (identifier? #'name)
+ (let ([mapping (syntax-local-value #'name (lambda () #f))])
+ (unless (syntax-pattern-variable? mapping)
+ (raise-syntax-error #f "not bound as a pattern variable" stx #'name))
+ (let ([var (syntax-mapping-valvar mapping)])
+ (let ([attr (syntax-local-value var (lambda () #f))])
+ (unless (attribute-mapping? attr)
+ (raise-syntax-error #f "not bound as an attribute" stx #'name))
+ (syntax-property (attribute-mapping-var attr)
+ 'disappeared-use
+ (list (syntax-local-introduce #'name))))))]))
+
+;; (attribute-binding id)
+;; mostly for debugging/testing
+(define-syntax (attribute-binding stx)
+ (syntax-case stx ()
+ [(attribute-bound? name)
+ (identifier? #'name)
+ (let ([value (syntax-local-value #'name (lambda () #f))])
+ (if (syntax-pattern-variable? value)
+ (let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
+ (if (attribute-mapping? value)
+ #`(quote #,(make-attr (attribute-mapping-name value)
+ (attribute-mapping-depth value)
+ (if (attribute-mapping-check value) #f #t)))
+ #'(quote #f)))
+ #'(quote #f)))]))
+
+;; stx-list-take : stxish nat -> syntax
+(define (stx-list-take stx n)
+ (datum->syntax #f
+ (let loop ([stx stx] [n n])
+ (if (zero? n)
+ null
+ (cons (stx-car stx)
+ (loop (stx-cdr stx) (sub1 n)))))))
+
+;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
+(define (stx-list-drop/cx x cx n)
+ (let loop ([x x] [cx cx] [n n])
+ (if (zero? n)
+ (values x
+ (if (syntax? x) x cx))
+ (loop (stx-cdr x)
+ (if (syntax? x) x cx)
+ (sub1 n)))))
+
+;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any))
+(define (check-attr-value v0 depth0 base? ctx)
+ (define (bad kind v)
+ (raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx))
+ (define (depthloop depth v)
+ (if (zero? depth)
+ (if base? (baseloop v) v)
+ (let listloop ([v v] [root? #t])
+ (cond [(null? v) null]
+ [(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))]
+ [new-cdr (listloop (cdr v) #f)])
+ (cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v]
+ [else (cons new-car new-cdr)]))]
+ [(promise? v) (listloop (force v) root?)]
+ [(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))]
+ [else (bad 'list v)]))))
+ (define (baseloop v)
+ (cond [(syntax? v) v]
+ [(promise? v) (baseloop (force v))]
+ [(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))]
+ [else (bad 'syntax v)]))
+ (depthloop depth0 v0))
+
+;; datum->syntax/with-clause : any -> syntax
+(define (datum->syntax/with-clause x)
+ (cond [(syntax? x) x]
+ [(2d-stx? x #:traverse-syntax? #f)
+ (datum->syntax #f x #f)]
+ [else
+ (error 'datum->syntax/with-clause
+ (string-append
+ "implicit conversion to 3D syntax\n"
+ " right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n"
+ " value: ~e")
+ x)]))
+
+;; check-literal* : id phase phase (listof phase) stx -> void
+(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
+ (unless (or (memv (and used-phase (- used-phase mod-phase))
+ ok-phases/ct-rel)
+ (identifier-binding id used-phase))
+ (raise-syntax-error
+ #f
+ (format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
+ used-phase
+ (and used-phase (- used-phase mod-phase)))
+ ctx id)))
+
+;; error/null-eh-match : -> (escapes)
+(define (error/null-eh-match)
+ (error 'syntax-parse "an ellipsis-head pattern matched an empty sequence"))
+
+;; (begin-for-syntax/once expr/phase1 ...)
+;; evaluates in pass 2 of module/intdefs expansion
+(define-syntax (begin-for-syntax/once stx)
+ (syntax-case stx ()
+ [(bfs/o e ...)
+ (cond [(list? (syntax-local-context))
+ #`(define-values ()
+ (begin (begin-for-syntax/once e ...)
+ (values)))]
+ [else
+ #'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
+ (m))])]))
+
+;; == parse.rkt
+
+(define (name->too-few/once name)
+ (and name (format "missing required occurrence of ~a" name)))
+
+(define (name->too-few name)
+ (and name (format "too few occurrences of ~a" name)))
+
+(define (name->too-many name)
+ (and name (format "too many occurrences of ~a" name)))
+
+;; == parse.rkt
+
+;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax)
+(define (normalize-context who ctx stx)
+ (cond [(syntax? ctx)
+ (list #f ctx)]
+ [(symbol? ctx)
+ (list ctx stx)]
+ [(eq? ctx #f)
+ (list #f stx)]
+ [(and (list? ctx)
+ (= (length ctx) 2)
+ (or (symbol? (car ctx)) (eq? #f (car ctx)))
+ (syntax? (cadr ctx)))
+ ctx]
+ [else (error who "bad #:context argument\n expected: ~s\n given: ~e"
+ '(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?))
+ ctx)]))
+
+;; == parse.rkt
+
+(lazy-require
+ ["runtime-report.rkt"
+ (call-current-failure-handler)])
+
+;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes
+(define ((syntax-patterns-fail ctx) undos fs)
+ (unwind-to undos null)
+ (call-current-failure-handler ctx fs))
+
+;; == specialized ellipsis parser
+;; returns (values 'ok attr-values) or (values 'fail failure)
+
+(provide predicate-ellipsis-parser)
+
+(define (predicate-ellipsis-parser x cx pr es pred? desc rl)
+ (let ([elems (stx->list x)])
+ (if (and elems (list? elems) (andmap pred? elems))
+ (values 'ok elems)
+ (let loop ([x x] [cx cx] [i 0])
+ (cond [(syntax? x)
+ (loop (syntax-e x) x i)]
+ [(pair? x)
+ (if (pred? (car x))
+ (loop (cdr x) cx (add1 i))
+ (let* ([pr (ps-add-cdr pr i)]
+ [pr (ps-add-car pr)]
+ [es (es-add-thing pr desc #t rl es)])
+ (values 'fail (failure pr es))))]
+ [else ;; not null, because stx->list failed
+ (let ([pr (ps-add-cdr pr i)]
+ #|
+ ;; Don't extend es! That way we don't get spurious "expected ()"
+ ;; that *should* have been cancelled out by ineffable pair failures.
+ |#)
+ (values 'fail (failure* pr es)))])))))
+
+(provide illegal-cut-error)
+
+(define (illegal-cut-error . _)
+ (error 'syntax-parse "illegal use of cut"))
+
+;; ----
+
+(provide unwind-to
+ maybe-add-state-undo
+ current-state
+ current-state-writable?
+ state-cons!
+ track-literals)
+
+(define (unwind-to undos base)
+ ;; PRE: undos = (list* proc/hash ... base)
+ (unless (eq? undos base)
+ (let ([top-undo (car undos)])
+ (cond [(procedure? top-undo) (top-undo)]
+ [(hash? top-undo) (current-state top-undo)]))
+ (unwind-to (cdr undos) base)))
+
+(define (maybe-add-state-undo init-state new-state undos)
+ (if (eq? init-state new-state)
+ undos
+ (cons init-state undos)))
+
+;; To make adding undos to rewind current-state simpler, only allow updates
+;; in a few contexts:
+;; - literals (handled automatically)
+;; - in ~do/#:do blocks (sets current-state-writable? = #t)
+
+(define current-state (make-parameter (hasheq)))
+(define current-state-writable? (make-parameter #f))
+
+(define (state-cons! key value)
+ (define state (current-state))
+ (current-state (hash-set state key (cons value (hash-ref state key null)))))
+
+(define (track-literals who v #:introduce? [introduce? #t])
+ (unless (syntax? v)
+ (raise-argument-error who "syntax?" v))
+ (let* ([literals (hash-ref (current-state) 'literals '())])
+ (if (null? literals)
+ v
+ (let ([literals* (if (and introduce? (syntax-transforming?) (list? literals))
+ (for/list ([literal (in-list literals)])
+ (if (identifier? literal)
+ (syntax-local-introduce literal)
+ literal))
+ literals)]
+ [old-val (syntax-property v 'disappeared-use)])
+ (syntax-property v 'disappeared-use
+ (if old-val
+ (cons literals* old-val)
+ literals*))))))
diff --git a/7-4/racket/collects/syntax/parse/private/runtime-progress.rkt b/7-4/racket/collects/syntax/parse/private/runtime-progress.rkt
new file mode 100644
index 0000000..ad894d2
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/runtime-progress.rkt
@@ -0,0 +1,258 @@
+#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:thing Progress #f #f 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 (or description (not transparent?)))
+ (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)
+|#
diff --git a/7-4/racket/collects/syntax/parse/private/runtime-reflect.rkt b/7-4/racket/collects/syntax/parse/private/runtime-reflect.rkt
new file mode 100644
index 0000000..59125cf
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/runtime-reflect.rkt
@@ -0,0 +1,96 @@
+#lang racket/base
+(require "residual.rkt"
+ (only-in syntax/parse/private/residual-ct attr-name attr-depth)
+ syntax/parse/private/kws)
+(provide reflect-parser
+ (struct-out reified)
+ (struct-out reified-syntax-class)
+ (struct-out reified-splicing-syntax-class))
+
+#|
+A Reified is
+ (reified symbol ParserFunction nat (listof (list symbol nat)))
+|#
+(require (only-in syntax/parse/private/runtime-reflect
+ reified
+ reified?
+ reified-parser
+ reified-arity
+ reified-signature
+ make-reified
+ struct:reified
+
+ reified-syntax-class
+ reified-syntax-class?
+ make-reified-syntax-class
+ struct:reified-syntax-class
+
+ reified-splicing-syntax-class
+ reified-splicing-syntax-class?
+ make-reified-splicing-syntax-class
+ struct:reified-splicing-syntax-class))
+#;(define-struct reified-base (name) #:transparent)
+#;(define-struct (reified reified-base) (parser arity signature))
+#;(define-struct (reified-syntax-class reified) ())
+#;(define-struct (reified-splicing-syntax-class reified) ())
+
+(define (reflect-parser obj e-arity e-attrs splicing?)
+ ;; e-arity represents single call; min and max are same
+ (define who (if splicing? 'reflect-splicing-syntax-class 'reflect-syntax-class))
+ (if splicing?
+ (unless (reified-splicing-syntax-class? obj)
+ (raise-type-error who "reified splicing-syntax-class" obj))
+ (unless (reified-syntax-class? obj)
+ (raise-type-error who "reified syntax-class" obj)))
+ (check-params who e-arity (reified-arity obj) obj)
+ (adapt-parser who
+ (for/list ([a (in-list e-attrs)])
+ (list (attr-name a) (attr-depth a)))
+ (reified-signature obj)
+ (reified-parser obj)
+ splicing?))
+
+(define (check-params who e-arity r-arity obj)
+ (let ([e-pos (arity-minpos e-arity)]
+ [e-kws (arity-minkws e-arity)])
+ (check-arity r-arity e-pos e-kws (lambda (msg) (error who "~a" msg)))))
+
+(define (adapt-parser who esig0 rsig0 parser splicing?)
+ (if (equal? esig0 rsig0)
+ parser
+ (let ([indexes
+ (let loop ([esig esig0] [rsig rsig0] [index 0])
+ (cond [(null? esig)
+ null]
+ [(and (pair? rsig) (eq? (caar esig) (caar rsig)))
+ (unless (= (cadar esig) (cadar rsig))
+ (wrong-depth who (car esig) (car rsig)))
+ (cons index (loop (cdr esig) (cdr rsig) (add1 index)))]
+ [(and (pair? rsig)
+ (string>? (symbol->string (caar esig))
+ (symbol->string (caar rsig))))
+ (loop esig (cdr rsig) (add1 index))]
+ [else
+ (error who "reified syntax-class is missing declared attribute `~s'"
+ (caar esig))]))])
+ (define (take-indexes result indexes)
+ (let loop ([result result] [indexes indexes] [i 0])
+ (cond [(null? indexes) null]
+ [(= (car indexes) i)
+ (cons (car result) (loop (cdr result) (cdr indexes) (add1 i)))]
+ [else
+ (loop (cdr result) indexes (add1 i))])))
+ (make-keyword-procedure
+ (lambda (kws kwargs x cx pr es undos fh cp rl success . rest)
+ (keyword-apply parser kws kwargs x cx pr es undos fh cp rl
+ (if splicing?
+ (lambda (fh undos x cx pr . result)
+ (apply success fh undos x cx pr (take-indexes result indexes)))
+ (lambda (fh undos . result)
+ (apply success fh undos (take-indexes result indexes))))
+ rest))))))
+
+(define (wrong-depth who a b)
+ (error who
+ "reified syntax-class has wrong depth for attribute `~s'; expected ~s, got ~s instead"
+ (car a) (cadr a) (cadr b)))
diff --git a/7-4/racket/collects/syntax/parse/private/runtime-report.rkt b/7-4/racket/collects/syntax/parse/private/runtime-report.rkt
new file mode 100644
index 0000000..a1d09e1
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/runtime-report.rkt
@@ -0,0 +1,816 @@
+#lang racket/base
+(require racket/list
+ racket/format
+ syntax/stx
+ racket/struct
+ syntax/srcloc
+ syntax/parse/private/minimatch
+ stxparse-info/parse/private/residual
+ syntax/parse/private/kws)
+(provide call-current-failure-handler
+ current-failure-handler
+ invert-failure
+ maximal-failures
+ invert-ps
+ ps->stx+index)
+
+#|
+TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
+ simplify to (expect:thing _ D _ #f)
+ thus, "expected D" rather than "expected D or D for R" (?)
+|#
+
+#|
+Note: there is a cyclic dependence between residual.rkt and this module,
+broken by a lazy-require of this module into residual.rkt
+|#
+
+(define (call-current-failure-handler ctx fs)
+ (call-with-values (lambda () ((current-failure-handler) ctx fs))
+ (lambda vals
+ (error 'current-failure-handler
+ "current-failure-handler: did not escape, produced ~e"
+ (case (length vals)
+ ((1) (car vals))
+ (else (cons 'values vals)))))))
+
+(define (default-failure-handler ctx fs)
+ (handle-failureset ctx fs))
+
+(define current-failure-handler
+ (make-parameter default-failure-handler))
+
+
+;; ============================================================
+;; Processing failure sets
+
+#|
+We use progress to select the maximal failures and determine the syntax
+they're complaining about. After that, we no longer care about progress.
+
+Old versions of syntax-parse (through 6.4) grouped failures into
+progress-equivalence-classes and generated reports by class, but only showed
+one report. New syntax-parse just mixes all maximal failures together and
+deals with the fact that they might not be talking about the same terms.
+|#
+
+;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
+(define (handle-failureset ctx fs)
+ (define inverted-fs (map invert-failure (reverse (flatten fs))))
+ (define maximal-classes (maximal-failures inverted-fs))
+ (define ess (map failure-expectstack (append* maximal-classes)))
+ (define report (report/sync-shared ess))
+ ;; Hack: alternative to new (primitive) phase-crossing exn type is to store
+ ;; extra information in exn continuation marks. Currently for debugging only.
+ (with-continuation-mark 'syntax-parse-error
+ (hasheq 'raw-failures fs
+ 'maximal maximal-classes)
+ (error/report ctx report)))
+
+;; An RFailure is (failure IPS RExpectList)
+
+;; invert-failure : Failure -> RFailure
+(define (invert-failure f)
+ (match f
+ [(failure ps es)
+ (failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))]))
+
+;; A Report is (report String (Listof String) Syntax/#f Syntax/#f)
+(define-struct report (message context stx within-stx) #:prefab)
+
+;; Sometimes the point where an error occurred does not correspond to
+;; a syntax object within the original term being matched. We use one
+;; or two syntax objects to identify where an error occurred:
+;; - the "at" term is the specific point of error, coerced to a syntax
+;; object if it isn't already
+;; - the "within" term is the closest enclosing original syntax object,
+;; dropped (#f) if same as "at" term
+
+;; Examples (AT is pre-coercion):
+;; TERM PATTERN => AT WITHIN
+;; #'(1) (a:id) #'1 -- ;; the happy case
+;; #'(1) (a b) () #'(1) ;; tail of syntax list, too short
+;; #'(1 . ()) (a b) #'() -- ;; tail is already syntax
+;; #'#(1) #(a b) () #'#(1) ;; "tail" of syntax vector
+;; #'#s(X 1) #s(X a b) () #'#s(X 1) ;; "tail" of syntax prefab
+;; #'(1 2) (a) (#'2) #'(1 2) ;; tail of syntax list, too long
+
+
+;; ============================================================
+;; Progress
+
+;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure))
+(define (maximal-failures fs)
+ (maximal/progress
+ (for/list ([f (in-list fs)])
+ (cons (failure-progress f) f))))
+
+#|
+Progress ordering
+-----------------
+
+Nearly a lexicographic generalization of partial order on frames.
+ (( CAR < CDR ) || stx ) < POST )
+ - stx incomparable except with self
+
+But ORD prefixes are sorted out (and discarded) before comparison with
+rest of progress. Like post, ord comparable only w/in same group:
+ - (ord g n1) < (ord g n2) if n1 < n2
+ - (ord g1 n1) || (ord g2 n2) when g1 != g2
+
+
+Progress equality
+-----------------
+
+If ps1 = ps2 then both must "blame" the same term,
+ie (ps->stx+index ps1) = (ps->stx+index ps2).
+|#
+
+;; An Inverted PS (IPS) is a PS inverted for easy comparison.
+;; An IPS may not contain any 'opaque frames.
+
+;; invert-ps : PS -> IPS
+;; Reverse and truncate at earliest 'opaque frame.
+(define (invert-ps ps)
+ (reverse (ps-truncate-opaque ps)))
+
+;; ps-truncate-opaque : PS -> PS
+;; Returns maximal tail with no 'opaque frame.
+(define (ps-truncate-opaque ps)
+ (let loop ([ps ps] [acc ps])
+ ;; acc is the biggest tail that has not been seen to contain 'opaque
+ (cond [(null? ps) acc]
+ [(eq? (car ps) 'opaque)
+ (loop (cdr ps) (cdr ps))]
+ [else (loop (cdr ps) acc)])))
+
+;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A))
+;; Eliminates As with non-maximal progress, then groups As into
+;; equivalence classes according to progress.
+(define (maximal/progress items)
+ (cond [(null? items)
+ null]
+ [(null? (cdr items))
+ (list (list (cdr (car items))))]
+ [else
+ (let loop ([items items] [non-ORD-items null])
+ (define-values (ORD non-ORD)
+ (partition (lambda (item) (ord? (item-first-prf item))) items))
+ (cond [(pair? ORD)
+ (loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))]
+ [else
+ (maximal/prf1 (append non-ORD non-ORD-items))]))]))
+
+;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A))
+(define (maximal/prf1 items)
+ (define-values (POST rest1)
+ (partition (lambda (item) (eq? 'post (item-first-prf item))) items))
+ (cond [(pair? POST)
+ (maximal/progress (map item-pop-prf POST))]
+ [else
+ (define-values (STX rest2)
+ (partition (lambda (item) (syntax? (item-first-prf item))) rest1))
+ (define-values (CDR rest3)
+ (partition (lambda (item) (exact-integer? (item-first-prf item))) rest2))
+ (define-values (CAR rest4)
+ (partition (lambda (item) (eq? 'car (item-first-prf item))) rest3))
+ (define-values (NULL rest5)
+ (partition (lambda (item) (eq? '#f (item-first-prf item))) rest4))
+ (unless (null? rest5)
+ (error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5))
+ (cond [(pair? CDR)
+ (define leastCDR (apply min (map item-first-prf CDR)))
+ (append
+ (maximal/stx STX)
+ (maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))]
+ [(pair? CAR)
+ (append
+ (maximal/stx STX)
+ (maximal/progress (map item-pop-prf CAR)))]
+ [(pair? STX)
+ (maximal/stx STX)]
+ [(pair? NULL)
+ (list (map cdr NULL))]
+ [else null])]))
+
+;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A))
+;; PRE: each item has ORD first frame
+;; Keep only maximal by first frame and pop first frame from each item.
+(define (maximal-prf1/ord items)
+ ;; groups : (NEListof (NEListof (cons A IPS)))
+ (define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items))
+ (append*
+ (for/list ([group (in-list groups)])
+ (define group* (filter-max group (lambda (item) (ord-index (item-first-prf item)))))
+ (map item-pop-prf group*))))
+
+;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A))
+;; PRE: Each IPS starts with a stx frame.
+(define (maximal/stx items)
+ ;; groups : (Listof (Listof (cons IPS A)))
+ (define groups (group-by item-first-prf items))
+ (append*
+ (for/list ([group (in-list groups)])
+ (maximal/progress (map item-pop-prf group)))))
+
+;; filter-max : (Listof X) (X -> Nat) -> (Listof X)
+(define (filter-max xs x->nat)
+ (let loop ([xs xs] [nmax -inf.0] [r-keep null])
+ (cond [(null? xs)
+ (reverse r-keep)]
+ [else
+ (define n0 (x->nat (car xs)))
+ (cond [(> n0 nmax)
+ (loop (cdr xs) n0 (list (car xs)))]
+ [(= n0 nmax)
+ (loop (cdr xs) nmax (cons (car xs) r-keep))]
+ [else
+ (loop (cdr xs) nmax r-keep)])])))
+
+;; item-first-prf : (cons IPS A) -> prframe/#f
+(define (item-first-prf item)
+ (define ips (car item))
+ (and (pair? ips) (car ips)))
+
+;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A))
+(define (item-split-ord item)
+ (define ips (car item))
+ (define a (cdr item))
+ (define-values (rest-ips r-ord)
+ (let loop ([ips ips] [r-ord null])
+ (cond [(and (pair? ips) (ord? (car ips)))
+ (loop (cdr ips) (cons (car ips) r-ord))]
+ [else (values ips r-ord)])))
+ (list* (reverse r-ord) rest-ips a))
+
+;; item-pop-prf : (cons IPS A) -> (cons IPS A)
+(define (item-pop-prf item)
+ (let ([ips (car item)]
+ [a (cdr item)])
+ (cons (cdr ips) a)))
+
+;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A)
+;; Assumes first frame is nat > ncdrs.
+(define (item-pop-prf-ncdrs item ncdrs)
+ (let ([ips (car item)]
+ [a (cdr item)])
+ (cond [(= (car ips) ncdrs) (cons (cdr ips) a)]
+ [else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)])))
+
+;; StxIdx = (cons Syntax Nat), the "within" term and offset (#cdrs) of "at" subterm
+
+;; ps->stx+index : Progress -> StxIdx
+;; Gets the innermost stx that should have a real srcloc, and the offset
+;; (number of cdrs) within that where the progress ends.
+(define (ps->stx+index ps)
+ (define (interp ps top?)
+ ;; if top?: first frame is 'car, must return Syntax, don't unwrap vector/struct
+ (match ps
+ [(cons (? syntax? stx) _) stx]
+ [(cons 'car parent)
+ (let* ([x (interp parent #f)]
+ [d (if (syntax? x) (syntax-e x) x)])
+ (cond [(pair? d) (car d)]
+ [(vector? d)
+ (if top? x (vector->list d))]
+ [(box? d) (unbox d)]
+ [(prefab-struct-key d)
+ (if top? x (struct->list d))]
+ [else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
+ [(cons (? exact-positive-integer? n) parent)
+ (for/fold ([stx (interp parent #f)]) ([i (in-range n)])
+ (stx-cdr stx))]
+ [(cons (? ord?) parent)
+ (interp parent top?)]
+ [(cons 'post parent)
+ (interp parent top?)]))
+ (let loop ([ps (ps-truncate-opaque ps)])
+ (match ps
+ [(cons (? syntax? stx) _)
+ (cons stx 0)]
+ [(cons 'car _)
+ (cons (interp ps #t) 0)]
+ [(cons (? exact-positive-integer? n) parent)
+ (match (loop parent)
+ [(cons stx m) (cons stx (+ m n))])]
+ [(cons (? ord?) parent)
+ (loop parent)]
+ [(cons 'post parent)
+ (loop parent)])))
+
+;; stx+index->at+within : StxIdx -> (values Syntax Syntax/#f)
+(define (stx+index->at+within stx+index)
+ (define within-stx (car stx+index))
+ (define index (cdr stx+index))
+ (cond [(zero? index)
+ (values within-stx #f)]
+ [else
+ (define d (syntax-e within-stx))
+ (define stx*
+ (cond [(vector? d) (vector->list d)]
+ [(prefab-struct-key d) (struct->list d)]
+ [else within-stx]))
+ (define at-stx*
+ (for/fold ([x stx*]) ([_i (in-range index)]) (stx-cdr x)))
+ (values (datum->syntax within-stx at-stx* within-stx)
+ within-stx)]))
+
+;; ============================================================
+;; Expectation simplification
+
+;; normalize-expectstack : ExpectStack StxIdx -> ExpectList
+;; Converts to list, converts expect:thing term rep, and truncates
+;; expectstack after opaque (ie, transparent=#f) frames.
+(define (normalize-expectstack es stx+index [truncate-opaque? #t])
+ (reverse (invert-expectstack es stx+index truncate-opaque?)))
+
+;; invert-expectstack : ExpectStack StxIdx -> RExpectList
+;; Converts to reversed list, converts expect:thing term rep,
+;; and truncates expectstack after opaque (ie, transparent=#f) frames.
+(define (invert-expectstack es stx+index [truncate-opaque? #t])
+ (let loop ([es es] [acc null])
+ (match es
+ ['#f acc]
+ ['#t acc]
+ [(expect:thing ps desc tr? role rest-es)
+ (let* (;; discard frames so far if opaque
+ [acc (if (and truncate-opaque? (not tr?)) null acc)]
+ ;; discard this frame if desc is #f
+ [acc (if desc (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc) acc)])
+ (loop rest-es acc))]
+ [(expect:message message rest-es)
+ (loop rest-es (cons (expect:message message stx+index) acc))]
+ [(expect:atom atom rest-es)
+ (loop rest-es (cons (expect:atom atom stx+index) acc))]
+ [(expect:literal literal rest-es)
+ (loop rest-es (cons (expect:literal literal stx+index) acc))]
+ [(expect:proper-pair first-desc rest-es)
+ (loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))])))
+
+;; expect->stxidx : Expect -> StxIdx
+(define (expect->stxidx e)
+ (cond [(expect:thing? e) (expect:thing-next e)]
+ [(expect:message? e) (expect:message-next e)]
+ [(expect:atom? e) (expect:atom-next e)]
+ [(expect:literal? e) (expect:literal-next e)]
+ [(expect:proper-pair? e) (expect:proper-pair-next e)]
+ [(expect:disj? e) (expect:disj-next e)]))
+
+#| Simplification
+
+A list of ExpectLists represents a tree, with shared tails meaning shared
+branches of the tree. We need a "reasonable" way to simplify it to a list to
+show to the user. Here we develop "reasonable" by example. (It would be nice,
+of course, to also have some way of exploring the full failure trees.)
+
+Notation: [A B X] means an ExpectList with class/description A at root and X
+at leaf. If the term sequences differ, write [t1:A ...] etc.
+
+Options:
+ (o) = "old behavior (through 6.4)"
+ (f) = "first divergence"
+ (s) = "sync on shared"
+
+Case 1: [A B X], [A B Y]
+
+ This is nearly the ideal situation: report as
+
+ expected X or Y, while parsing B, while parsing A
+
+Case 2: [A X], [A]
+
+ For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()],
+ but we don't want to see "expected ()".
+
+ So simplify to [A]---that is, drop X.
+
+But there are other cases that are more problematic.
+
+Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y]
+
+ Could report as:
+ (o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors)
+ (f) expected B or C for t2, while parsing t1 as A
+ (x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A
+
+ (o) is not good
+ (b) loses the most specific error information
+ (x) implies spurious contexts (eg, X while parsing C)
+
+ I like (b) best for this situation, but ...
+
+Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y]
+
+ Could report as:
+ (f') expected B or C, while parsing t1 as A
+ (s) expected X or Y for t4, while ..., while parsing t1 as A
+ (f) expected A for t1
+
+ (f') is problematic, since terms are different!
+ (s) okay, but nothing good to put in that ... space
+ (f) loses a lot of information
+
+Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y]
+
+ Only feasible choice (no other sync points):
+ (f,s) expected A for t1
+
+Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y]
+
+ Could report as:
+ (s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A
+ (s) expected X or Y for t3, while ..., while parsing t1 as A
+
+ (s') again implies spurious contexts, bad
+ (s) okay
+
+Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _]
+
+ Same frames show up in different orders. (Can this really happen? Probably,
+ with very weird uses of ~parse.)
+
+--
+
+This suggests the following new algorithm based on (s):
+- Step 1: emit an intermediate "unified" expectstack (extended with "..." markers)
+ - make a list (in order) of frames shared by all expectstacks
+ - emit those frames with "..." markers if (sometimes) unshared stuff between
+ - continue processing with the tails after the last shared frame:
+ - find the last term shared by all expectstacks (if any)
+ - find the last frame for that term for each expectstack
+ - combine in expect:disj and emit
+- Step 2:
+ - remove trailing and collapse adjacent "..." markers
+
+|#
+
+;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList)
+;; -> Report
+(define (report* ess handle-divergence)
+ (define es ;; ExpectList
+ (let loop ([ess ess] [acc null])
+ (cond [(ormap null? ess) acc]
+ [else
+ (define groups (group-by car ess))
+ (cond [(singleton? groups)
+ (define group (car groups))
+ (define frame (car (car group)))
+ (loop (map cdr group) (cons frame acc))]
+ [else ;; found point of divergence
+ (append (handle-divergence groups) acc)])])))
+ (define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0)))
+ (report/expectstack (clean-up es) stx+index))
+
+;; clean-up : ExpectList -> ExpectList
+;; Remove leading and collapse adjacent '... markers
+(define (clean-up es)
+ (if (and (pair? es) (eq? (car es) '...))
+ (clean-up (cdr es))
+ (let loop ([es es])
+ (cond [(null? es) null]
+ [(eq? (car es) '...)
+ (cons '... (clean-up es))]
+ [else (cons (car es) (loop (cdr es)))]))))
+
+;; --
+
+;; report/first-divergence : (NEListof RExpectList) -> Report
+;; Generate a single report, using frames from root to first divergence.
+(define (report/first-divergence ess)
+ (report* ess handle-divergence/first))
+
+;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList
+(define (handle-divergence/first ess-groups)
+ (define representative-ess (map car ess-groups))
+ (define first-frames (map car representative-ess))
+ ;; Do all of the first frames talk about the same term?
+ (cond [(all-equal? (map expect->stxidx first-frames))
+ (list (expect:disj first-frames #f))]
+ [else null]))
+
+;; --
+
+;; report/sync-shared : (NEListof RExpectList) -> Report
+;; Generate a single report, syncing on shared frames (and later, terms).
+(define (report/sync-shared ess)
+ (report* ess handle-divergence/sync-shared))
+
+;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList
+(define (handle-divergence/sync-shared ess-groups)
+ (define ess (append* ess-groups)) ;; (NEListof RExpectList)
+ (define shared-frames (get-shared ess values))
+ ;; rsegs : (NEListof (Rev2n+1-Listof RExpectList))
+ (define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames)))
+ (define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames
+ (define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList))
+ (append (hd/sync-shared/final final-seg)
+ (hd/sync-shared/ctx ctx-rsegs)))
+
+;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList
+;; PRE: ess has no shared frames, but may have shared terms.
+(define (hd/sync-shared/final ess0)
+ (define ess (remove-extensions ess0))
+ (define shared-terms (get-shared ess expect->stxidx))
+ (cond [(null? shared-terms) null]
+ [else
+ ;; split at the last shared term
+ (define rsegs ;; (NEListof (3-Listof RExpectList))
+ (for/list ([es (in-list ess)])
+ (rsplit es expect->stxidx (list (last shared-terms)))))
+ ;; only care about the got segment and pre, not post
+ (define last-term-ess ;; (NEListof RExpectList)
+ (map cadr rsegs))
+ (define pre-term-ess ;; (NEListof RExpectList)
+ (map caddr rsegs))
+ ;; last is most specific
+ (append
+ (list (expect:disj (remove-duplicates (reverse (map last last-term-ess)))
+ (last shared-terms)))
+ (if (ormap pair? pre-term-ess) '(...) '()))]))
+
+;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList
+;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most.
+;; We want leaf-most-first, so just process naturally.
+(define (hd/sync-shared/ctx rsegs)
+ (let loop ([rsegs rsegs])
+ (cond [(null? rsegs) null]
+ [(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")]
+ [else (append
+ ;; shared frame: possible for duplicate ctx frames, but unlikely
+ (let ([ess (car rsegs)]) (list (car (car ess))))
+ ;; inter frames:
+ (let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '()))
+ ;; recur
+ (loop (cddr rsegs)))])))
+
+;; transpose : (Listof (Listof X)) -> (Listof (Listof X))
+(define (transpose xss)
+ (cond [(ormap null? xss) null]
+ [else (cons (map car xss) (transpose (map cdr xss)))]))
+
+;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y)
+;; Return a list of Ys s.t. occur in order in (map of) each xs in xss.
+(define (get-shared xss get-y)
+ (cond [(null? xss) null]
+ [else
+ (define yhs ;; (Listof (Hash Y => Nat))
+ (for/list ([xs (in-list xss)])
+ (for/hash ([x (in-list xs)] [i (in-naturals 1)])
+ (values (get-y x) i))))
+ (remove-duplicates
+ (let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)])
+ ;; last is list of indexes of last accepted y; only accept next if occurs
+ ;; after last in every sequence (see Case 7 above)
+ (cond [(null? xs) null]
+ [else
+ (define y (get-y (car xs)))
+ (define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1)))
+ (cond [(andmap > curr last)
+ (cons y (loop (cdr xs) curr))]
+ [else (loop (cdr xs) last)])])))]))
+
+;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X))
+;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1].
+;; Thus the result has 2N+1 elements. The sublists are in original order.
+(define (rsplit xs get-y ys)
+ (define (loop xs ys segsacc)
+ (cond [(null? ys) (cons xs segsacc)]
+ [else (pre-loop xs ys segsacc null)]))
+ (define (pre-loop xs ys segsacc preacc)
+ (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
+ (got-loop (cdr xs) ys segsacc preacc (list (car xs)))]
+ [else
+ (pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))]))
+ (define (got-loop xs ys segsacc preacc gotacc)
+ (cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
+ (got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))]
+ [else
+ (loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))]))
+ (loop xs ys null))
+
+;; singleton? : list -> boolean
+(define (singleton? x) (and (pair? x) (null? (cdr x))))
+
+;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X))
+;; Remove any element that is an extension of another.
+(define (remove-extensions xss)
+ (cond [(null? xss) null]
+ [else
+ (let loop ([xss xss])
+ (cond [(singleton? xss) xss]
+ [(ormap null? xss) (list null)]
+ [else
+ (define groups (group-by car xss))
+ (append*
+ (for/list ([group (in-list groups)])
+ (define group* (loop (map cdr group)))
+ (map (lambda (x) (cons (caar group) x)) group*)))]))]))
+
+;; all-equal? : (Listof Any) -> Boolean
+(define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs))))
+
+
+;; ============================================================
+;; Reporting
+
+;; report/expectstack : ExpectList StxIdx -> Report
+(define (report/expectstack es stx+index)
+ (define frame-expect (and (pair? es) (car es)))
+ (define context-frames (if (pair? es) (cdr es) null))
+ (define context (append* (map context-prose-for-expect context-frames)))
+ (cond [(not frame-expect)
+ (report "bad syntax" context #f #f)]
+ [else
+ (define-values (frame-stx within-stx) (stx+index->at+within stx+index))
+ (cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f])
+ (stx-pair? frame-stx))
+ (report "unexpected term" context (stx-car frame-stx) #f)]
+ [(expect:disj? frame-expect)
+ (report (prose-for-expects (expect:disj-expects frame-expect))
+ context frame-stx within-stx)]
+ [else
+ (report (prose-for-expects (list frame-expect))
+ context frame-stx within-stx)])]))
+
+;; prose-for-expects : (listof Expect) -> string
+(define (prose-for-expects expects)
+ (define msgs (filter expect:message? expects))
+ (define things (filter expect:thing? expects))
+ (define literal (filter expect:literal? expects))
+ (define atom/symbol
+ (filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects))
+ (define atom/nonsym
+ (filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects))
+ (define proper-pairs (filter expect:proper-pair? expects))
+ (join-sep
+ (append (map prose-for-expect (append msgs things))
+ (prose-for-expects/literals literal "identifiers")
+ (prose-for-expects/literals atom/symbol "literal symbols")
+ (prose-for-expects/literals atom/nonsym "literals")
+ (prose-for-expects/pairs proper-pairs))
+ ";" "or"))
+
+(define (prose-for-expects/literals expects whats)
+ (cond [(null? expects) null]
+ [(singleton? expects) (map prose-for-expect expects)]
+ [else
+ (define (prose e)
+ (match e
+ [(expect:atom (? symbol? atom) _)
+ (format "`~s'" atom)]
+ [(expect:atom atom _)
+ (format "~s" atom)]
+ [(expect:literal literal _)
+ (format "`~s'" (syntax-e literal))]))
+ (list (string-append "expected one of these " whats ": "
+ (join-sep (map prose expects) "," "or")))]))
+
+(define (prose-for-expects/pairs expects)
+ (if (pair? expects) (list (prose-for-proper-pair-expects expects)) null))
+
+;; prose-for-expect : Expect -> string
+(define (prose-for-expect e)
+ (match e
+ [(expect:thing _ description transparent? role _)
+ (if role
+ (format "expected ~a for ~a" description role)
+ (format "expected ~a" description))]
+ [(expect:atom (? symbol? atom) _)
+ (format "expected the literal symbol `~s'" atom)]
+ [(expect:atom atom _)
+ (format "expected the literal ~s" atom)]
+ [(expect:literal literal _)
+ (format "expected the identifier `~s'" (syntax-e literal))]
+ [(expect:message message _)
+ message]
+ [(expect:proper-pair '#f _)
+ "expected more terms"]))
+
+;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
+(define (prose-for-proper-pair-expects es)
+ (define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
+ (cond [(for/or ([desc descs]) (equal? desc #f))
+ ;; FIXME: better way to indicate unknown ???
+ "expected more terms"]
+ [else
+ (format "expected more terms starting with ~a"
+ (join-sep (map prose-for-first-desc descs)
+ "," "or"))]))
+
+;; prose-for-first-desc : FirstDesc -> string
+(define (prose-for-first-desc desc)
+ (match desc
+ [(? string?) desc]
+ [(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
+ [(list 'literal id) (format "the identifier `~s'" id)]
+ [(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)]
+ [(list 'datum d) (format "the literal ~s" d)]))
+
+;; context-prose-for-expect : (U '... expect:thing) -> (listof string)
+(define (context-prose-for-expect e)
+ (match e
+ ['...
+ (list "while parsing different things...")]
+ [(expect:thing '#f description transparent? role stx+index)
+ (let-values ([(stx _within-stx) (stx+index->at+within stx+index)])
+ (cons (~a "while parsing " description
+ (if role (~a " for " role) ""))
+ (if (error-print-source-location)
+ (list (~a " term: "
+ (~s (syntax->datum stx)
+ #:limit-marker "..."
+ #:max-width 50))
+ (~a " location: "
+ (or (source-location->string stx) "not available")))
+ null)))]))
+
+
+;; ============================================================
+;; Raise exception
+
+(define (error/report ctx report)
+ (let* ([message (report-message report)]
+ [context (report-context report)]
+ [stx (cadr ctx)]
+ [who (or (car ctx) (infer-who stx))]
+ [sub-stx (report-stx report)]
+ [within-stx (report-within-stx report)]
+ [message
+ (format "~a: ~a~a~a~a~a"
+ who message
+ (format-if "at" (stx-if-loc sub-stx))
+ (format-if "within" (stx-if-loc within-stx))
+ (format-if "in" (stx-if-loc stx))
+ (if (null? context)
+ ""
+ (apply string-append
+ "\n parsing context: "
+ (for/list ([c (in-list context)])
+ (format "\n ~a" c)))))]
+ [message
+ (if (error-print-source-location)
+ (let ([source-stx (or stx sub-stx within-stx)])
+ (string-append (source-location->prefix source-stx) message))
+ message)])
+ (raise
+ (exn:fail:syntax message (current-continuation-marks)
+ (map syntax-taint
+ (cond [within-stx (list within-stx)]
+ [sub-stx (list sub-stx)]
+ [stx (list stx)]
+ [else null]))))))
+
+(define (format-if prefix val)
+ (if val
+ (format "\n ~a: ~a" prefix val)
+ ""))
+
+(define (stx-if-loc stx)
+ (and (syntax? stx)
+ (error-print-source-location)
+ (format "~.s" (syntax->datum stx))))
+
+(define (infer-who stx)
+ (let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
+ (if (identifier? maybe-id) (syntax-e maybe-id) '?)))
+
+(define (comma-list items)
+ (join-sep items "," "or"))
+
+(define (improper-stx->list stx)
+ (syntax-case stx ()
+ [(a . b) (cons #'a (improper-stx->list #'b))]
+ [() null]
+ [rest (list #'rest)]))
+
+
+;; ============================================================
+;; Debugging
+
+(provide failureset->sexpr
+ failure->sexpr
+ expectstack->sexpr
+ expect->sexpr)
+
+(define (failureset->sexpr fs)
+ (let ([fs (flatten fs)])
+ (case (length fs)
+ ((1) (failure->sexpr (car fs)))
+ (else `(union ,@(map failure->sexpr fs))))))
+
+(define (failure->sexpr f)
+ (match f
+ [(failure progress expectstack)
+ `(failure ,(progress->sexpr progress)
+ #:expected ,(expectstack->sexpr expectstack))]))
+
+(define (expectstack->sexpr es)
+ (map expect->sexpr es))
+
+(define (expect->sexpr e) e)
+
+(define (progress->sexpr ps)
+ (for/list ([pf (in-list ps)])
+ (match pf
+ [(? syntax? stx) 'stx]
+ [_ pf])))
diff --git a/7-4/racket/collects/syntax/parse/private/runtime.rkt b/7-4/racket/collects/syntax/parse/private/runtime.rkt
new file mode 100644
index 0000000..90d7ea8
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/runtime.rkt
@@ -0,0 +1,235 @@
+#lang racket/base
+(require racket/stxparam
+ stxparse-info/parse/private/residual ;; keep abs. path
+ stxparse-info/current-pvars
+ (for-syntax racket/base
+ racket/list
+ syntax/kerncase
+ syntax/strip-context
+ racket/private/sc
+ auto-syntax-e/utils
+ racket/syntax
+ syntax/parse/private/rep-data))
+
+(provide with
+ fail-handler
+ cut-prompt
+ undo-stack
+ wrap-user-code
+
+ fail
+ try
+
+ let-attributes
+ let-attributes*
+ let/unpack
+
+ defattrs/unpack
+
+ check-literal
+ no-shadow
+ curried-stxclass-parser
+ app-argu)
+
+#|
+TODO: rename file
+
+This file contains "runtime" (ie, phase 0) auxiliary *macros* used in
+expansion of syntax-parse etc. This file must not contain any
+reference that persists in a compiled program; those must go in
+residual.rkt.
+|#
+
+;; == with ==
+
+(define-syntax (with stx)
+ (syntax-case stx ()
+ [(with ([stxparam expr] ...) . body)
+ (with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))])
+ (syntax/loc stx
+ (let ([var expr] ...)
+ (syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var)))
+ ...)
+ . body))))]))
+
+;; == Control information ==
+
+(define-syntax-parameter fail-handler
+ (lambda (stx)
+ (wrong-syntax stx "internal error: fail-handler used out of context")))
+(define-syntax-parameter cut-prompt
+ (lambda (stx)
+ (wrong-syntax stx "internal error: cut-prompt used out of context")))
+(define-syntax-parameter undo-stack
+ (lambda (stx)
+ (wrong-syntax stx "internal error: undo-stack used out of context")))
+
+(define-syntax-rule (wrap-user-code e)
+ (with ([fail-handler #f]
+ [cut-prompt #t]
+ [undo-stack null])
+ e))
+
+(define-syntax-rule (fail fs)
+ (fail-handler undo-stack fs))
+
+(define-syntax (try stx)
+ (syntax-case stx ()
+ [(try e0 e ...)
+ (with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
+ (with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
+ (with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)])
+ #'(let* ([fh (lambda (undos1 fs1)
+ (with ([fail-handler
+ (lambda (undos2 fs2)
+ (unwind-to undos2 undos1)
+ (next-fh undos1 (cons fs1 fs2)))]
+ [undo-stack undos1])
+ re))]
+ ...)
+ (with ([fail-handler
+ (lambda (undos2 fs2)
+ (unwind-to undos2 undo-stack)
+ (last-fh undo-stack fs2))]
+ [undo-stack undo-stack])
+ e0)))))]))
+
+;; == Attributes
+
+(define-for-syntax (parse-attr x)
+ (syntax-case x ()
+ [#s(attr name depth syntax?) #'(name depth syntax?)]))
+
+(define-syntax (let-attributes stx)
+ (syntax-case stx ()
+ [(let-attributes ([a value] ...) . body)
+ (with-syntax ([((name depth syntax?) ...)
+ (map parse-attr (syntax->list #'(a ...)))])
+ (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
+ [(stmp ...) (generate-temporaries #'(name ...))])
+ #'(letrec-syntaxes+values
+ ([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth
+ (if 'syntax? #f (quote-syntax check-attr-value)))]
+ ...)
+ ([(vtmp) value] ...)
+ (letrec-syntaxes+values
+ ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...)
+ ()
+ (with-pvars (name ...)
+ . body)))))]))
+
+;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
+;; Special case: empty attrs need not match number of value exprs.
+(define-syntax let-attributes*
+ (syntax-rules ()
+ [(la* (() _) . body)
+ (let () . body)]
+ [(la* ((a ...) (val ...)) . body)
+ (let-attributes ([a val] ...) . body)]))
+
+;; (let/unpack (([id num] ...) expr) expr) : expr
+;; Special case: empty attrs need not match packed length
+(define-syntax (let/unpack stx)
+ (syntax-case stx ()
+ [(let/unpack (() packed) body)
+ #'body]
+ [(let/unpack ((a ...) packed) body)
+ (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
+ #'(let-values ([(tmp ...) (apply values packed)])
+ (let-attributes ([a tmp] ...) body)))]))
+
+(define-syntax (defattrs/unpack stx)
+ (syntax-case stx ()
+ [(defattrs (a ...) packed)
+ (with-syntax ([((name depth syntax?) ...)
+ (map parse-attr (syntax->list #'(a ...)))])
+ (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
+ [(stmp ...) (generate-temporaries #'(name ...))])
+ #'(begin (define-values (vtmp ...) (apply values packed))
+ (define-syntax stmp
+ (attribute-mapping (quote-syntax vtmp) 'name 'depth
+ (if 'syntax? #f (quote-syntax check-attr-value))))
+ ...
+ (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp)))
+ ...
+ (define-pvars name ...))))]))
+
+(define-syntax-rule (phase-of-enclosing-module)
+ (variable-reference->module-base-phase
+ (#%variable-reference)))
+
+;; (check-literal id phase-level-expr ctx) -> void
+(define-syntax (check-literal stx)
+ (syntax-case stx ()
+ [(check-literal id used-phase-expr ctx)
+ (let* ([ok-phases/ct-rel
+ ;; id is bound at each of ok-phases/ct-rel
+ ;; (phase relative to the compilation of the module in which the
+ ;; 'syntax-parse' (or related) form occurs)
+ (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))])
+ ;; so we can avoid run-time call to identifier-binding if
+ ;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase
+ (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel])
+ #`(check-literal* (quote-syntax id)
+ used-phase-expr
+ (phase-of-enclosing-module)
+ 'ok-phases/ct-rel
+ ;; If context is not stripped, racket complains about
+ ;; being unable to restore bindings for compiled code;
+ ;; and all we want is the srcloc, etc.
+ (quote-syntax #,(strip-context #'ctx)))))]))
+
+;; ====
+
+(begin-for-syntax
+ (define (check-shadow def)
+ (syntax-case def ()
+ [(_def (x ...) . _)
+ (parameterize ((current-syntax-context def))
+ (for ([x (in-list (syntax->list #'(x ...)))])
+ (let ([v (syntax-local-value x (lambda _ #f))])
+ (when (syntax-pattern-variable? v)
+ (wrong-syntax
+ x
+ ;; FIXME: customize "~do pattern" vs "#:do block" as appropriate
+ "definition in ~~do pattern must not shadow attribute binding")))))])))
+
+(define-syntax (no-shadow stx)
+ (syntax-case stx ()
+ [(no-shadow e)
+ (let ([ee (local-expand #'e (syntax-local-context)
+ (kernel-form-identifier-list))])
+ (syntax-case ee (begin define-values define-syntaxes)
+ [(begin d ...)
+ #'(begin (no-shadow d) ...)]
+ [(define-values . _)
+ (begin (check-shadow ee)
+ ee)]
+ [(define-syntaxes . _)
+ (begin (check-shadow ee)
+ ee)]
+ [_
+ ee]))]))
+
+(define-syntax (curried-stxclass-parser stx)
+ (syntax-case stx ()
+ [(_ class argu)
+ (with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu])
+ (let ([sc (get-stxclass/check-arity #'class #'class
+ (length (syntax->list #'(parg ...)))
+ (syntax->datum #'(kw ...)))])
+ (with-syntax ([parser (stxclass-parser sc)])
+ #'(lambda (x cx pr es undos fh cp rl success)
+ (app-argu parser x cx pr es undos fh cp rl success argu)))))]))
+
+(define-syntax (app-argu stx)
+ (syntax-case stx ()
+ [(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...)))
+ #|
+ Use keyword-apply directly?
+ #'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null)
+ If so, create separate no-keyword clause.
+ |#
+ ;; For now, let #%app handle it.
+ (with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)])
+ #'(proc kw-part ... ... extra-parg ... parg ...))]))
diff --git a/7-4/racket/collects/syntax/parse/private/sc.rkt b/7-4/racket/collects/syntax/parse/private/sc.rkt
new file mode 100644
index 0000000..d4e5ff6
--- /dev/null
+++ b/7-4/racket/collects/syntax/parse/private/sc.rkt
@@ -0,0 +1,32 @@
+#lang racket/base
+(require racket/lazy-require
+ syntax/parse/private/keywords
+ "residual.rkt")
+
+(lazy-require-syntax
+ ["parse.rkt"
+ (define-syntax-class
+ define-splicing-syntax-class
+ define-integrable-syntax-class
+ syntax-parse
+ syntax-parser
+ define/syntax-parse
+ syntax-parser/template
+ define-eh-alternative-set)])
+
+(provide define-syntax-class
+ define-splicing-syntax-class
+ define-integrable-syntax-class
+ syntax-parse
+ syntax-parser
+ define/syntax-parse
+
+ (except-out (all-from-out syntax/parse/private/keywords)
+ ~reflect
+ ~splicing-reflect
+ ~eh-var)
+ attribute
+ this-syntax
+
+ syntax-parser/template
+ define-eh-alternative-set)
diff --git a/7-4/racket/collects/syntax/parse/private/txlift.rkt b/7-4/racket/collects/syntax/parse/private/txlift.rkt
new file mode 100644
index 0000000..57c5497
--- /dev/null
+++ b/7-4/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))))))
diff --git a/7-4/stxparse-info.scrbl b/7-4/stxparse-info.scrbl
new file mode 100644
index 0000000..8cd3733
--- /dev/null
+++ b/7-4/stxparse-info.scrbl
@@ -0,0 +1,357 @@
+#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
+ prop:syntax-class
+ 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
+ ??
+ ?@)
diff --git a/info.rkt b/info.rkt
index 2376213..61b929d 100644
--- a/info.rkt
+++ b/info.rkt
@@ -11,8 +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" "8-0"))
-(define test-omit-paths '("6-11" "6-12" "6-90-0-29" "7-0-0-20" "7-3-0-1" "8-0"))
+(define compile-omit-paths '("6-11" "6-12" "6-90-0-29" "7-0-0-20" "7-3-0-1" "7-4" "8-0"))
+(define test-omit-paths '("6-11" "6-12" "6-90-0-29" "7-0-0-20" "7-3-0-1" "7-4" "8-0"))
(define pkg-desc "Description Here")
(define version "0.0")
(define pkg-authors '(Suzanne Soy))
diff --git a/my-include.rkt b/my-include.rkt
index 183487d..459c897 100644
--- a/my-include.rkt
+++ b/my-include.rkt
@@ -42,7 +42,9 @@
#,(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)))]
- [(version< (version) "7.4")
- #,(my-include1 (loc (string-append -updir "7-3-0-1" -filename)))]
+ ;[(version< (version) "7.4")
+ ; #,(my-include1 (loc (string-append -updir "7-3-0-1" -filename)))]
+ [(version< (version) "7.5")
+ #,(my-include1 (loc (string-append -updir "7-4" -filename)))]
[else
#,(my-include1 (loc (string-append -updir "8-0" -filename)))]))]))