From 34fa88001a8c9f35f64f9e6a7d656fb481b6ec58 Mon Sep 17 00:00:00 2001
From: Suzanne Soy <ligo@suzanne.soy>
Date: Fri, 26 Feb 2021 23:47:19 +0000
Subject: [PATCH] Moved files around to get the original directory structure
---
.../racket/private/stxcase-scheme.rkt | 0
.../collects/racket/private/stxcase.rkt | 0
.../racket/collects/racket/private/stxloc.rkt | 0
.../racket/collects/racket/private/syntax.rkt | 0
.../racket/private/template.rkt.deleted | 0
.../collects/racket/private/with-stx.rkt | 0
.../racket/collects/syntax/parse.rkt | 0
.../racket/collects/syntax/parse/debug.rkt | 0
.../syntax/parse/experimental/contract.rkt | 0
.../parse/experimental/private/substitute.rkt | 0
.../syntax/parse/experimental/provide.rkt | 0
.../syntax/parse/experimental/reflect.rkt | 0
.../syntax/parse/experimental/specialize.rkt | 0
.../syntax/parse/experimental/splicing.rkt | 0
.../syntax/parse/experimental/template.rkt | 0
.../racket/collects/syntax/parse/pre.rkt | 0
.../collects/syntax/parse/private/lib.rkt | 0
.../collects/syntax/parse/private/opt.rkt | 0
.../syntax/parse/private/parse-aux.rkt | 0
.../collects/syntax/parse/private/parse.rkt | 0
.../collects/syntax/parse/private/rep.rkt | 0
.../syntax/parse/private/residual.rkt | 0
.../syntax/parse/private/runtime-reflect.rkt | 0
.../syntax/parse/private/runtime-report.rkt | 0
.../collects/syntax/parse/private/runtime.rkt | 0
.../collects/syntax/parse/private/sc.rkt | 0
.../racket/private/stxcase-scheme.rkt | 77 ++
.../collects/racket/private/stxcase.rkt | 610 +++++++++++++
.../racket/collects/racket/private/stxloc.rkt | 80 ++
.../racket/collects/racket/private/syntax.rkt | 212 +++++
.../racket/private/template.rkt.deleted | 0
.../collects/racket/private/with-stx.rkt | 100 +++
6-12/racket/collects/syntax/parse.rkt | 31 +
.../racket/collects/syntax/parse/debug.rkt | 0
.../syntax/parse/experimental/contract.rkt | 40 +
.../private/substitute.rkt.deleted | 0
.../syntax/parse/experimental/provide.rkt | 0
.../syntax/parse/experimental/reflect.rkt | 0
.../syntax/parse/experimental/specialize.rkt | 0
.../syntax/parse/experimental/splicing.rkt | 0
.../syntax/parse/experimental/template.rkt | 0
.../racket/collects/syntax/parse/pre.rkt | 0
.../collects/syntax/parse/private/lib.rkt | 0
.../collects/syntax/parse/private/opt.rkt | 430 +++++++++
.../parse/private/parse-aux.rkt.deleted | 0
.../collects/syntax/parse/private/parse.rkt | 0
.../collects/syntax/parse/private/rep.rkt | 0
.../syntax/parse/private/residual.rkt | 0
.../syntax/parse/private/runtime-reflect.rkt | 0
.../syntax/parse/private/runtime-report.rkt | 0
.../collects/syntax/parse/private/runtime.rkt | 0
.../collects/syntax/parse/private/sc.rkt | 0
.../racket/private/stxcase-scheme.rkt | 0
.../collects/racket/private/stxcase.rkt | 0
.../racket/collects/racket/private/stxloc.rkt | 0
.../racket/collects/racket/private/syntax.rkt | 0
.../collects/racket/private/template.rkt | 0
.../collects/racket/private/with-stx.rkt | 0
6-90-0-29/racket/collects/syntax/parse.rkt | 31 +
.../racket/collects/syntax/parse/debug.rkt | 0
.../syntax/parse/experimental/contract.rkt | 40 +
.../private/substitute.rkt.deleted | 0
.../syntax/parse/experimental/provide.rkt | 0
.../syntax/parse/experimental/reflect.rkt | 0
.../syntax/parse/experimental/specialize.rkt | 0
.../syntax/parse/experimental/splicing.rkt | 0
.../syntax/parse/experimental/template.rkt | 0
.../racket/collects/syntax/parse/pre.rkt | 0
.../collects/syntax/parse/private/lib.rkt | 0
.../collects/syntax/parse/private/opt.rkt | 430 +++++++++
.../parse/private/parse-aux.rkt.deleted | 0
.../collects/syntax/parse/private/parse.rkt | 0
.../collects/syntax/parse/private/rep.rkt | 0
.../syntax/parse/private/residual.rkt | 0
.../syntax/parse/private/runtime-reflect.rkt | 0
.../syntax/parse/private/runtime-report.rkt | 0
.../collects/syntax/parse/private/runtime.rkt | 0
.../collects/syntax/parse/private/sc.rkt | 0
.../racket/private/stxcase-scheme.rkt | 77 ++
.../collects/racket/private/stxcase.rkt | 390 +++++++++
.../racket/collects/racket/private/stxloc.rkt | 59 ++
.../racket/collects/racket/private/syntax.rkt | 214 +++++
.../collects/racket/private/template.rkt | 732 ++++++++++++++++
.../collects/racket/private/with-stx.rkt | 100 +++
7-0-0-20/racket/collects/syntax/parse.rkt | 31 +
.../racket/collects/syntax/parse/debug.rkt | 0
.../syntax/parse/experimental/contract.rkt | 40 +
.../private/substitute.rkt.deleted | 0
.../syntax/parse/experimental/provide.rkt | 156 ++++
.../syntax/parse/experimental/reflect.rkt | 0
.../syntax/parse/experimental/specialize.rkt | 40 +
.../syntax/parse/experimental/splicing.rkt | 95 ++
.../syntax/parse/experimental/template.rkt | 55 ++
.../racket/collects/syntax/parse/pre.rkt | 0
.../collects/syntax/parse/private/lib.rkt | 0
.../collects/syntax/parse/private/opt.rkt | 0
.../parse/private/parse-aux.rkt.deleted | 0
.../collects/syntax/parse/private/parse.rkt | 0
.../collects/syntax/parse/private/rep.rkt | 0
.../syntax/parse/private/residual.rkt | 0
.../syntax/parse/private/runtime-reflect.rkt | 96 +++
.../syntax/parse/private/runtime-report.rkt | 815 ++++++++++++++++++
.../collects/syntax/parse/private/runtime.rkt | 235 +++++
.../collects/syntax/parse/private/sc.rkt | 0
.../racket/private/stxcase-scheme.rkt | 77 ++
.../collects/racket/private/stxcase.rkt | 390 +++++++++
.../racket/collects/racket/private/stxloc.rkt | 59 ++
.../racket/collects/racket/private/syntax.rkt | 214 +++++
.../collects/racket/private/template.rkt | 732 ++++++++++++++++
.../collects/racket/private/with-stx.rkt | 100 +++
.../racket/collects/syntax/parse.rkt | 0
.../racket/collects/syntax/parse/debug.rkt | 0
.../syntax/parse/experimental/contract.rkt | 0
.../private/substitute.rkt.deleted | 0
.../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 | 55 ++
7-3-0-1/racket/collects/syntax/parse/pre.rkt | 49 ++
.../collects/syntax/parse/private/lib.rkt | 96 +++
.../collects/syntax/parse/private/opt.rkt | 430 +++++++++
.../parse/private/parse-aux.rkt.deleted | 0
.../collects/syntax/parse/private/parse.rkt | 0
.../collects/syntax/parse/private/rep.rkt | 0
.../syntax/parse/private/residual.rkt | 302 +++++++
.../syntax/parse/private/runtime-reflect.rkt | 96 +++
.../syntax/parse/private/runtime-report.rkt | 815 ++++++++++++++++++
.../collects/syntax/parse/private/runtime.rkt | 235 +++++
.../collects/syntax/parse/private/sc.rkt | 32 +
case/stxcase-scheme.rkt | 7 +-
case/stxcase.rkt | 7 +-
case/stxloc.rkt | 7 +-
case/syntax.rkt | 7 +-
case/template.rkt | 2 +-
case/with-stx.rkt | 7 +-
generate-dispatch-6-11--6-12.sh | 33 -
info.rkt | 2 +-
parse.rkt | 4 +-
parse/debug.rkt | 10 +-
parse/experimental/contract.rkt | 4 +-
parse/experimental/private/substitute.rkt | 4 +-
parse/experimental/provide.rkt | 6 +-
parse/experimental/reflect.rkt | 8 +-
parse/experimental/specialize.rkt | 6 +-
parse/experimental/splicing.rkt | 6 +-
parse/experimental/template.rkt | 6 +-
parse/pre.rkt | 8 +-
parse/private/lib.rkt | 8 +-
parse/private/opt.rkt | 4 +-
parse/private/parse-aux.rkt | 4 +-
parse/private/parse.rkt | 10 +-
parse/private/rep.rkt | 10 +-
parse/private/residual.rkt | 8 +-
parse/private/runtime-reflect.rkt | 6 +-
parse/private/runtime-report.rkt | 6 +-
parse/private/runtime.rkt | 6 +-
parse/private/sc.rkt | 8 +-
158 files changed, 9422 insertions(+), 118 deletions(-)
rename case/stxcase-scheme.rkt-6-11 => 6-11/racket/collects/racket/private/stxcase-scheme.rkt (100%)
rename case/stxcase.rkt-6-11 => 6-11/racket/collects/racket/private/stxcase.rkt (100%)
rename case/stxloc.rkt-6-11 => 6-11/racket/collects/racket/private/stxloc.rkt (100%)
rename case/syntax.rkt-6-11 => 6-11/racket/collects/racket/private/syntax.rkt (100%)
rename parse/experimental/private/substitute.rkt-6-12.deleted => 6-11/racket/collects/racket/private/template.rkt.deleted (100%)
rename case/with-stx.rkt-6-11 => 6-11/racket/collects/racket/private/with-stx.rkt (100%)
rename parse.rkt-7-0-0-20 => 6-11/racket/collects/syntax/parse.rkt (100%)
rename parse/debug.rkt-6-11 => 6-11/racket/collects/syntax/parse/debug.rkt (100%)
rename parse/experimental/contract.rkt-7-0-0-20 => 6-11/racket/collects/syntax/parse/experimental/contract.rkt (100%)
rename parse/experimental/private/substitute.rkt-6-11 => 6-11/racket/collects/syntax/parse/experimental/private/substitute.rkt (100%)
rename parse/experimental/provide.rkt-6-11 => 6-11/racket/collects/syntax/parse/experimental/provide.rkt (100%)
rename parse/experimental/reflect.rkt-6-11 => 6-11/racket/collects/syntax/parse/experimental/reflect.rkt (100%)
rename parse/experimental/specialize.rkt-6-11 => 6-11/racket/collects/syntax/parse/experimental/specialize.rkt (100%)
rename parse/experimental/splicing.rkt-6-11 => 6-11/racket/collects/syntax/parse/experimental/splicing.rkt (100%)
rename parse/experimental/template.rkt-6-11 => 6-11/racket/collects/syntax/parse/experimental/template.rkt (100%)
rename parse/pre.rkt-6-11 => 6-11/racket/collects/syntax/parse/pre.rkt (100%)
rename parse/private/lib.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/lib.rkt (100%)
rename parse/private/opt.rkt-6-90-0-29 => 6-11/racket/collects/syntax/parse/private/opt.rkt (100%)
rename parse/private/parse-aux.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/parse-aux.rkt (100%)
rename parse/private/parse.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/parse.rkt (100%)
rename parse/private/rep.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/rep.rkt (100%)
rename parse/private/residual.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/residual.rkt (100%)
rename parse/private/runtime-reflect.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/runtime-reflect.rkt (100%)
rename parse/private/runtime-report.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/runtime-report.rkt (100%)
rename parse/private/runtime.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/runtime.rkt (100%)
rename parse/private/sc.rkt-6-11 => 6-11/racket/collects/syntax/parse/private/sc.rkt (100%)
create mode 100644 6-12/racket/collects/racket/private/stxcase-scheme.rkt
create mode 100644 6-12/racket/collects/racket/private/stxcase.rkt
create mode 100644 6-12/racket/collects/racket/private/stxloc.rkt
create mode 100644 6-12/racket/collects/racket/private/syntax.rkt
rename parse/private/parse-aux.rkt-6-12.deleted => 6-12/racket/collects/racket/private/template.rkt.deleted (100%)
create mode 100644 6-12/racket/collects/racket/private/with-stx.rkt
create mode 100644 6-12/racket/collects/syntax/parse.rkt
rename parse/debug.rkt-6-12 => 6-12/racket/collects/syntax/parse/debug.rkt (100%)
create mode 100644 6-12/racket/collects/syntax/parse/experimental/contract.rkt
create mode 100644 6-12/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
rename parse/experimental/provide.rkt-6-12 => 6-12/racket/collects/syntax/parse/experimental/provide.rkt (100%)
rename parse/experimental/reflect.rkt-6-12 => 6-12/racket/collects/syntax/parse/experimental/reflect.rkt (100%)
rename parse/experimental/specialize.rkt-6-12 => 6-12/racket/collects/syntax/parse/experimental/specialize.rkt (100%)
rename parse/experimental/splicing.rkt-6-12 => 6-12/racket/collects/syntax/parse/experimental/splicing.rkt (100%)
rename parse/experimental/template.rkt-6-12 => 6-12/racket/collects/syntax/parse/experimental/template.rkt (100%)
rename parse/pre.rkt-6-12 => 6-12/racket/collects/syntax/parse/pre.rkt (100%)
rename parse/private/lib.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/lib.rkt (100%)
create mode 100644 6-12/racket/collects/syntax/parse/private/opt.rkt
create mode 100644 6-12/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
rename parse/private/parse.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/parse.rkt (100%)
rename parse/private/rep.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/rep.rkt (100%)
rename parse/private/residual.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/residual.rkt (100%)
rename parse/private/runtime-reflect.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/runtime-reflect.rkt (100%)
rename parse/private/runtime-report.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/runtime-report.rkt (100%)
rename parse/private/runtime.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/runtime.rkt (100%)
rename parse/private/sc.rkt-6-12 => 6-12/racket/collects/syntax/parse/private/sc.rkt (100%)
rename case/stxcase-scheme.rkt-6-90-0-29 => 6-90-0-29/racket/collects/racket/private/stxcase-scheme.rkt (100%)
rename case/stxcase.rkt-6-90-0-29 => 6-90-0-29/racket/collects/racket/private/stxcase.rkt (100%)
rename case/stxloc.rkt-6-90-0-29 => 6-90-0-29/racket/collects/racket/private/stxloc.rkt (100%)
rename case/syntax.rkt-6-90-0-29 => 6-90-0-29/racket/collects/racket/private/syntax.rkt (100%)
rename case/template.rkt-6-90-0-29 => 6-90-0-29/racket/collects/racket/private/template.rkt (100%)
rename case/with-stx.rkt-6-90-0-29 => 6-90-0-29/racket/collects/racket/private/with-stx.rkt (100%)
create mode 100644 6-90-0-29/racket/collects/syntax/parse.rkt
rename parse/debug.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/debug.rkt (100%)
create mode 100644 6-90-0-29/racket/collects/syntax/parse/experimental/contract.rkt
create mode 100644 6-90-0-29/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
rename parse/experimental/provide.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/experimental/provide.rkt (100%)
rename parse/experimental/reflect.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/experimental/reflect.rkt (100%)
rename parse/experimental/specialize.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/experimental/specialize.rkt (100%)
rename parse/experimental/splicing.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/experimental/splicing.rkt (100%)
rename parse/experimental/template.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/experimental/template.rkt (100%)
rename parse/pre.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/pre.rkt (100%)
rename parse/private/lib.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/lib.rkt (100%)
create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/opt.rkt
create mode 100644 6-90-0-29/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
rename parse/private/parse.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/parse.rkt (100%)
rename parse/private/rep.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/rep.rkt (100%)
rename parse/private/residual.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/residual.rkt (100%)
rename parse/private/runtime-reflect.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/runtime-reflect.rkt (100%)
rename parse/private/runtime-report.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/runtime-report.rkt (100%)
rename parse/private/runtime.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/runtime.rkt (100%)
rename parse/private/sc.rkt-6-90-0-29 => 6-90-0-29/racket/collects/syntax/parse/private/sc.rkt (100%)
create mode 100644 7-0-0-20/racket/collects/racket/private/stxcase-scheme.rkt
create mode 100644 7-0-0-20/racket/collects/racket/private/stxcase.rkt
create mode 100644 7-0-0-20/racket/collects/racket/private/stxloc.rkt
create mode 100644 7-0-0-20/racket/collects/racket/private/syntax.rkt
create mode 100644 7-0-0-20/racket/collects/racket/private/template.rkt
create mode 100644 7-0-0-20/racket/collects/racket/private/with-stx.rkt
create mode 100644 7-0-0-20/racket/collects/syntax/parse.rkt
rename parse/debug.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/debug.rkt (100%)
create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt
create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/provide.rkt
rename parse/experimental/reflect.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/experimental/reflect.rkt (100%)
create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/specialize.rkt
create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/splicing.rkt
create mode 100644 7-0-0-20/racket/collects/syntax/parse/experimental/template.rkt
rename parse/pre.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/pre.rkt (100%)
rename parse/private/lib.rkt-7-3-0-1 => 7-0-0-20/racket/collects/syntax/parse/private/lib.rkt (100%)
rename parse/private/opt.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/private/opt.rkt (100%)
create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
rename parse/private/parse.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/private/parse.rkt (100%)
rename parse/private/rep.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/private/rep.rkt (100%)
rename parse/private/residual.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/private/residual.rkt (100%)
create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/runtime-reflect.rkt
create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/runtime-report.rkt
create mode 100644 7-0-0-20/racket/collects/syntax/parse/private/runtime.rkt
rename parse/private/sc.rkt-7-0-0-20 => 7-0-0-20/racket/collects/syntax/parse/private/sc.rkt (100%)
create mode 100644 7-3-0-1/racket/collects/racket/private/stxcase-scheme.rkt
create mode 100644 7-3-0-1/racket/collects/racket/private/stxcase.rkt
create mode 100644 7-3-0-1/racket/collects/racket/private/stxloc.rkt
create mode 100644 7-3-0-1/racket/collects/racket/private/syntax.rkt
create mode 100644 7-3-0-1/racket/collects/racket/private/template.rkt
create mode 100644 7-3-0-1/racket/collects/racket/private/with-stx.rkt
rename parse.rkt-7-3-0-1 => 7-3-0-1/racket/collects/syntax/parse.rkt (100%)
rename parse/debug.rkt-7-3-0-1 => 7-3-0-1/racket/collects/syntax/parse/debug.rkt (100%)
rename parse/experimental/contract.rkt-7-3-0-1 => 7-3-0-1/racket/collects/syntax/parse/experimental/contract.rkt (100%)
create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/provide.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/reflect.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/specialize.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/splicing.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/experimental/template.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/pre.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/lib.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/opt.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
rename parse/private/parse.rkt-7-3-0-1 => 7-3-0-1/racket/collects/syntax/parse/private/parse.rkt (100%)
rename parse/private/rep.rkt-7-3-0-1 => 7-3-0-1/racket/collects/syntax/parse/private/rep.rkt (100%)
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/residual.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/runtime-reflect.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/runtime-report.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/runtime.rkt
create mode 100644 7-3-0-1/racket/collects/syntax/parse/private/sc.rkt
delete mode 100755 generate-dispatch-6-11--6-12.sh
diff --git a/case/stxcase-scheme.rkt-6-11 b/6-11/racket/collects/racket/private/stxcase-scheme.rkt
similarity index 100%
rename from case/stxcase-scheme.rkt-6-11
rename to 6-11/racket/collects/racket/private/stxcase-scheme.rkt
diff --git a/case/stxcase.rkt-6-11 b/6-11/racket/collects/racket/private/stxcase.rkt
similarity index 100%
rename from case/stxcase.rkt-6-11
rename to 6-11/racket/collects/racket/private/stxcase.rkt
diff --git a/case/stxloc.rkt-6-11 b/6-11/racket/collects/racket/private/stxloc.rkt
similarity index 100%
rename from case/stxloc.rkt-6-11
rename to 6-11/racket/collects/racket/private/stxloc.rkt
diff --git a/case/syntax.rkt-6-11 b/6-11/racket/collects/racket/private/syntax.rkt
similarity index 100%
rename from case/syntax.rkt-6-11
rename to 6-11/racket/collects/racket/private/syntax.rkt
diff --git a/parse/experimental/private/substitute.rkt-6-12.deleted b/6-11/racket/collects/racket/private/template.rkt.deleted
similarity index 100%
rename from parse/experimental/private/substitute.rkt-6-12.deleted
rename to 6-11/racket/collects/racket/private/template.rkt.deleted
diff --git a/case/with-stx.rkt-6-11 b/6-11/racket/collects/racket/private/with-stx.rkt
similarity index 100%
rename from case/with-stx.rkt-6-11
rename to 6-11/racket/collects/racket/private/with-stx.rkt
diff --git a/parse.rkt-7-0-0-20 b/6-11/racket/collects/syntax/parse.rkt
similarity index 100%
rename from parse.rkt-7-0-0-20
rename to 6-11/racket/collects/syntax/parse.rkt
diff --git a/parse/debug.rkt-6-11 b/6-11/racket/collects/syntax/parse/debug.rkt
similarity index 100%
rename from parse/debug.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/debug.rkt
diff --git a/parse/experimental/contract.rkt-7-0-0-20 b/6-11/racket/collects/syntax/parse/experimental/contract.rkt
similarity index 100%
rename from parse/experimental/contract.rkt-7-0-0-20
rename to 6-11/racket/collects/syntax/parse/experimental/contract.rkt
diff --git a/parse/experimental/private/substitute.rkt-6-11 b/6-11/racket/collects/syntax/parse/experimental/private/substitute.rkt
similarity index 100%
rename from parse/experimental/private/substitute.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/experimental/private/substitute.rkt
diff --git a/parse/experimental/provide.rkt-6-11 b/6-11/racket/collects/syntax/parse/experimental/provide.rkt
similarity index 100%
rename from parse/experimental/provide.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/experimental/provide.rkt
diff --git a/parse/experimental/reflect.rkt-6-11 b/6-11/racket/collects/syntax/parse/experimental/reflect.rkt
similarity index 100%
rename from parse/experimental/reflect.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/experimental/reflect.rkt
diff --git a/parse/experimental/specialize.rkt-6-11 b/6-11/racket/collects/syntax/parse/experimental/specialize.rkt
similarity index 100%
rename from parse/experimental/specialize.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/experimental/specialize.rkt
diff --git a/parse/experimental/splicing.rkt-6-11 b/6-11/racket/collects/syntax/parse/experimental/splicing.rkt
similarity index 100%
rename from parse/experimental/splicing.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/experimental/splicing.rkt
diff --git a/parse/experimental/template.rkt-6-11 b/6-11/racket/collects/syntax/parse/experimental/template.rkt
similarity index 100%
rename from parse/experimental/template.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/experimental/template.rkt
diff --git a/parse/pre.rkt-6-11 b/6-11/racket/collects/syntax/parse/pre.rkt
similarity index 100%
rename from parse/pre.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/pre.rkt
diff --git a/parse/private/lib.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/lib.rkt
similarity index 100%
rename from parse/private/lib.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/lib.rkt
diff --git a/parse/private/opt.rkt-6-90-0-29 b/6-11/racket/collects/syntax/parse/private/opt.rkt
similarity index 100%
rename from parse/private/opt.rkt-6-90-0-29
rename to 6-11/racket/collects/syntax/parse/private/opt.rkt
diff --git a/parse/private/parse-aux.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/parse-aux.rkt
similarity index 100%
rename from parse/private/parse-aux.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/parse-aux.rkt
diff --git a/parse/private/parse.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/parse.rkt
similarity index 100%
rename from parse/private/parse.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/parse.rkt
diff --git a/parse/private/rep.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/rep.rkt
similarity index 100%
rename from parse/private/rep.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/rep.rkt
diff --git a/parse/private/residual.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/residual.rkt
similarity index 100%
rename from parse/private/residual.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/residual.rkt
diff --git a/parse/private/runtime-reflect.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/runtime-reflect.rkt
similarity index 100%
rename from parse/private/runtime-reflect.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/runtime-reflect.rkt
diff --git a/parse/private/runtime-report.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/runtime-report.rkt
similarity index 100%
rename from parse/private/runtime-report.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/runtime-report.rkt
diff --git a/parse/private/runtime.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/runtime.rkt
similarity index 100%
rename from parse/private/runtime.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/runtime.rkt
diff --git a/parse/private/sc.rkt-6-11 b/6-11/racket/collects/syntax/parse/private/sc.rkt
similarity index 100%
rename from parse/private/sc.rkt-6-11
rename to 6-11/racket/collects/syntax/parse/private/sc.rkt
diff --git a/6-12/racket/collects/racket/private/stxcase-scheme.rkt b/6-12/racket/collects/racket/private/stxcase-scheme.rkt
new file mode 100644
index 0000000..0b29f81
--- /dev/null
+++ b/6-12/racket/collects/racket/private/stxcase-scheme.rkt
@@ -0,0 +1,77 @@
+
+;;----------------------------------------------------------------------
+;; #%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" racket/private/stxloc
+ (for-syntax '#%kernel racket/private/small-scheme
+ racket/private/stx "stxcase.rkt"
+ racket/private/stxloc))
+
+ (-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 racket/private/stxloc)
+ check-duplicate-identifier syntax-protect
+ syntax-rules syntax-id-rules
+ (for-syntax syntax-pattern-variable?)))
diff --git a/6-12/racket/collects/racket/private/stxcase.rkt b/6-12/racket/collects/racket/private/stxcase.rkt
new file mode 100644
index 0000000..6ac4211
--- /dev/null
+++ b/6-12/racket/collects/racket/private/stxcase.rkt
@@ -0,0 +1,610 @@
+;;----------------------------------------------------------------------
+;; 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/member racket/private/sc '#%kernel
+ auto-syntax-e/utils))
+
+ (-define (datum->syntax/shape orig datum)
+ (if (syntax? datum)
+ datum
+ ;; Keeps 'paren-shape and any other properties:
+ (datum->syntax orig datum orig orig)))
+
+ (-define (catch-ellipsis-error thunk sexp sloc)
+ ((let/ec esc
+ (with-continuation-mark
+ exception-handler-key
+ (lambda (exn)
+ (esc
+ (lambda ()
+ (if (exn:break? exn)
+ (raise exn)
+ (raise-syntax-error
+ 'syntax
+ "incompatible ellipsis match counts for template"
+ sexp
+ sloc)))))
+ (let ([v (thunk)])
+ (lambda () v))))))
+
+ (-define substitute-stop 'dummy)
+
+ ;; pattern-substitute optimizes a pattern substitution by
+ ;; merging variables that look up the same simple mapping
+ (-define-syntax pattern-substitute
+ (lambda (stx)
+ (let ([pat (stx-car (stx-cdr stx))]
+ [subs (stx->list (stx-cdr (stx-cdr stx)))])
+ (let ([ht-common (make-hash)]
+ [ht-map (make-hasheq)])
+ ;; Determine merges:
+ (let loop ([subs subs])
+ (unless (null? subs)
+ (let ([id (syntax-e (car subs))]
+ [expr (cadr subs)])
+ (when (or (identifier? expr)
+ (and (stx-pair? expr)
+ (memq (syntax-e (stx-car expr))
+ '(car cadr caddr cadddr
+ cdr cddr cdddr cddddr
+ list-ref list-tail))
+ (stx-pair? (stx-cdr expr))
+ (identifier? (stx-car (stx-cdr expr)))))
+ (let ([s-expr (syntax->datum expr)])
+ (let ([new-id (hash-ref ht-common s-expr #f)])
+ (if new-id
+ (hash-set! ht-map id new-id)
+ (hash-set! ht-common s-expr id))))))
+ (loop (cddr subs))))
+ ;; Merge:
+ (let ([new-pattern (if (zero? (hash-count ht-map))
+ pat
+ (let loop ([stx pat])
+ (cond
+ [(pair? stx)
+ (let ([a (loop (car stx))]
+ [b (loop (cdr stx))])
+ (if (and (eq? a (car stx))
+ (eq? b (cdr stx)))
+ stx
+ (cons a b)))]
+ [(symbol? stx)
+ (let ([new-id (hash-ref ht-map stx #f)])
+ (or new-id stx))]
+ [(syntax? stx)
+ (let ([new-e (loop (syntax-e stx))])
+ (if (eq? (syntax-e stx) new-e)
+ stx
+ (datum->syntax stx new-e stx stx)))]
+ [(vector? stx)
+ (list->vector (map loop (vector->list stx)))]
+ [(box? stx) (box (loop (unbox stx)))]
+ [else stx])))])
+ (datum->syntax (quote-syntax here)
+ `(apply-pattern-substitute
+ ,new-pattern
+ (quote ,(let loop ([subs subs])
+ (cond
+ [(null? subs) null]
+ [(hash-ref ht-map (syntax-e (car subs)) #f)
+ ;; Drop mapped id
+ (loop (cddr subs))]
+ [else
+ (cons (car subs) (loop (cddr subs)))])))
+ . ,(let loop ([subs subs])
+ (cond
+ [(null? subs) null]
+ [(hash-ref ht-map (syntax-e (car subs)) #f)
+ ;; Drop mapped id
+ (loop (cddr subs))]
+ [else
+ (cons (cadr subs) (loop (cddr subs)))])))
+ stx))))))
+
+ (-define apply-pattern-substitute
+ (lambda (stx sub-ids . sub-vals)
+ (let loop ([stx stx])
+ (cond
+ [(pair? stx) (let ([a (loop (car stx))]
+ [b (loop (cdr stx))])
+ (if (and (eq? a (car stx))
+ (eq? b (cdr stx)))
+ stx
+ (cons a b)))]
+ [(symbol? stx)
+ (let sloop ([sub-ids sub-ids][sub-vals sub-vals])
+ (cond
+ [(null? sub-ids) stx]
+ [(eq? stx (car sub-ids)) (car sub-vals)]
+ [else (sloop (cdr sub-ids) (cdr sub-vals))]))]
+ [(syntax? stx)
+ (let ([new-e (loop (syntax-e stx))])
+ (if (eq? (syntax-e stx) new-e)
+ stx
+ (datum->syntax/shape stx new-e)))]
+ [(vector? stx)
+ (list->vector (map loop (vector->list stx)))]
+ [(box? stx) (box (loop (unbox stx)))]
+ [else stx]))))
+
+ (-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)))))))
+
+ (begin-for-syntax
+ (define-values (gen-template)
+ (lambda (x s-exp?)
+ (-define here-stx (quote-syntax here))
+ (unless (and (stx-pair? x)
+ (let ([rest (stx-cdr x)])
+ (and (stx-pair? rest)
+ (stx-null? (stx-cdr rest)))))
+ (raise-syntax-error
+ #f
+ "bad form"
+ x))
+ (syntax-arm
+ (datum->syntax
+ here-stx
+ (let ([pattern (stx-car (stx-cdr x))])
+ (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)])
+ (let ([var-bindings
+ (map
+ (lambda (var)
+ (and (let ([v (syntax-local-value var (lambda () #f))])
+ (and (if s-exp?
+ (s-exp-pattern-variable? v)
+ (syntax-pattern-variable? v))
+ v))))
+ unique-vars)])
+ (if (and (or (null? var-bindings)
+ (not (ormap (lambda (x) x) var-bindings)))
+ (no-ellipses? pattern))
+ ;; Constant template:
+ (list (if s-exp?
+ (quote-syntax quote)
+ (quote-syntax quote-syntax))
+ pattern)
+ ;; Non-constant:
+ (let ([proto-r (let loop ([vars unique-vars][bindings var-bindings])
+ (if (null? bindings)
+ null
+ (let ([rest (loop (cdr vars)
+ (cdr bindings))])
+ (if (car bindings)
+ (cons (let loop ([v (car vars)]
+ [d (if s-exp?
+ (s-exp-mapping-depth (car bindings))
+ (syntax-mapping-depth (car bindings)))])
+ (if (zero? d)
+ v
+ (loop (list v) (sub1 d))))
+ rest)
+ rest))))]
+ [non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings])
+ (if (null? bindings)
+ null
+ (let ([rest (loop (cdr vars)
+ (cdr bindings))])
+ (if (car bindings)
+ rest
+ (cons (car vars) rest)))))])
+ (let ([build-from-template
+ ;; Even if we don't use the builder, we need to check
+ ;; for a well-formed pattern:
+ (make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)]
+ [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss])
+ (cond
+ [(null? bindings) null]
+ [(car bindings)
+ (cons
+ (syntax-property
+ (let ([id (if s-exp?
+ (s-exp-mapping-valvar (car bindings))
+ (syntax-mapping-valvar (car bindings)))])
+ (datum->syntax
+ id
+ (syntax-e id)
+ x))
+ 'disappeared-use
+ (map syntax-local-introduce (car all-varss)))
+ (loop (cdr vars) (cdr bindings) (cdr all-varss)))]
+ [else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))])
+ (if (identifier? pattern)
+ ;; Simple syntax-id lookup:
+ (car r)
+ ;; General case:
+ (list (datum->syntax
+ here-stx
+ build-from-template
+ pattern)
+ (let ([len (length r)])
+ (cond
+ [(zero? len) (quote-syntax ())]
+ [(= len 1) (car r)]
+ [else
+ (cons (quote-syntax list*) r)]))))))))))
+ x)))))
+
+ (-define-syntax syntax (lambda (stx) (gen-template stx #f)))
+ (-define-syntax datum (lambda (stx) (gen-template stx #t)))
+
+ (#%provide (all-from racket/private/ellipses) syntax-case** syntax datum
+ (for-syntax syntax-pattern-variable?)))
diff --git a/6-12/racket/collects/racket/private/stxloc.rkt b/6-12/racket/collects/racket/private/stxloc.rkt
new file mode 100644
index 0000000..6444aa1
--- /dev/null
+++ b/6-12/racket/collects/racket/private/stxloc.rkt
@@ -0,0 +1,80 @@
+
+;;----------------------------------------------------------------------
+;; 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 (relocate loc stx)
+ (if (or (syntax-source loc)
+ (syntax-position loc))
+ (datum->syntax stx
+ (syntax-e stx)
+ loc
+ stx)
+ stx))
+
+ ;; Like syntax, but also takes a syntax object
+ ;; that supplies a source location for the
+ ;; resulting syntax object.
+ (-define-syntax syntax/loc
+ (lambda (stx)
+ (syntax-case** #f #t stx () free-identifier=? #f
+ [(_ loc pattern)
+ (if (if (symbol? (syntax-e #'pattern))
+ (syntax-pattern-variable? (syntax-local-value #'pattern (lambda () #f)))
+ #f)
+ (syntax (syntax pattern))
+ (syntax (relocate loc (syntax pattern))))])))
+
+ (-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/6-12/racket/collects/racket/private/syntax.rkt b/6-12/racket/collects/racket/private/syntax.rkt
new file mode 100644
index 0000000..b9ebea0
--- /dev/null
+++ b/6-12/racket/collects/racket/private/syntax.rkt
@@ -0,0 +1,212 @@
+#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)
+ (cond
+ [(identifier? ids) (record-disappeared-uses (list ids))]
+ [(and (list? ids) (andmap identifier? ids))
+ (let ([uses (current-recorded-disappeared-uses)])
+ (when uses
+ (current-recorded-disappeared-uses
+ (append
+ (if (syntax-transforming?)
+ (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))))
+
+;; Applies the renaming of intdefs to stx.
+(define (internal-definition-context-apply intdefs stx)
+ (let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)])
+ (with-syntax ([(q astx) qastx]) #'astx)))
+
+(define (syntax-local-eval stx [intdef0 #f])
+ (let* ([name (generate-temporary)]
+ [intdefs (syntax-local-make-definition-context intdef0)])
+ (syntax-local-bind-syntaxes (list name)
+ #`(call-with-values (lambda () #,stx) list)
+ intdefs)
+ (internal-definition-context-seal intdefs)
+ (apply values
+ (syntax-local-value (internal-definition-context-apply intdefs name)
+ #f intdefs))))
+
+(define-syntax (with-syntax* stx)
+ (syntax-case stx ()
+ [(_ (cl) body ...) #'(with-syntax (cl) body ...)]
+ [(_ (cl cls ...) body ...)
+ #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
diff --git a/parse/private/parse-aux.rkt-6-12.deleted b/6-12/racket/collects/racket/private/template.rkt.deleted
similarity index 100%
rename from parse/private/parse-aux.rkt-6-12.deleted
rename to 6-12/racket/collects/racket/private/template.rkt.deleted
diff --git a/6-12/racket/collects/racket/private/with-stx.rkt b/6-12/racket/collects/racket/private/with-stx.rkt
new file mode 100644
index 0000000..9dfa546
--- /dev/null
+++ b/6-12/racket/collects/racket/private/with-stx.rkt
@@ -0,0 +1,100 @@
+;;----------------------------------------------------------------------
+;; 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"
+ racket/private/stxloc 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 (begin 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/6-12/racket/collects/syntax/parse.rkt b/6-12/racket/collects/syntax/parse.rkt
new file mode 100644
index 0000000..c28072d
--- /dev/null
+++ b/6-12/racket/collects/syntax/parse.rkt
@@ -0,0 +1,31 @@
+#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
+ [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/parse/debug.rkt-6-12 b/6-12/racket/collects/syntax/parse/debug.rkt
similarity index 100%
rename from parse/debug.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/debug.rkt
diff --git a/6-12/racket/collects/syntax/parse/experimental/contract.rkt b/6-12/racket/collects/syntax/parse/experimental/contract.rkt
new file mode 100644
index 0000000..5d5144b
--- /dev/null
+++ b/6-12/racket/collects/syntax/parse/experimental/contract.rkt
@@ -0,0 +1,40 @@
+#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
+ #:positive [pos-blame 'use-site]
+ #:negative [neg-blame 'from-macro]
+ #:macro [macro-name #f]
+ #:name [expr-name not-given]
+ #:context [ctx #f])
+ #:attributes (c)
+ #:commit
+ (pattern y:expr
+ #:with
+ c (wrap-expr/c ctc-stx
+ #'y
+ #: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)))))
+
+(provide-syntax-class/contract
+ [expr/c (syntax-class/c (syntax?)
+ (#: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)))])
diff --git a/6-12/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted b/6-12/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/parse/experimental/provide.rkt-6-12 b/6-12/racket/collects/syntax/parse/experimental/provide.rkt
similarity index 100%
rename from parse/experimental/provide.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/experimental/provide.rkt
diff --git a/parse/experimental/reflect.rkt-6-12 b/6-12/racket/collects/syntax/parse/experimental/reflect.rkt
similarity index 100%
rename from parse/experimental/reflect.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/experimental/reflect.rkt
diff --git a/parse/experimental/specialize.rkt-6-12 b/6-12/racket/collects/syntax/parse/experimental/specialize.rkt
similarity index 100%
rename from parse/experimental/specialize.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/experimental/specialize.rkt
diff --git a/parse/experimental/splicing.rkt-6-12 b/6-12/racket/collects/syntax/parse/experimental/splicing.rkt
similarity index 100%
rename from parse/experimental/splicing.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/experimental/splicing.rkt
diff --git a/parse/experimental/template.rkt-6-12 b/6-12/racket/collects/syntax/parse/experimental/template.rkt
similarity index 100%
rename from parse/experimental/template.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/experimental/template.rkt
diff --git a/parse/pre.rkt-6-12 b/6-12/racket/collects/syntax/parse/pre.rkt
similarity index 100%
rename from parse/pre.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/pre.rkt
diff --git a/parse/private/lib.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/lib.rkt
similarity index 100%
rename from parse/private/lib.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/lib.rkt
diff --git a/6-12/racket/collects/syntax/parse/private/opt.rkt b/6-12/racket/collects/syntax/parse/private/opt.rkt
new file mode 100644
index 0000000..0c04788
--- /dev/null
+++ b/6-12/racket/collects/syntax/parse/private/opt.rkt
@@ -0,0 +1,430 @@
+#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]))
+
+;; controls debugging output for optimization successes and failures
+(define DEBUG-OPT-SUCCEED #f)
+(define DEBUG-OPT-FAIL #f)
+
+;; ----
+
+;; 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.
+
+;; ----
+
+(define (optimize-matrix0 rows)
+ (define now (current-inexact-milliseconds))
+ (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
+ (eprintf "\n%% optimizing (~s):\n" (length rows))
+ (pretty-write (matrix->sexpr rows) (current-error-port)))
+ (define result (optimize-matrix rows))
+ (define then (current-inexact-milliseconds))
+ (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
+ (cond [(= (length result) (length rows))
+ (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
+ [else
+ (eprintf "==> (~s ms)\n" (floor (- then now)))
+ (pretty-write (matrix->sexpr result) (current-error-port))
+ (eprintf "\n")]))
+ 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)
+ (when DEBUG-OPT-SUCCEED
+ (eprintf "-- accumulated ~s rows like ~e\n" (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)
+ (when DEBUG-OPT-SUCCEED
+ (eprintf "-- accumulated ~s rows like ~e\n" (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)
+ (when DEBUG-OPT-FAIL
+ (when (pattern-equal? pat1 pat2)
+ (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,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))
+ (when #f ;; DEBUG-OPT-SUCCEED
+ (eprintf ">> unfolding: ~e\n" p))
+ (unfold-and first-sub (*append rest-subs onto))]
+ [else (values p onto)]))]
+ [_ (values p onto)]))
+
+(define (pattern-factorable? p)
+ ;; Can factor out p if p can succeed at most once, does not cut
+ ;; - if p can succeed multiple times, then factoring changes success order
+ ;; - if p can cut, then factoring changes which choice points are discarded (too few)
+ (match p
+ [(pat:any) #t]
+ [(pat:svar _n) #t]
+ [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
+ ;; commit? implies delimit-cut
+ commit?]
+ [(? pat:integrated?) #t]
+ [(pat:literal _lit _ip _lp) #t]
+ [(pat:datum _datum) #t]
+ [(pat:action _act _pat) #f]
+ [(pat:head head tail)
+ (and (pattern-factorable? head)
+ (pattern-factorable? tail))]
+ [(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.
+ (and (= (length heads) 1)
+ (let ([head (car heads)])
+ (and (pattern-factorable? head)))
+ (equal? tail (pat:datum '())))]
+ [(pat:and patterns)
+ (andmap pattern-factorable? patterns)]
+ [(pat:or patterns) #f]
+ [(pat:not pattern) #f] ;; FIXME: ?
+ [(pat:pair head tail)
+ (and (pattern-factorable? head)
+ (pattern-factorable? tail))]
+ [(pat:vector pattern)
+ (pattern-factorable? pattern)]
+ [(pat:box pattern)
+ (pattern-factorable? pattern)]
+ [(pat:pstruct key pattern)
+ (pattern-factorable? pattern)]
+ [(pat:describe pattern _desc _trans _role)
+ (pattern-factorable? pattern)]
+ [(pat:delimit pattern)
+ (pattern-factorable? pattern)]
+ [(pat:commit pattern) #t]
+ [(? pat:reflect?) #f]
+ [(pat:ord pattern _ _)
+ (pattern-factorable? pattern)]
+ [(pat:post pattern)
+ (pattern-factorable? pattern)]
+ ;; ----
+ [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
+ commit?]
+ [(hpat:seq inner)
+ (pattern-factorable? inner)]
+ [(hpat:commit inner) #t]
+ ;; ----
+ [(ehpat head repc)
+ (and (equal? repc #f)
+ (pattern-factorable? head))]
+ ;; ----
+ [else #f]))
+
+(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 (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 DEBUG-OPT-FAIL
+ (when (and (eq? result #f)
+ (equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
+ (eprintf "** pattern-equal? failed on ~e\n" 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?) `(quote ,(syntax->datum (pat:literal-id p)))]
+ [(pat:datum datum) datum]
+ [(? pat:action?) 'ACTION]
+ [(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))]
+ [(ehpat _as hpat '#f _cn)
+ (pattern->sexpr hpat)]
+ [_ 'PATTERN]))
diff --git a/6-12/racket/collects/syntax/parse/private/parse-aux.rkt.deleted b/6-12/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/parse/private/parse.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/parse.rkt
similarity index 100%
rename from parse/private/parse.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/parse.rkt
diff --git a/parse/private/rep.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/rep.rkt
similarity index 100%
rename from parse/private/rep.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/rep.rkt
diff --git a/parse/private/residual.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/residual.rkt
similarity index 100%
rename from parse/private/residual.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/residual.rkt
diff --git a/parse/private/runtime-reflect.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/runtime-reflect.rkt
similarity index 100%
rename from parse/private/runtime-reflect.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/runtime-reflect.rkt
diff --git a/parse/private/runtime-report.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/runtime-report.rkt
similarity index 100%
rename from parse/private/runtime-report.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/runtime-report.rkt
diff --git a/parse/private/runtime.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/runtime.rkt
similarity index 100%
rename from parse/private/runtime.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/runtime.rkt
diff --git a/parse/private/sc.rkt-6-12 b/6-12/racket/collects/syntax/parse/private/sc.rkt
similarity index 100%
rename from parse/private/sc.rkt-6-12
rename to 6-12/racket/collects/syntax/parse/private/sc.rkt
diff --git a/case/stxcase-scheme.rkt-6-90-0-29 b/6-90-0-29/racket/collects/racket/private/stxcase-scheme.rkt
similarity index 100%
rename from case/stxcase-scheme.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/racket/private/stxcase-scheme.rkt
diff --git a/case/stxcase.rkt-6-90-0-29 b/6-90-0-29/racket/collects/racket/private/stxcase.rkt
similarity index 100%
rename from case/stxcase.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/racket/private/stxcase.rkt
diff --git a/case/stxloc.rkt-6-90-0-29 b/6-90-0-29/racket/collects/racket/private/stxloc.rkt
similarity index 100%
rename from case/stxloc.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/racket/private/stxloc.rkt
diff --git a/case/syntax.rkt-6-90-0-29 b/6-90-0-29/racket/collects/racket/private/syntax.rkt
similarity index 100%
rename from case/syntax.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/racket/private/syntax.rkt
diff --git a/case/template.rkt-6-90-0-29 b/6-90-0-29/racket/collects/racket/private/template.rkt
similarity index 100%
rename from case/template.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/racket/private/template.rkt
diff --git a/case/with-stx.rkt-6-90-0-29 b/6-90-0-29/racket/collects/racket/private/with-stx.rkt
similarity index 100%
rename from case/with-stx.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/racket/private/with-stx.rkt
diff --git a/6-90-0-29/racket/collects/syntax/parse.rkt b/6-90-0-29/racket/collects/syntax/parse.rkt
new file mode 100644
index 0000000..c28072d
--- /dev/null
+++ b/6-90-0-29/racket/collects/syntax/parse.rkt
@@ -0,0 +1,31 @@
+#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
+ [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/parse/debug.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/debug.rkt
similarity index 100%
rename from parse/debug.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/debug.rkt
diff --git a/6-90-0-29/racket/collects/syntax/parse/experimental/contract.rkt b/6-90-0-29/racket/collects/syntax/parse/experimental/contract.rkt
new file mode 100644
index 0000000..5d5144b
--- /dev/null
+++ b/6-90-0-29/racket/collects/syntax/parse/experimental/contract.rkt
@@ -0,0 +1,40 @@
+#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
+ #:positive [pos-blame 'use-site]
+ #:negative [neg-blame 'from-macro]
+ #:macro [macro-name #f]
+ #:name [expr-name not-given]
+ #:context [ctx #f])
+ #:attributes (c)
+ #:commit
+ (pattern y:expr
+ #:with
+ c (wrap-expr/c ctc-stx
+ #'y
+ #: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)))))
+
+(provide-syntax-class/contract
+ [expr/c (syntax-class/c (syntax?)
+ (#: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)))])
diff --git a/6-90-0-29/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted b/6-90-0-29/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/parse/experimental/provide.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/experimental/provide.rkt
similarity index 100%
rename from parse/experimental/provide.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/experimental/provide.rkt
diff --git a/parse/experimental/reflect.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/experimental/reflect.rkt
similarity index 100%
rename from parse/experimental/reflect.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/experimental/reflect.rkt
diff --git a/parse/experimental/specialize.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/experimental/specialize.rkt
similarity index 100%
rename from parse/experimental/specialize.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/experimental/specialize.rkt
diff --git a/parse/experimental/splicing.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/experimental/splicing.rkt
similarity index 100%
rename from parse/experimental/splicing.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/experimental/splicing.rkt
diff --git a/parse/experimental/template.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/experimental/template.rkt
similarity index 100%
rename from parse/experimental/template.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/experimental/template.rkt
diff --git a/parse/pre.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/pre.rkt
similarity index 100%
rename from parse/pre.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/pre.rkt
diff --git a/parse/private/lib.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/lib.rkt
similarity index 100%
rename from parse/private/lib.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/lib.rkt
diff --git a/6-90-0-29/racket/collects/syntax/parse/private/opt.rkt b/6-90-0-29/racket/collects/syntax/parse/private/opt.rkt
new file mode 100644
index 0000000..0c04788
--- /dev/null
+++ b/6-90-0-29/racket/collects/syntax/parse/private/opt.rkt
@@ -0,0 +1,430 @@
+#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]))
+
+;; controls debugging output for optimization successes and failures
+(define DEBUG-OPT-SUCCEED #f)
+(define DEBUG-OPT-FAIL #f)
+
+;; ----
+
+;; 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.
+
+;; ----
+
+(define (optimize-matrix0 rows)
+ (define now (current-inexact-milliseconds))
+ (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
+ (eprintf "\n%% optimizing (~s):\n" (length rows))
+ (pretty-write (matrix->sexpr rows) (current-error-port)))
+ (define result (optimize-matrix rows))
+ (define then (current-inexact-milliseconds))
+ (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
+ (cond [(= (length result) (length rows))
+ (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
+ [else
+ (eprintf "==> (~s ms)\n" (floor (- then now)))
+ (pretty-write (matrix->sexpr result) (current-error-port))
+ (eprintf "\n")]))
+ 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)
+ (when DEBUG-OPT-SUCCEED
+ (eprintf "-- accumulated ~s rows like ~e\n" (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)
+ (when DEBUG-OPT-SUCCEED
+ (eprintf "-- accumulated ~s rows like ~e\n" (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)
+ (when DEBUG-OPT-FAIL
+ (when (pattern-equal? pat1 pat2)
+ (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,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))
+ (when #f ;; DEBUG-OPT-SUCCEED
+ (eprintf ">> unfolding: ~e\n" p))
+ (unfold-and first-sub (*append rest-subs onto))]
+ [else (values p onto)]))]
+ [_ (values p onto)]))
+
+(define (pattern-factorable? p)
+ ;; Can factor out p if p can succeed at most once, does not cut
+ ;; - if p can succeed multiple times, then factoring changes success order
+ ;; - if p can cut, then factoring changes which choice points are discarded (too few)
+ (match p
+ [(pat:any) #t]
+ [(pat:svar _n) #t]
+ [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
+ ;; commit? implies delimit-cut
+ commit?]
+ [(? pat:integrated?) #t]
+ [(pat:literal _lit _ip _lp) #t]
+ [(pat:datum _datum) #t]
+ [(pat:action _act _pat) #f]
+ [(pat:head head tail)
+ (and (pattern-factorable? head)
+ (pattern-factorable? tail))]
+ [(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.
+ (and (= (length heads) 1)
+ (let ([head (car heads)])
+ (and (pattern-factorable? head)))
+ (equal? tail (pat:datum '())))]
+ [(pat:and patterns)
+ (andmap pattern-factorable? patterns)]
+ [(pat:or patterns) #f]
+ [(pat:not pattern) #f] ;; FIXME: ?
+ [(pat:pair head tail)
+ (and (pattern-factorable? head)
+ (pattern-factorable? tail))]
+ [(pat:vector pattern)
+ (pattern-factorable? pattern)]
+ [(pat:box pattern)
+ (pattern-factorable? pattern)]
+ [(pat:pstruct key pattern)
+ (pattern-factorable? pattern)]
+ [(pat:describe pattern _desc _trans _role)
+ (pattern-factorable? pattern)]
+ [(pat:delimit pattern)
+ (pattern-factorable? pattern)]
+ [(pat:commit pattern) #t]
+ [(? pat:reflect?) #f]
+ [(pat:ord pattern _ _)
+ (pattern-factorable? pattern)]
+ [(pat:post pattern)
+ (pattern-factorable? pattern)]
+ ;; ----
+ [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
+ commit?]
+ [(hpat:seq inner)
+ (pattern-factorable? inner)]
+ [(hpat:commit inner) #t]
+ ;; ----
+ [(ehpat head repc)
+ (and (equal? repc #f)
+ (pattern-factorable? head))]
+ ;; ----
+ [else #f]))
+
+(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 (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 DEBUG-OPT-FAIL
+ (when (and (eq? result #f)
+ (equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
+ (eprintf "** pattern-equal? failed on ~e\n" 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?) `(quote ,(syntax->datum (pat:literal-id p)))]
+ [(pat:datum datum) datum]
+ [(? pat:action?) 'ACTION]
+ [(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))]
+ [(ehpat _as hpat '#f _cn)
+ (pattern->sexpr hpat)]
+ [_ 'PATTERN]))
diff --git a/6-90-0-29/racket/collects/syntax/parse/private/parse-aux.rkt.deleted b/6-90-0-29/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/parse/private/parse.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/parse.rkt
similarity index 100%
rename from parse/private/parse.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/parse.rkt
diff --git a/parse/private/rep.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/rep.rkt
similarity index 100%
rename from parse/private/rep.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/rep.rkt
diff --git a/parse/private/residual.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/residual.rkt
similarity index 100%
rename from parse/private/residual.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/residual.rkt
diff --git a/parse/private/runtime-reflect.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/runtime-reflect.rkt
similarity index 100%
rename from parse/private/runtime-reflect.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/runtime-reflect.rkt
diff --git a/parse/private/runtime-report.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/runtime-report.rkt
similarity index 100%
rename from parse/private/runtime-report.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/runtime-report.rkt
diff --git a/parse/private/runtime.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/runtime.rkt
similarity index 100%
rename from parse/private/runtime.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/runtime.rkt
diff --git a/parse/private/sc.rkt-6-90-0-29 b/6-90-0-29/racket/collects/syntax/parse/private/sc.rkt
similarity index 100%
rename from parse/private/sc.rkt-6-90-0-29
rename to 6-90-0-29/racket/collects/syntax/parse/private/sc.rkt
diff --git a/7-0-0-20/racket/collects/racket/private/stxcase-scheme.rkt b/7-0-0-20/racket/collects/racket/private/stxcase-scheme.rkt
new file mode 100644
index 0000000..464a306
--- /dev/null
+++ b/7-0-0-20/racket/collects/racket/private/stxcase-scheme.rkt
@@ -0,0 +1,77 @@
+
+;;----------------------------------------------------------------------
+;; #%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" (all-except racket/private/stxloc syntax/loc)
+ (for-syntax '#%kernel racket/private/small-scheme
+ racket/private/stx "stxcase.rkt"
+ (all-except racket/private/stxloc syntax/loc)))
+
+ (-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 racket/private/stxloc)
+ check-duplicate-identifier syntax-protect
+ syntax-rules syntax-id-rules
+ (for-syntax syntax-pattern-variable?)))
diff --git a/7-0-0-20/racket/collects/racket/private/stxcase.rkt b/7-0-0-20/racket/collects/racket/private/stxcase.rkt
new file mode 100644
index 0000000..cb94b64
--- /dev/null
+++ b/7-0-0-20/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 "template.rkt")
+ (#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
+ (for-syntax syntax-pattern-variable?)))
diff --git a/7-0-0-20/racket/collects/racket/private/stxloc.rkt b/7-0-0-20/racket/collects/racket/private/stxloc.rkt
new file mode 100644
index 0000000..e26417c
--- /dev/null
+++ b/7-0-0-20/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-0-0-20/racket/collects/racket/private/syntax.rkt b/7-0-0-20/racket/collects/racket/private/syntax.rkt
new file mode 100644
index 0000000..7f18fc7
--- /dev/null
+++ b/7-0-0-20/racket/collects/racket/private/syntax.rkt
@@ -0,0 +1,214 @@
+#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)
+ (cond
+ [(identifier? ids) (record-disappeared-uses (list ids))]
+ [(and (list? ids) (andmap identifier? ids))
+ (let ([uses (current-recorded-disappeared-uses)])
+ (when uses
+ (current-recorded-disappeared-uses
+ (append
+ (if (syntax-transforming?)
+ (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 ()
+ [(_ (cl) body ...) #'(with-syntax (cl) body ...)]
+ [(_ (cl cls ...) body ...)
+ #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
diff --git a/7-0-0-20/racket/collects/racket/private/template.rkt b/7-0-0-20/racket/collects/racket/private/template.rkt
new file mode 100644
index 0000000..1c1cb5c
--- /dev/null
+++ b/7-0-0-20/racket/collects/racket/private/template.rkt
@@ -0,0 +1,732 @@
+;; TODO: should either use directly the official "template.rkt",
+;; or import all the structs from there, to avoid having
+;; multiple definitions of the same struct.
+(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
+ racket/struct
+ auto-syntax-e/utils))
+(#%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?)))
+
+;; ============================================================
+;; 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-const Expr) ;; constant
+;; - (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!)
+
+;; A PVar is (pvar Id Id Id/#f Nat/#f)
+;;
+;; The first identifier (var) is from the syntax-mapping or attribute-binding.
+;; The second (lvar) is a local variable name used to hold its value (or parts
+;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a
+;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see
+;; below) if it needs to be checked.
+;;
+;; The depth-delta associated with a depth>0 pattern variable is the difference
+;; between the pattern variable's depth and the depth at which it is used. (For
+;; depth 0 pvars, it's #f.) For example, in
+;;
+;; (with-syntax ([x #'0]
+;; [(y ...) #'(1 2)]
+;; [((z ...) ...) #'((a b) (c d))])
+;; (template (((x y z) ...) ...)))
+;;
+;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta
+;; for z is 0. The depth-delta (or depth "delay") is also the depth of the
+;; ellipsis form where the variable begins to be iterated over. That is, the
+;; template above should be interpreted roughly as
+;;
+;; (let ([Lx (pvar-value-of x)]
+;; [Ly (pvar-value-of y)]
+;; [Lz (pvar-value-of z)])
+;; (for/list ([Lz (in-list Lz)]) ;; depth 0
+;; (for/list ([Ly (in-list Ly)] ;; depth 1
+;; [Lz (in-list Lz)])
+;; (___ Lx Ly Lz ___))))
+
+(begin-for-syntax
+
+ (define here-stx (quote-syntax here))
+
+ (define template-logger (make-logger 'template (current-logger)))
+
+ ;; (struct pvar (var lvar check dd) #:prefab)
+ (define-values (struct:pv pvar pvar? pvar-ref pvar-set!)
+ (make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3)))
+ (define (pvar-var pv) (pvar-ref pv 0))
+ (define (pvar-lvar pv) (pvar-ref pv 1))
+ (define (pvar-check pv) (pvar-ref pv 2))
+ (define (pvar-dd pv) (pvar-ref pv 3))
+
+ ;; 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)) )
+ (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 (ht-guide? x)
+ (if (and (pair? x) (eq? (car x) 'h-t)) #t #f))
+ (define (ht-guide-t x)
+ (if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f))
+
+ (define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list))))
+ (define (const-guide-v x)
+ (if (eq? (car x) 't-list)
+ null
+ (let ([e (cadr x)])
+ (if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e)))))
+
+ (define (cons-guide g1 g2)
+ (cond [(eq? (car g2) 't-list) (list* 't-list g1 (cdr g2))]
+ [(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))]
+ [else (list 't-list* g1 g2)]))
+
+ ;; ----------------------------------------
+ ;; Parsing templates
+
+ ;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id))
+ (define (parse-template ctx t stx?)
+ ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
+ (define env (make-hasheq))
+
+ ;; 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 -> (values (dsetof PVar) 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))
+ (define-values (drivers guide) (parse-t (cadr t) depth #t))
+ ;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _)
+ (values drivers `(t-escaped ,guide)))]
+ [(parse-form t (quote-syntax ~?) 2)
+ => (lambda (t)
+ (disappeared! (car t))
+ (define t1 (cadr t))
+ (define t2 (caddr t))
+ (define-values (drivers1 guide1) (parse-t t1 depth esc?))
+ (define-values (drivers2 guide2) (parse-t t2 depth esc?))
+ (values (dset-union drivers1 drivers2) `(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-values (drivers guide) (parse-t (stx-cdr t) depth esc?))
+ (values drivers
+ `(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 nesting)
+ (let loop ([tail (stx-cdr t)] [nesting 0])
+ (if (and (not esc?) (stx-pair? tail)
+ (let ([x (stx-car tail)])
+ (and (identifier? x) (free-identifier=? x (quote-syntax ...)))))
+ (begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting)))
+ (values tail nesting))))
+ (if (zero? nesting)
+ (parse-t-pair/normal t depth esc?)
+ (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)]
+ [(tdrivers tguide) (parse-t tail depth esc?)])
+ (when (dset-empty? hdrivers)
+ (wrong-syntax head "no pattern variables before ellipsis in template"))
+ (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
+ (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
+ (stx-car (stx-drop nesting t))])
+ ;; FIXME: improve error message?
+ (wrong-syntax bad-dots "too many ellipses in template")))
+ ;; hdrivers is (listof (dsetof pvar))
+ (define hdriverss ;; per level
+ (let loop ([i 0])
+ (if (< i nesting)
+ (cons (dset-filter hdrivers (pvar/dd<=? (+ depth i)))
+ (loop (add1 i)))
+ null)))
+ (define at-stx (datum->syntax #f '... head))
+ (define hg
+ (let loop ([hdriverss hdriverss])
+ (cond [(null? (cdr hdriverss))
+ (let ([cons? (ht-guide? hguide)]
+ [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
+ `(t-dots ,cons? ,hguide ,(car hdriverss)
+ (quote ,head) (quote-syntax ,at-stx)))]
+ [else (let ([inner (loop (cdr hdriverss))])
+ `(t-dots #f ,inner ,(car hdriverss)
+ (quote ,head) (quote-syntax ,at-stx)))])))
+ (values (dset-union hdrivers tdrivers)
+ (if (equal? tguide '(t-list))
+ (resyntax t hg)
+ (resyntax t `(t-append ,hg ,tguide)))))))
+
+ ;; parse-t-pair/normal : Stx Nat Boolean -> ...
+ ;; t is a normal stx pair
+ (define (parse-t-pair/normal t depth esc?)
+ (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?))
+ (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?))
+ (values (dset-union hdrivers tdrivers)
+ (resyntax t
+ (if (ht-guide? hguide)
+ (let ([hguide (ht-guide-t hguide)])
+ (if (and (const-guide? hguide) (const-guide? tguide))
+ (const-guide t)
+ (cons-guide hguide tguide)))
+ (if (equal? tguide '(t-list))
+ hguide
+ `(t-append ,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 (pvar)
+ (disappeared! t)
+ (values (dset pvar)
+ (cond [(pvar-check pvar)
+ => (lambda (check)
+ `(#%expression
+ (,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))]
+ [else `(t-var ,(pvar-lvar pvar))])))]
+ [else (values (dset) (const-guide t))])]
+ [(vector? td)
+ (define-values (drivers guide) (parse-t (vector->list td) depth esc?))
+ (values drivers
+ (cond [(const-guide? guide) (const-guide t)]
+ [else (resyntax t `(t-vector ,guide))]))]
+ [(prefab-struct-key td)
+ => (lambda (key)
+ (define-values (drivers guide)
+ (let ([elems (cdr (vector->list (struct->vector td)))])
+ (parse-t elems depth esc?)))
+ (values drivers
+ (cond [(const-guide? guide) (const-guide t)]
+ [else (resyntax t `(t-struct (quote ,key) ,guide))])))]
+ [(box? td)
+ (define-values (drivers guide) (parse-t (unbox td) depth esc?))
+ (values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))]
+ [else (values (dset) (const-guide t))]))
+
+ ;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide)
+ (define (parse-h h depth esc?)
+ (cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
+ => (lambda (h)
+ (disappeared! (car h))
+ (define-values (drivers guide) (parse-h (cadr h) depth esc?))
+ (values drivers `(h-orelse ,guide null)))]
+ [(and (not esc?) (parse-form h (quote-syntax ~?) 2))
+ => (lambda (h)
+ (disappeared! (car h))
+ (define-values (drivers1 guide1) (parse-h (cadr h) depth esc?))
+ (define-values (drivers2 guide2) (parse-h (caddr h) depth esc?))
+ (values (dset-union drivers1 drivers2)
+ (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-values (drivers guide) (parse-t (stx-cdr h) depth esc?))
+ (values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))]
+ [else
+ (define-values (drivers guide) (parse-t h depth esc?))
+ (values drivers `(h-t ,guide))]))
+
+ ;; lookup : Identifier Nat -> PVar/#f
+ (define (lookup id depth)
+ (define (make-pvar var check pvar-depth)
+ (cond [(zero? pvar-depth)
+ (pvar var var check #f)]
+ [(>= depth pvar-depth)
+ (pvar var (gentemp) check (- depth pvar-depth))]
+ [(zero? depth)
+ (wrong-syntax id "missing ellipsis with pattern variable in template")]
+ [else
+ (wrong-syntax id "too few ellipses for pattern variable in template")]))
+ (define (hash-ref! h k proc)
+ (let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*))))
+ (let ([v (syntax-local-value id (lambda () #f))])
+ (cond [(syntax-pattern-variable? v)
+ (hash-ref! env (cons v depth)
+ (lambda ()
+ (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)))]
+ [(s-exp-pattern-variable? v)
+ (hash-ref! env (cons v depth)
+ (lambda ()
+ (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 t0 g)
+ (if (and stx? (syntax? t0))
+ (cond [(const-guide? g) (const-guide t0)]
+ [else (optimize-resyntax t0 g)])
+ 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 [(const-guide? g0)
+ (let ([const (const-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 [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)]
+ [(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)]
+ [(eq? (car g) 't-append)
+ (loop-g (caddr g) (add1 i) (cons HOLE rt)
+ (list* i 'append rs) (cons (cadr g) re))]
+ [(eq? (car g) 't-const)
+ (let ([const (const-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 [(null? x) `(t-list)]
+ [(not stx?) `(t-const (quote ,x))]
+ [(syntax? x) `(t-const (quote-syntax ,x))]
+ [else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))]))
+
+ (let-values ([(drivers guide) (parse-t t 0 #f)])
+ (values (dset->list drivers) 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 (pvar/dd<=? expected-dd)
+ (lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))))
+
+ (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))))
+
+ ;; ----------------------------------------
+ ;; Deterministic Sets
+ ;; FIXME: detect big unions, use hash table
+
+ (define (dset . xs) xs)
+ (define (dset-empty? ds) (null? ds))
+ (define (dset-filter ds pred) (filter pred ds))
+ (define (dset->list ds) ds)
+ (define (dset-union ds1 ds2)
+ (if (pair? ds1)
+ (let ([elem (car ds1)])
+ (if (member elem ds2)
+ (dset-union (cdr ds1) ds2)
+ (dset-union (cdr ds1) (cons (car ds1) ds2))))
+ ds2))
+
+ (define (filter keep? xs)
+ (if (pair? xs)
+ (if (keep? (car xs))
+ (cons (car xs) (filter keep? (cdr xs)))
+ (filter keep? (cdr xs)))
+ null))
+
+ ;; ----------------------------------------
+ ;; 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 [(eq? gtag 't-resyntax)
+ `(t-resyntax ,loc-id . ,(cddr g))]
+ [(eq? gtag 't-const)
+ `(t-relocate ,g ,loc-id)]
+ [(eq? gtag 't-subst)
+ `(t-subst ,loc-id . ,(cddr g))]
+ ;; ----
+ [(eq? gtag 't-escaped)
+ `(t-escaped ,(loop (cadr g)))]
+ [(eq? gtag '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 (pvars pre-guide disappeared-uses)
+ (parse-template ctx tstx stx?))
+ (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
+ (define ell-pvars (filter pvar-dd pvars))
+ (define pre-code
+ (if (const-guide? guide)
+ (if stx? `(quote-syntax ,tstx) `(quote ,tstx))
+ (let ([lvars (map pvar-lvar ell-pvars)]
+ [valvars (map pvar-var ell-pvars)])
+ `(let (,@(map list lvars valvars))
+ ,(datum->syntax here-stx guide)))))
+ (define code (syntax-arm (datum->syntax here-stx pre-code 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 hdrivers) : 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 drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar)
+ (define in-stx (list-ref s 4))
+ (define at-stx (list-ref s 5))
+ (cond
+ ;; Case 1: (x ...) where x is trusted
+ [(and cons? (let ([head-s (syntax->list head)])
+ (and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var))))
+ head]
+ ;; General case
+ [else
+ ;; var-value-expr : Id Id/#'#f -> Expr[List]
+ (define (var-value-expr lvar check)
+ (if (syntax-e check) `(,check ,lvar 1 #f #f) lvar))
+ (define lvars (map pvar-lvar drivers))
+ (define checks (map pvar-check drivers))
+ (define code
+ `(let ,(map list lvars (map var-value-expr lvars checks))
+ ,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void))
+ ,(if cons?
+ `(map (lambda ,lvars ,head) . ,lvars)
+ `(apply append (map (lambda ,lvars ,head) . ,lvars)))))
+ (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-const #%expression)
+ (rename '#%kernel t-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-0-0-20/racket/collects/racket/private/with-stx.rkt b/7-0-0-20/racket/collects/racket/private/with-stx.rkt
new file mode 100644
index 0000000..e16faa8
--- /dev/null
+++ b/7-0-0-20/racket/collects/racket/private/with-stx.rkt
@@ -0,0 +1,100 @@
+;;----------------------------------------------------------------------
+;; 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"
+ (all-except racket/private/stxloc syntax/loc) racket/private/sc
+ racket/private/gen-temp 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 (begin 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-0-0-20/racket/collects/syntax/parse.rkt b/7-0-0-20/racket/collects/syntax/parse.rkt
new file mode 100644
index 0000000..c28072d
--- /dev/null
+++ b/7-0-0-20/racket/collects/syntax/parse.rkt
@@ -0,0 +1,31 @@
+#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
+ [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/parse/debug.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/debug.rkt
similarity index 100%
rename from parse/debug.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/debug.rkt
diff --git a/7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt
new file mode 100644
index 0000000..5d5144b
--- /dev/null
+++ b/7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt
@@ -0,0 +1,40 @@
+#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
+ #:positive [pos-blame 'use-site]
+ #:negative [neg-blame 'from-macro]
+ #:macro [macro-name #f]
+ #:name [expr-name not-given]
+ #:context [ctx #f])
+ #:attributes (c)
+ #:commit
+ (pattern y:expr
+ #:with
+ c (wrap-expr/c ctc-stx
+ #'y
+ #: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)))))
+
+(provide-syntax-class/contract
+ [expr/c (syntax-class/c (syntax?)
+ (#: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)))])
diff --git a/7-0-0-20/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted b/7-0-0-20/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/7-0-0-20/racket/collects/syntax/parse/experimental/provide.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/provide.rkt
new file mode 100644
index 0000000..173d81e
--- /dev/null
+++ b/7-0-0-20/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/parse/experimental/reflect.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/experimental/reflect.rkt
similarity index 100%
rename from parse/experimental/reflect.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/experimental/reflect.rkt
diff --git a/7-0-0-20/racket/collects/syntax/parse/experimental/specialize.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/specialize.rkt
new file mode 100644
index 0000000..ad569c1
--- /dev/null
+++ b/7-0-0-20/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-0-0-20/racket/collects/syntax/parse/experimental/splicing.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/splicing.rkt
new file mode 100644
index 0000000..56abbd5
--- /dev/null
+++ b/7-0-0-20/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-0-0-20/racket/collects/syntax/parse/experimental/template.rkt b/7-0-0-20/racket/collects/syntax/parse/experimental/template.rkt
new file mode 100644
index 0000000..98c69f5
--- /dev/null
+++ b/7-0-0-20/racket/collects/syntax/parse/experimental/template.rkt
@@ -0,0 +1,55 @@
+#lang racket/base
+(require (for-syntax racket/base
+ racket/struct
+ 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
+ syntax-local-template-metafunction-introduce)
+
+;; ============================================================
+;; Metafunctions
+
+;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use
+;; the exported prop:template-metafunction, template-metafunction? and
+;; template-metafunction-accessor.
+(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/parse/pre.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/pre.rkt
similarity index 100%
rename from parse/pre.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/pre.rkt
diff --git a/parse/private/lib.rkt-7-3-0-1 b/7-0-0-20/racket/collects/syntax/parse/private/lib.rkt
similarity index 100%
rename from parse/private/lib.rkt-7-3-0-1
rename to 7-0-0-20/racket/collects/syntax/parse/private/lib.rkt
diff --git a/parse/private/opt.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/private/opt.rkt
similarity index 100%
rename from parse/private/opt.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/private/opt.rkt
diff --git a/7-0-0-20/racket/collects/syntax/parse/private/parse-aux.rkt.deleted b/7-0-0-20/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/parse/private/parse.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/private/parse.rkt
similarity index 100%
rename from parse/private/parse.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/private/parse.rkt
diff --git a/parse/private/rep.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/private/rep.rkt
similarity index 100%
rename from parse/private/rep.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/private/rep.rkt
diff --git a/parse/private/residual.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/private/residual.rkt
similarity index 100%
rename from parse/private/residual.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/private/residual.rkt
diff --git a/7-0-0-20/racket/collects/syntax/parse/private/runtime-reflect.rkt b/7-0-0-20/racket/collects/syntax/parse/private/runtime-reflect.rkt
new file mode 100644
index 0000000..59125cf
--- /dev/null
+++ b/7-0-0-20/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-0-0-20/racket/collects/syntax/parse/private/runtime-report.rkt b/7-0-0-20/racket/collects/syntax/parse/private/runtime-report.rkt
new file mode 100644
index 0000000..48c128c
--- /dev/null
+++ b/7-0-0-20/racket/collects/syntax/parse/private/runtime-report.rkt
@@ -0,0 +1,815 @@
+#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)
+ (cond [(and truncate-opaque? (not tr?))
+ (loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]
+ [else
+ (loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) 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-0-0-20/racket/collects/syntax/parse/private/runtime.rkt b/7-0-0-20/racket/collects/syntax/parse/private/runtime.rkt
new file mode 100644
index 0000000..90d7ea8
--- /dev/null
+++ b/7-0-0-20/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/parse/private/sc.rkt-7-0-0-20 b/7-0-0-20/racket/collects/syntax/parse/private/sc.rkt
similarity index 100%
rename from parse/private/sc.rkt-7-0-0-20
rename to 7-0-0-20/racket/collects/syntax/parse/private/sc.rkt
diff --git a/7-3-0-1/racket/collects/racket/private/stxcase-scheme.rkt b/7-3-0-1/racket/collects/racket/private/stxcase-scheme.rkt
new file mode 100644
index 0000000..464a306
--- /dev/null
+++ b/7-3-0-1/racket/collects/racket/private/stxcase-scheme.rkt
@@ -0,0 +1,77 @@
+
+;;----------------------------------------------------------------------
+;; #%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" (all-except racket/private/stxloc syntax/loc)
+ (for-syntax '#%kernel racket/private/small-scheme
+ racket/private/stx "stxcase.rkt"
+ (all-except racket/private/stxloc syntax/loc)))
+
+ (-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 racket/private/stxloc)
+ check-duplicate-identifier syntax-protect
+ syntax-rules syntax-id-rules
+ (for-syntax syntax-pattern-variable?)))
diff --git a/7-3-0-1/racket/collects/racket/private/stxcase.rkt b/7-3-0-1/racket/collects/racket/private/stxcase.rkt
new file mode 100644
index 0000000..cb94b64
--- /dev/null
+++ b/7-3-0-1/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 "template.rkt")
+ (#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
+ (for-syntax syntax-pattern-variable?)))
diff --git a/7-3-0-1/racket/collects/racket/private/stxloc.rkt b/7-3-0-1/racket/collects/racket/private/stxloc.rkt
new file mode 100644
index 0000000..e26417c
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/racket/private/syntax.rkt b/7-3-0-1/racket/collects/racket/private/syntax.rkt
new file mode 100644
index 0000000..7f18fc7
--- /dev/null
+++ b/7-3-0-1/racket/collects/racket/private/syntax.rkt
@@ -0,0 +1,214 @@
+#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)
+ (cond
+ [(identifier? ids) (record-disappeared-uses (list ids))]
+ [(and (list? ids) (andmap identifier? ids))
+ (let ([uses (current-recorded-disappeared-uses)])
+ (when uses
+ (current-recorded-disappeared-uses
+ (append
+ (if (syntax-transforming?)
+ (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 ()
+ [(_ (cl) body ...) #'(with-syntax (cl) body ...)]
+ [(_ (cl cls ...) body ...)
+ #'(with-syntax (cl) (with-syntax* (cls ...) body ...))]))
diff --git a/7-3-0-1/racket/collects/racket/private/template.rkt b/7-3-0-1/racket/collects/racket/private/template.rkt
new file mode 100644
index 0000000..1c1cb5c
--- /dev/null
+++ b/7-3-0-1/racket/collects/racket/private/template.rkt
@@ -0,0 +1,732 @@
+;; TODO: should either use directly the official "template.rkt",
+;; or import all the structs from there, to avoid having
+;; multiple definitions of the same struct.
+(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
+ racket/struct
+ auto-syntax-e/utils))
+(#%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?)))
+
+;; ============================================================
+;; 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-const Expr) ;; constant
+;; - (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!)
+
+;; A PVar is (pvar Id Id Id/#f Nat/#f)
+;;
+;; The first identifier (var) is from the syntax-mapping or attribute-binding.
+;; The second (lvar) is a local variable name used to hold its value (or parts
+;; thereof) in ellipsis iteration. The third is #f if var is trusted to have a
+;; (Listof^depth Syntax) value, or an Id reference to a Checker procedure (see
+;; below) if it needs to be checked.
+;;
+;; The depth-delta associated with a depth>0 pattern variable is the difference
+;; between the pattern variable's depth and the depth at which it is used. (For
+;; depth 0 pvars, it's #f.) For example, in
+;;
+;; (with-syntax ([x #'0]
+;; [(y ...) #'(1 2)]
+;; [((z ...) ...) #'((a b) (c d))])
+;; (template (((x y z) ...) ...)))
+;;
+;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta
+;; for z is 0. The depth-delta (or depth "delay") is also the depth of the
+;; ellipsis form where the variable begins to be iterated over. That is, the
+;; template above should be interpreted roughly as
+;;
+;; (let ([Lx (pvar-value-of x)]
+;; [Ly (pvar-value-of y)]
+;; [Lz (pvar-value-of z)])
+;; (for/list ([Lz (in-list Lz)]) ;; depth 0
+;; (for/list ([Ly (in-list Ly)] ;; depth 1
+;; [Lz (in-list Lz)])
+;; (___ Lx Ly Lz ___))))
+
+(begin-for-syntax
+
+ (define here-stx (quote-syntax here))
+
+ (define template-logger (make-logger 'template (current-logger)))
+
+ ;; (struct pvar (var lvar check dd) #:prefab)
+ (define-values (struct:pv pvar pvar? pvar-ref pvar-set!)
+ (make-struct-type 'pvar #f 4 0 #f null 'prefab #f '(0 1 2 3)))
+ (define (pvar-var pv) (pvar-ref pv 0))
+ (define (pvar-lvar pv) (pvar-ref pv 1))
+ (define (pvar-check pv) (pvar-ref pv 2))
+ (define (pvar-dd pv) (pvar-ref pv 3))
+
+ ;; 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)) )
+ (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 (ht-guide? x)
+ (if (and (pair? x) (eq? (car x) 'h-t)) #t #f))
+ (define (ht-guide-t x)
+ (if (and (pair? x) (eq? (car x) 'h-t)) (cadr x) #f))
+
+ (define (const-guide? x) (or (and (pair? x) (eq? (car x) 't-const)) (equal? x '(t-list))))
+ (define (const-guide-v x)
+ (if (eq? (car x) 't-list)
+ null
+ (let ([e (cadr x)])
+ (if (eq? (car e) 'syntax-e) (syntax-e (cadr (cadr e))) (cadr e)))))
+
+ (define (cons-guide g1 g2)
+ (cond [(eq? (car g2) 't-list) (list* 't-list g1 (cdr g2))]
+ [(eq? (car g2) 't-list*) (list* 't-list* g1 (cdr g2))]
+ [else (list 't-list* g1 g2)]))
+
+ ;; ----------------------------------------
+ ;; Parsing templates
+
+ ;; parse-template : Syntax Syntax Boolean -> (values (listof PVar) Guide (Listof Id))
+ (define (parse-template ctx t stx?)
+ ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
+ (define env (make-hasheq))
+
+ ;; 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 -> (values (dsetof PVar) 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))
+ (define-values (drivers guide) (parse-t (cadr t) depth #t))
+ ;; Preserve t-escaped so that (t-escaped (t-const _)) != (t-const _)
+ (values drivers `(t-escaped ,guide)))]
+ [(parse-form t (quote-syntax ~?) 2)
+ => (lambda (t)
+ (disappeared! (car t))
+ (define t1 (cadr t))
+ (define t2 (caddr t))
+ (define-values (drivers1 guide1) (parse-t t1 depth esc?))
+ (define-values (drivers2 guide2) (parse-t t2 depth esc?))
+ (values (dset-union drivers1 drivers2) `(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-values (drivers guide) (parse-t (stx-cdr t) depth esc?))
+ (values drivers
+ `(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 nesting)
+ (let loop ([tail (stx-cdr t)] [nesting 0])
+ (if (and (not esc?) (stx-pair? tail)
+ (let ([x (stx-car tail)])
+ (and (identifier? x) (free-identifier=? x (quote-syntax ...)))))
+ (begin (disappeared! (stx-car tail)) (loop (stx-cdr tail) (add1 nesting)))
+ (values tail nesting))))
+ (if (zero? nesting)
+ (parse-t-pair/normal t depth esc?)
+ (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)]
+ [(tdrivers tguide) (parse-t tail depth esc?)])
+ (when (dset-empty? hdrivers)
+ (wrong-syntax head "no pattern variables before ellipsis in template"))
+ (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
+ (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
+ (stx-car (stx-drop nesting t))])
+ ;; FIXME: improve error message?
+ (wrong-syntax bad-dots "too many ellipses in template")))
+ ;; hdrivers is (listof (dsetof pvar))
+ (define hdriverss ;; per level
+ (let loop ([i 0])
+ (if (< i nesting)
+ (cons (dset-filter hdrivers (pvar/dd<=? (+ depth i)))
+ (loop (add1 i)))
+ null)))
+ (define at-stx (datum->syntax #f '... head))
+ (define hg
+ (let loop ([hdriverss hdriverss])
+ (cond [(null? (cdr hdriverss))
+ (let ([cons? (ht-guide? hguide)]
+ [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
+ `(t-dots ,cons? ,hguide ,(car hdriverss)
+ (quote ,head) (quote-syntax ,at-stx)))]
+ [else (let ([inner (loop (cdr hdriverss))])
+ `(t-dots #f ,inner ,(car hdriverss)
+ (quote ,head) (quote-syntax ,at-stx)))])))
+ (values (dset-union hdrivers tdrivers)
+ (if (equal? tguide '(t-list))
+ (resyntax t hg)
+ (resyntax t `(t-append ,hg ,tguide)))))))
+
+ ;; parse-t-pair/normal : Stx Nat Boolean -> ...
+ ;; t is a normal stx pair
+ (define (parse-t-pair/normal t depth esc?)
+ (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?))
+ (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?))
+ (values (dset-union hdrivers tdrivers)
+ (resyntax t
+ (if (ht-guide? hguide)
+ (let ([hguide (ht-guide-t hguide)])
+ (if (and (const-guide? hguide) (const-guide? tguide))
+ (const-guide t)
+ (cons-guide hguide tguide)))
+ (if (equal? tguide '(t-list))
+ hguide
+ `(t-append ,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 (pvar)
+ (disappeared! t)
+ (values (dset pvar)
+ (cond [(pvar-check pvar)
+ => (lambda (check)
+ `(#%expression
+ (,check ,(pvar-lvar pvar) 0 #t (quote-syntax ,t))))]
+ [else `(t-var ,(pvar-lvar pvar))])))]
+ [else (values (dset) (const-guide t))])]
+ [(vector? td)
+ (define-values (drivers guide) (parse-t (vector->list td) depth esc?))
+ (values drivers
+ (cond [(const-guide? guide) (const-guide t)]
+ [else (resyntax t `(t-vector ,guide))]))]
+ [(prefab-struct-key td)
+ => (lambda (key)
+ (define-values (drivers guide)
+ (let ([elems (cdr (vector->list (struct->vector td)))])
+ (parse-t elems depth esc?)))
+ (values drivers
+ (cond [(const-guide? guide) (const-guide t)]
+ [else (resyntax t `(t-struct (quote ,key) ,guide))])))]
+ [(box? td)
+ (define-values (drivers guide) (parse-t (unbox td) depth esc?))
+ (values drivers (if (const-guide? guide) (const-guide t) (resyntax t `(t-box ,guide))))]
+ [else (values (dset) (const-guide t))]))
+
+ ;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide)
+ (define (parse-h h depth esc?)
+ (cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
+ => (lambda (h)
+ (disappeared! (car h))
+ (define-values (drivers guide) (parse-h (cadr h) depth esc?))
+ (values drivers `(h-orelse ,guide null)))]
+ [(and (not esc?) (parse-form h (quote-syntax ~?) 2))
+ => (lambda (h)
+ (disappeared! (car h))
+ (define-values (drivers1 guide1) (parse-h (cadr h) depth esc?))
+ (define-values (drivers2 guide2) (parse-h (caddr h) depth esc?))
+ (values (dset-union drivers1 drivers2)
+ (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-values (drivers guide) (parse-t (stx-cdr h) depth esc?))
+ (values drivers `(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h))))]
+ [else
+ (define-values (drivers guide) (parse-t h depth esc?))
+ (values drivers `(h-t ,guide))]))
+
+ ;; lookup : Identifier Nat -> PVar/#f
+ (define (lookup id depth)
+ (define (make-pvar var check pvar-depth)
+ (cond [(zero? pvar-depth)
+ (pvar var var check #f)]
+ [(>= depth pvar-depth)
+ (pvar var (gentemp) check (- depth pvar-depth))]
+ [(zero? depth)
+ (wrong-syntax id "missing ellipsis with pattern variable in template")]
+ [else
+ (wrong-syntax id "too few ellipses for pattern variable in template")]))
+ (define (hash-ref! h k proc)
+ (let ([v (hash-ref h k #f)]) (if v v (let ([v* (proc)]) (hash-set! h k v*) v*))))
+ (let ([v (syntax-local-value id (lambda () #f))])
+ (cond [(syntax-pattern-variable? v)
+ (hash-ref! env (cons v depth)
+ (lambda ()
+ (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)))]
+ [(s-exp-pattern-variable? v)
+ (hash-ref! env (cons v depth)
+ (lambda ()
+ (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 t0 g)
+ (if (and stx? (syntax? t0))
+ (cond [(const-guide? g) (const-guide t0)]
+ [else (optimize-resyntax t0 g)])
+ 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 [(const-guide? g0)
+ (let ([const (const-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 [(eq? (car g) 't-list) (loop-gs #f (cdr g) i rt rs re)]
+ [(eq? (car g) 't-list*) (loop-gs #t (cdr g) i rt rs re)]
+ [(eq? (car g) 't-append)
+ (loop-g (caddr g) (add1 i) (cons HOLE rt)
+ (list* i 'append rs) (cons (cadr g) re))]
+ [(eq? (car g) 't-const)
+ (let ([const (const-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 [(null? x) `(t-list)]
+ [(not stx?) `(t-const (quote ,x))]
+ [(syntax? x) `(t-const (quote-syntax ,x))]
+ [else `(t-const (syntax-e (quote-syntax ,(datum->syntax #f x))))]))
+
+ (let-values ([(drivers guide) (parse-t t 0 #f)])
+ (values (dset->list drivers) 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 (pvar/dd<=? expected-dd)
+ (lambda (x) (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))))
+
+ (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))))
+
+ ;; ----------------------------------------
+ ;; Deterministic Sets
+ ;; FIXME: detect big unions, use hash table
+
+ (define (dset . xs) xs)
+ (define (dset-empty? ds) (null? ds))
+ (define (dset-filter ds pred) (filter pred ds))
+ (define (dset->list ds) ds)
+ (define (dset-union ds1 ds2)
+ (if (pair? ds1)
+ (let ([elem (car ds1)])
+ (if (member elem ds2)
+ (dset-union (cdr ds1) ds2)
+ (dset-union (cdr ds1) (cons (car ds1) ds2))))
+ ds2))
+
+ (define (filter keep? xs)
+ (if (pair? xs)
+ (if (keep? (car xs))
+ (cons (car xs) (filter keep? (cdr xs)))
+ (filter keep? (cdr xs)))
+ null))
+
+ ;; ----------------------------------------
+ ;; 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 [(eq? gtag 't-resyntax)
+ `(t-resyntax ,loc-id . ,(cddr g))]
+ [(eq? gtag 't-const)
+ `(t-relocate ,g ,loc-id)]
+ [(eq? gtag 't-subst)
+ `(t-subst ,loc-id . ,(cddr g))]
+ ;; ----
+ [(eq? gtag 't-escaped)
+ `(t-escaped ,(loop (cadr g)))]
+ [(eq? gtag '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 (pvars pre-guide disappeared-uses)
+ (parse-template ctx tstx stx?))
+ (define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
+ (define ell-pvars (filter pvar-dd pvars))
+ (define pre-code
+ (if (const-guide? guide)
+ (if stx? `(quote-syntax ,tstx) `(quote ,tstx))
+ (let ([lvars (map pvar-lvar ell-pvars)]
+ [valvars (map pvar-var ell-pvars)])
+ `(let (,@(map list lvars valvars))
+ ,(datum->syntax here-stx guide)))))
+ (define code (syntax-arm (datum->syntax here-stx pre-code 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 hdrivers) : 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 drivers (map syntax-e (syntax->list (list-ref s 3)))) ;; (Listof PVar)
+ (define in-stx (list-ref s 4))
+ (define at-stx (list-ref s 5))
+ (cond
+ ;; Case 1: (x ...) where x is trusted
+ [(and cons? (let ([head-s (syntax->list head)])
+ (and (pair? head-s) (eq? (syntax-e (car head-s)) 't-var))))
+ head]
+ ;; General case
+ [else
+ ;; var-value-expr : Id Id/#'#f -> Expr[List]
+ (define (var-value-expr lvar check)
+ (if (syntax-e check) `(,check ,lvar 1 #f #f) lvar))
+ (define lvars (map pvar-lvar drivers))
+ (define checks (map pvar-check drivers))
+ (define code
+ `(let ,(map list lvars (map var-value-expr lvars checks))
+ ,(if (> (length lvars) 1) `(check-same-length ,in-stx ,at-stx . ,lvars) '(void))
+ ,(if cons?
+ `(map (lambda ,lvars ,head) . ,lvars)
+ `(apply append (map (lambda ,lvars ,head) . ,lvars)))))
+ (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-const #%expression)
+ (rename '#%kernel t-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-3-0-1/racket/collects/racket/private/with-stx.rkt b/7-3-0-1/racket/collects/racket/private/with-stx.rkt
new file mode 100644
index 0000000..e16faa8
--- /dev/null
+++ b/7-3-0-1/racket/collects/racket/private/with-stx.rkt
@@ -0,0 +1,100 @@
+;;----------------------------------------------------------------------
+;; 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"
+ (all-except racket/private/stxloc syntax/loc) racket/private/sc
+ racket/private/gen-temp 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 (begin 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/parse.rkt-7-3-0-1 b/7-3-0-1/racket/collects/syntax/parse.rkt
similarity index 100%
rename from parse.rkt-7-3-0-1
rename to 7-3-0-1/racket/collects/syntax/parse.rkt
diff --git a/parse/debug.rkt-7-3-0-1 b/7-3-0-1/racket/collects/syntax/parse/debug.rkt
similarity index 100%
rename from parse/debug.rkt-7-3-0-1
rename to 7-3-0-1/racket/collects/syntax/parse/debug.rkt
diff --git a/parse/experimental/contract.rkt-7-3-0-1 b/7-3-0-1/racket/collects/syntax/parse/experimental/contract.rkt
similarity index 100%
rename from parse/experimental/contract.rkt-7-3-0-1
rename to 7-3-0-1/racket/collects/syntax/parse/experimental/contract.rkt
diff --git a/7-3-0-1/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted b/7-3-0-1/racket/collects/syntax/parse/experimental/private/substitute.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/7-3-0-1/racket/collects/syntax/parse/experimental/provide.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/provide.rkt
new file mode 100644
index 0000000..173d81e
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/experimental/reflect.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/reflect.rkt
new file mode 100644
index 0000000..8f18781
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/experimental/specialize.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/specialize.rkt
new file mode 100644
index 0000000..ad569c1
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/experimental/splicing.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/splicing.rkt
new file mode 100644
index 0000000..56abbd5
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/experimental/template.rkt b/7-3-0-1/racket/collects/syntax/parse/experimental/template.rkt
new file mode 100644
index 0000000..98c69f5
--- /dev/null
+++ b/7-3-0-1/racket/collects/syntax/parse/experimental/template.rkt
@@ -0,0 +1,55 @@
+#lang racket/base
+(require (for-syntax racket/base
+ racket/struct
+ 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
+ syntax-local-template-metafunction-introduce)
+
+;; ============================================================
+;; Metafunctions
+
+;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use
+;; the exported prop:template-metafunction, template-metafunction? and
+;; template-metafunction-accessor.
+(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-3-0-1/racket/collects/syntax/parse/pre.rkt b/7-3-0-1/racket/collects/syntax/parse/pre.rkt
new file mode 100644
index 0000000..215ed6e
--- /dev/null
+++ b/7-3-0-1/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?))
\ No newline at end of file
diff --git a/7-3-0-1/racket/collects/syntax/parse/private/lib.rkt b/7-3-0-1/racket/collects/syntax/parse/private/lib.rkt
new file mode 100644
index 0000000..01e110c
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/private/opt.rkt b/7-3-0-1/racket/collects/syntax/parse/private/opt.rkt
new file mode 100644
index 0000000..7319b4e
--- /dev/null
+++ b/7-3-0-1/racket/collects/syntax/parse/private/opt.rkt
@@ -0,0 +1,430 @@
+#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]))
+
+;; controls debugging output for optimization successes and failures
+(define DEBUG-OPT-SUCCEED #f)
+(define DEBUG-OPT-FAIL #f)
+
+;; ----
+
+;; 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.
+
+;; ----
+
+(define (optimize-matrix0 rows)
+ (define now (current-inexact-milliseconds))
+ (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
+ (eprintf "\n%% optimizing (~s):\n" (length rows))
+ (pretty-write (matrix->sexpr rows) (current-error-port)))
+ (define result (optimize-matrix rows))
+ (define then (current-inexact-milliseconds))
+ (when (and DEBUG-OPT-SUCCEED (> (length rows) 1))
+ (cond [(= (length result) (length rows))
+ (eprintf "%% !! FAILED !! (~s ms)\n\n" (floor (- then now)))]
+ [else
+ (eprintf "==> (~s ms)\n" (floor (- then now)))
+ (pretty-write (matrix->sexpr result) (current-error-port))
+ (eprintf "\n")]))
+ 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)
+ (when DEBUG-OPT-SUCCEED
+ (eprintf "-- accumulated ~s rows like ~e\n" (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)
+ (when DEBUG-OPT-SUCCEED
+ (eprintf "-- accumulated ~s rows like ~e\n" (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)
+ (when DEBUG-OPT-FAIL
+ (when (pattern-equal? pat1 pat2)
+ (eprintf "** cannot factor: ~e\n" (syntax->datum #`#,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))
+ (when #f ;; DEBUG-OPT-SUCCEED
+ (eprintf ">> unfolding: ~e\n" p))
+ (unfold-and first-sub (*append rest-subs onto))]
+ [else (values p onto)]))]
+ [_ (values p onto)]))
+
+(define (pattern-factorable? p)
+ ;; Can factor out p if p can succeed at most once, does not cut
+ ;; - if p can succeed multiple times, then factoring changes success order
+ ;; - if p can cut, then factoring changes which choice points are discarded (too few)
+ (match p
+ [(pat:any) #t]
+ [(pat:svar _n) #t]
+ [(pat:var/p _ _ _ _ _ (scopts _ commit? _ _))
+ ;; commit? implies delimit-cut
+ commit?]
+ [(? pat:integrated?) #t]
+ [(pat:literal _lit _ip _lp) #t]
+ [(pat:datum _datum) #t]
+ [(pat:action _act _pat) #f]
+ [(pat:head head tail)
+ (and (pattern-factorable? head)
+ (pattern-factorable? tail))]
+ [(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.
+ (and (= (length heads) 1)
+ (let ([head (car heads)])
+ (and (pattern-factorable? head)))
+ (equal? tail (pat:datum '())))]
+ [(pat:and patterns)
+ (andmap pattern-factorable? patterns)]
+ [(pat:or _ patterns _) #f]
+ [(pat:not pattern) #f] ;; FIXME: ?
+ [(pat:pair head tail)
+ (and (pattern-factorable? head)
+ (pattern-factorable? tail))]
+ [(pat:vector pattern)
+ (pattern-factorable? pattern)]
+ [(pat:box pattern)
+ (pattern-factorable? pattern)]
+ [(pat:pstruct key pattern)
+ (pattern-factorable? pattern)]
+ [(pat:describe pattern _desc _trans _role)
+ (pattern-factorable? pattern)]
+ [(pat:delimit pattern)
+ (pattern-factorable? pattern)]
+ [(pat:commit pattern) #t]
+ [(? pat:reflect?) #f]
+ [(pat:ord pattern _ _)
+ (pattern-factorable? pattern)]
+ [(pat:post pattern)
+ (pattern-factorable? pattern)]
+ ;; ----
+ [(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
+ commit?]
+ [(hpat:seq inner)
+ (pattern-factorable? inner)]
+ [(hpat:commit inner) #t]
+ ;; ----
+ [(ehpat _ head repc _)
+ (and (equal? repc #f)
+ (pattern-factorable? head))]
+ ;; ----
+ [else #f]))
+
+(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 (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 DEBUG-OPT-FAIL
+ (when (and (eq? result #f)
+ (equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
+ (eprintf "** pattern-equal? failed on ~e\n" 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?) `(quote ,(syntax->datum (pat:literal-id p)))]
+ [(pat:datum datum) datum]
+ [(? pat:action?) 'ACTION]
+ [(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))]
+ [(ehpat _as hpat '#f _cn)
+ (pattern->sexpr hpat)]
+ [_ 'PATTERN]))
diff --git a/7-3-0-1/racket/collects/syntax/parse/private/parse-aux.rkt.deleted b/7-3-0-1/racket/collects/syntax/parse/private/parse-aux.rkt.deleted
new file mode 100644
index 0000000..e69de29
diff --git a/parse/private/parse.rkt-7-3-0-1 b/7-3-0-1/racket/collects/syntax/parse/private/parse.rkt
similarity index 100%
rename from parse/private/parse.rkt-7-3-0-1
rename to 7-3-0-1/racket/collects/syntax/parse/private/parse.rkt
diff --git a/parse/private/rep.rkt-7-3-0-1 b/7-3-0-1/racket/collects/syntax/parse/private/rep.rkt
similarity index 100%
rename from parse/private/rep.rkt-7-3-0-1
rename to 7-3-0-1/racket/collects/syntax/parse/private/rep.rkt
diff --git a/7-3-0-1/racket/collects/syntax/parse/private/residual.rkt b/7-3-0-1/racket/collects/syntax/parse/private/residual.rkt
new file mode 100644
index 0000000..313265b
--- /dev/null
+++ b/7-3-0-1/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 racket/private/template)
+(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-3-0-1/racket/collects/syntax/parse/private/runtime-reflect.rkt b/7-3-0-1/racket/collects/syntax/parse/private/runtime-reflect.rkt
new file mode 100644
index 0000000..59125cf
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/private/runtime-report.rkt b/7-3-0-1/racket/collects/syntax/parse/private/runtime-report.rkt
new file mode 100644
index 0000000..48c128c
--- /dev/null
+++ b/7-3-0-1/racket/collects/syntax/parse/private/runtime-report.rkt
@@ -0,0 +1,815 @@
+#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)
+ (cond [(and truncate-opaque? (not tr?))
+ (loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]
+ [else
+ (loop rest-es (cons (expect:thing #f desc tr? role (ps->stx+index ps)) 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-3-0-1/racket/collects/syntax/parse/private/runtime.rkt b/7-3-0-1/racket/collects/syntax/parse/private/runtime.rkt
new file mode 100644
index 0000000..90d7ea8
--- /dev/null
+++ b/7-3-0-1/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-3-0-1/racket/collects/syntax/parse/private/sc.rkt b/7-3-0-1/racket/collects/syntax/parse/private/sc.rkt
new file mode 100644
index 0000000..d4e5ff6
--- /dev/null
+++ b/7-3-0-1/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/case/stxcase-scheme.rkt b/case/stxcase-scheme.rkt
index 0cb4e7c..e49f2d0 100644
--- a/case/stxcase-scheme.rkt
+++ b/case/stxcase-scheme.rkt
@@ -5,8 +5,9 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "stxcase-scheme.rkt-6-11")]
+ (my-include "../6-11/racket/collects/racket/private/stxcase-scheme.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "stxcase-scheme.rkt-6-11")]
+ ;; TODO: this seems like a bug, it should be 6-12
+ (my-include "../6-11/racket/collects/racket/private/stxcase-scheme.rkt")]
[else
- (my-include "stxcase-scheme.rkt-6-90-0-29")])
+ (my-include "../6-90-0-29/racket/collects/racket/private/stxcase-scheme.rkt")])
diff --git a/case/stxcase.rkt b/case/stxcase.rkt
index ad4e2ad..fded7e8 100644
--- a/case/stxcase.rkt
+++ b/case/stxcase.rkt
@@ -5,8 +5,9 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "stxcase.rkt-6-11")]
+ (my-include "../6-11/racket/collects/racket/private/stxcase.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "stxcase.rkt-6-11")]
+ ;; TODO: this seems like a bug, it should be 6-12
+ (my-include "../6-11/racket/collects/racket/private/stxcase.rkt")]
[else
- (my-include "stxcase.rkt-6-90-0-29")])
+ (my-include "../6-90-0-29/racket/collects/racket/private/stxcase.rkt")])
diff --git a/case/stxloc.rkt b/case/stxloc.rkt
index 669983b..4a4904a 100644
--- a/case/stxloc.rkt
+++ b/case/stxloc.rkt
@@ -5,8 +5,9 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "stxloc.rkt-6-11")]
+ (my-include "../6-11/racket/collects/racket/private/stxloc.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "stxloc.rkt-6-11")]
+ ;; TODO: this seems like a bug, it should be 6-12
+ (my-include "../6-11/racket/collects/racket/private/stxloc.rkt")]
[else
- (my-include "stxloc.rkt-6-90-0-29")])
+ (my-include "../6-90-0-29/racket/collects/racket/private/stxloc.rkt")])
diff --git a/case/syntax.rkt b/case/syntax.rkt
index a64de8d..41fbc83 100644
--- a/case/syntax.rkt
+++ b/case/syntax.rkt
@@ -5,8 +5,9 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "syntax.rkt-6-11")]
+ (my-include "../6-11/racket/collects/racket/private/syntax.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "syntax.rkt-6-11")]
+ ;; TODO: this seems like a bug, it should be 6-12
+ (my-include "../6-11/racket/collects/racket/private/syntax.rkt")]
[else
- (my-include "syntax.rkt-6-90-0-29")])
+ (my-include "../6-90-0-29/racket/collects/racket/private/syntax.rkt")])
diff --git a/case/template.rkt b/case/template.rkt
index d288fe8..b46e478 100644
--- a/case/template.rkt
+++ b/case/template.rkt
@@ -9,4 +9,4 @@
[(version< (version) "6.90.0.29")
(begin)]
[else
- (my-include "template.rkt-6-90-0-29")])
+ (my-include "../6-90-0-29/racket/collects/racket/private/template.rkt")])
diff --git a/case/with-stx.rkt b/case/with-stx.rkt
index 4582d9a..2228da1 100644
--- a/case/with-stx.rkt
+++ b/case/with-stx.rkt
@@ -5,8 +5,9 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "with-stx.rkt-6-11")]
+ (my-include "../6-11/racket/collects/racket/private/with-stx.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "with-stx.rkt-6-11")]
+ ;; TODO: this seems like a bug, should be 6-12
+ (my-include "../6-11/racket/collects/racket/private/with-stx.rkt")]
[else
- (my-include "with-stx.rkt-6-90-0-29")])
+ (my-include "../6-90-0-29/racket/collects/racket/private/with-stx.rkt")])
diff --git a/generate-dispatch-6-11--6-12.sh b/generate-dispatch-6-11--6-12.sh
deleted file mode 100755
index f93cae8..0000000
--- a/generate-dispatch-6-11--6-12.sh
+++ /dev/null
@@ -1,33 +0,0 @@
-#!/bin/bash
-for i in `find -name '*-6-11' -or -name '*-6-12' -or -name '*-6-90.0.29'`; do
- echo "${i%-6-*}"
-done | sort -u | while read pathmain; do
- echo "$pathmain"
- main="$(basename "$pathmain")"
-
- if test -e "${pathmain}-6-11"; then eleven="(my-include \"${main}-6-11\")";
- else eleven="(begin)"; fi
-
- if test -e "${pathmain}-6-12"; then twelve="(my-include \"${main}-6-12\")";
- elif test -e "${pathmain}-6-12.deleted"; then twelve="(begin)";
- else twelve="$eleven"; fi
-
- if test -e "${pathmain}-6-90-0-29"; then twentynine="(my-include \"${main}-6-90-0-29\")";
- elif test -e "${pathmain}-6-90-0-29.deleted"; then twelve="(begin)";
- else twentynine="$twelve"; fi
-
- cat > "$pathmain" <<EOF
-#lang racket/base
-(#%require version-case
- (for-syntax (only racket/base version)
- (only racket/base #%app #%datum))
- stxparse-info/my-include)
-(version-case
- [(version< (version) "6.11.0.900")
- $eleven]
- [(version< (version) "6.90.0.29")
- $twelve]
- [else
- $twentynine])
-EOF
-done
diff --git a/info.rkt b/info.rkt
index c4d948a..476b1b8 100644
--- a/info.rkt
+++ b/info.rkt
@@ -13,4 +13,4 @@
(define scribblings '(("scribblings/stxparse-info.scrbl" () ("Syntax Extensions"))))
(define pkg-desc "Description Here")
(define version "0.0")
-(define pkg-authors '(georges))
+(define pkg-authors '(Suzanne Soy))
diff --git a/parse.rkt b/parse.rkt
index 99868d2..c4f7309 100644
--- a/parse.rkt
+++ b/parse.rkt
@@ -5,6 +5,6 @@
stxparse-info/my-include)
(version-case
[(version< (version) "7.3.0.1")
- (my-include "parse.rkt-7-0-0-20")]
+ (my-include "7-0-0-20/racket/collects/syntax/parse.rkt")]
[else
- (my-include "parse.rkt-7-3-0-1")])
+ (my-include "7-3-0-1/racket/collects/syntax/parse.rkt")])
diff --git a/parse/debug.rkt b/parse/debug.rkt
index 8b086e5..4364872 100644
--- a/parse/debug.rkt
+++ b/parse/debug.rkt
@@ -5,12 +5,12 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "debug.rkt-6-11")]
+ (my-include "../6-11/stxparse-info/parse/debug.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "debug.rkt-6-12")]
+ (my-include "../6-12/stxparse-info/parse/debug.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "debug.rkt-6-90-0-29")]
+ (my-include "../6-90-0-29/stxparse-info/parse/debug.rkt")]
[(version< (version) "7.3.0.1")
- (my-include "debug.rkt-7-0-0-20")]
+ (my-include "../7-0-0-20/stxparse-info/parse/debug.rkt")]
[else
- (my-include "debug.rkt-7-3-0-1")])
+ (my-include "../7-3-0-1/stxparse-info/parse/debug.rkt")])
diff --git a/parse/experimental/contract.rkt b/parse/experimental/contract.rkt
index ecc2ac1..7763155 100644
--- a/parse/experimental/contract.rkt
+++ b/parse/experimental/contract.rkt
@@ -5,6 +5,6 @@
stxparse-info/my-include)
(version-case
[(version< (version) "7.3.0.1")
- (my-include "contract.rkt-7-0-0-20")]
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/experimental/contract.rkt")]
[else
- (my-include "contract.rkt-7-3-0-1")])
+ (my-include "../../7-3-0-1/racket/collects/syntax/parse/experimental/contract.rkt")])
diff --git a/parse/experimental/private/substitute.rkt b/parse/experimental/private/substitute.rkt
index 7bb496f..b6c647f 100644
--- a/parse/experimental/private/substitute.rkt
+++ b/parse/experimental/private/substitute.rkt
@@ -5,8 +5,6 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "substitute.rkt-6-11")]
- [(version< (version) "6.90.0.29")
- (begin)]
+ (my-include "../../../6-11/racket/collects/syntax/parse/experimental/private/substitute.rkt")]
[else
(begin)])
diff --git a/parse/experimental/provide.rkt b/parse/experimental/provide.rkt
index 4ac50f2..15e28eb 100644
--- a/parse/experimental/provide.rkt
+++ b/parse/experimental/provide.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "provide.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/experimental/provide.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "provide.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/experimental/provide.rkt")]
[else
- (my-include "provide.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/provide.rkt")])
diff --git a/parse/experimental/reflect.rkt b/parse/experimental/reflect.rkt
index 92c790c..e9c1f54 100644
--- a/parse/experimental/reflect.rkt
+++ b/parse/experimental/reflect.rkt
@@ -5,10 +5,10 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "reflect.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/experimental/reflect.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "reflect.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/experimental/reflect.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "reflect.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/reflect.rkt")]
[else
- (my-include "reflect.rkt-7-0-0-20")])
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/experimental/reflect.rkt")])
diff --git a/parse/experimental/specialize.rkt b/parse/experimental/specialize.rkt
index e5ed82b..8ad42bd 100644
--- a/parse/experimental/specialize.rkt
+++ b/parse/experimental/specialize.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "specialize.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/experimental/specialize.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "specialize.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/experimental/specialize.rkt")]
[else
- (my-include "specialize.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/specialize.rkt")])
diff --git a/parse/experimental/splicing.rkt b/parse/experimental/splicing.rkt
index d3b1b13..83fe4d1 100644
--- a/parse/experimental/splicing.rkt
+++ b/parse/experimental/splicing.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "splicing.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/experimental/splicing.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "splicing.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/experimental/splicing.rkt")]
[else
- (my-include "splicing.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/splicing.rkt")])
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
index c94f20b..409ec1d 100644
--- a/parse/experimental/template.rkt
+++ b/parse/experimental/template.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "template.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/experimental/template.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "template.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/experimental/template.rkt")]
[else
- (my-include "template.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/experimental/template.rkt")])
diff --git a/parse/pre.rkt b/parse/pre.rkt
index 9310cff..927877e 100644
--- a/parse/pre.rkt
+++ b/parse/pre.rkt
@@ -5,10 +5,10 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "pre.rkt-6-11")]
+ (my-include "../6-11/stxparse-info/parse/pre.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "pre.rkt-6-12")]
+ (my-include "../6-12/stxparse-info/parse/pre.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "pre.rkt-6-90-0-29")]
+ (my-include "../6-90-0-29/stxparse-info/parse/pre.rkt")]
[else
- (my-include "pre.rkt-7-0-0-20")])
+ (my-include "../7-0-0-20/stxparse-info/parse/pre.rkt")])
diff --git a/parse/private/lib.rkt b/parse/private/lib.rkt
index c433c10..4583d73 100644
--- a/parse/private/lib.rkt
+++ b/parse/private/lib.rkt
@@ -5,10 +5,10 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "lib.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/lib.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "lib.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/lib.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "lib.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/lib.rkt")]
[else
- (my-include "lib.rkt-7-3-0-1")])
+ (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/lib.rkt")])
diff --git a/parse/private/opt.rkt b/parse/private/opt.rkt
index 2cba2c8..38c7881 100644
--- a/parse/private/opt.rkt
+++ b/parse/private/opt.rkt
@@ -5,6 +5,6 @@
stxparse-info/my-include)
(version-case
[(version< (version) "7.0.0.20")
- (my-include "opt.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/opt.rkt")]
[else
- (my-include "opt.rkt-7-0-0-20")])
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/opt.rkt")])
diff --git a/parse/private/parse-aux.rkt b/parse/private/parse-aux.rkt
index 52b9a08..779ce47 100644
--- a/parse/private/parse-aux.rkt
+++ b/parse/private/parse-aux.rkt
@@ -5,8 +5,6 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "parse-aux.rkt-6-11")]
- [(version< (version) "6.90.0.29")
- (begin)]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/parse-aux.rkt")]
[else
(begin)])
diff --git a/parse/private/parse.rkt b/parse/private/parse.rkt
index b6cf825..9f03c27 100644
--- a/parse/private/parse.rkt
+++ b/parse/private/parse.rkt
@@ -5,12 +5,12 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "parse.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/parse.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "parse.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/parse.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "parse.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/parse.rkt")]
[(version< (version) "7.3.0.1")
- (my-include "parse.rkt-7-0-0-20")]
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/parse.rkt")]
[else
- (my-include "parse.rkt-7-3-0-1")])
+ (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/parse.rkt")])
diff --git a/parse/private/rep.rkt b/parse/private/rep.rkt
index 8de1934..8136a73 100644
--- a/parse/private/rep.rkt
+++ b/parse/private/rep.rkt
@@ -5,12 +5,12 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "rep.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/rep.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "rep.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/rep.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "rep.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/rep.rkt")]
[(version< (version) "7.3.0.1")
- (my-include "rep.rkt-7-0-0-20")]
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/rep.rkt")]
[else
- (my-include "rep.rkt-7-3-0-1")])
+ (my-include "../../7-3-0-1/racket/collects/syntax/parse/private/rep.rkt")])
diff --git a/parse/private/residual.rkt b/parse/private/residual.rkt
index 8f1bdd1..5702578 100644
--- a/parse/private/residual.rkt
+++ b/parse/private/residual.rkt
@@ -5,10 +5,10 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "residual.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/residual.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "residual.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/residual.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "residual.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/residual.rkt")]
[else
- (my-include "residual.rkt-7-0-0-20")])
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/residual.rkt")])
diff --git a/parse/private/runtime-reflect.rkt b/parse/private/runtime-reflect.rkt
index 991df27..9ae2f8e 100644
--- a/parse/private/runtime-reflect.rkt
+++ b/parse/private/runtime-reflect.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "runtime-reflect.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/runtime-reflect.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "runtime-reflect.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/runtime-reflect.rkt")]
[else
- (my-include "runtime-reflect.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime-reflect.rkt")])
diff --git a/parse/private/runtime-report.rkt b/parse/private/runtime-report.rkt
index e389954..8d91a2c 100644
--- a/parse/private/runtime-report.rkt
+++ b/parse/private/runtime-report.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "runtime-report.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/runtime-report.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "runtime-report.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/runtime-report.rkt")]
[else
- (my-include "runtime-report.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime-report.rkt")])
diff --git a/parse/private/runtime.rkt b/parse/private/runtime.rkt
index 2b8371f..43788c6 100644
--- a/parse/private/runtime.rkt
+++ b/parse/private/runtime.rkt
@@ -5,8 +5,8 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "runtime.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/runtime.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "runtime.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/runtime.rkt")]
[else
- (my-include "runtime.rkt-6-90-0-29")])
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/runtime.rkt")])
diff --git a/parse/private/sc.rkt b/parse/private/sc.rkt
index 122ed04..0787d7c 100644
--- a/parse/private/sc.rkt
+++ b/parse/private/sc.rkt
@@ -5,10 +5,10 @@
stxparse-info/my-include)
(version-case
[(version< (version) "6.11.0.900")
- (my-include "sc.rkt-6-11")]
+ (my-include "../../6-11/racket/collects/syntax/parse/private/sc.rkt")]
[(version< (version) "6.90.0.29")
- (my-include "sc.rkt-6-12")]
+ (my-include "../../6-12/racket/collects/syntax/parse/private/sc.rkt")]
[(version< (version) "7.0.0.20")
- (my-include "sc.rkt-6-90-0-29")]
+ (my-include "../../6-90-0-29/racket/collects/syntax/parse/private/sc.rkt")]
[else
- (my-include "sc.rkt-7-0-0-20")])
+ (my-include "../../7-0-0-20/racket/collects/syntax/parse/private/sc.rkt")])