suzanne.soy/stxparse-info
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Upgrade for Racket 7.4

Browse Source
This commit is contained in:
Suzanne Soy 2021-03-03 03:21:48 +00:00
parent 69dd024348
commit d64d2c1901
39 changed files with 9721 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

650
7-4/0001-require-paths.patch Normal file
View File

@ -0,0 +1,650 @@
From f40af8e9288f83b19c8b358981e2a8c7c42874ef Mon Sep 17 00:00:00 2001
From: Suzanne Soy <ligo@suzanne.soy>
Date: Tue, 2 Mar 2021 21:19:51 +0000
Subject: [PATCH 1/2] require paths
---
.../racket/private/stxcase-scheme.rkt | 7 +--
racket/collects/racket/private/stxcase.rkt | 12 ++---
racket/collects/racket/private/stxloc.rkt | 4 +-
racket/collects/racket/private/template.rkt | 49 +++++++++++--------
racket/collects/racket/private/with-stx.rkt | 6 +--
racket/collects/racket/syntax.rkt | 3 +-
racket/collects/syntax/parse.rkt | 3 +-
racket/collects/syntax/parse/debug.rkt | 8 +--
racket/collects/syntax/parse/define.rkt | 4 +-
.../syntax/parse/experimental/contract.rkt | 4 +-
.../collects/syntax/parse/experimental/eh.rkt | 2 +-
.../parse/experimental/private/substitute.rkt | 1 +
.../syntax/parse/experimental/provide.rkt | 6 +--
.../syntax/parse/experimental/reflect.rkt | 6 +--
.../syntax/parse/experimental/specialize.rkt | 4 +-
.../syntax/parse/experimental/splicing.rkt | 6 +--
racket/collects/syntax/parse/private/lib.rkt | 2 +-
.../collects/syntax/parse/private/litconv.rkt | 10 ++--
racket/collects/syntax/parse/private/opt.rkt | 6 +--
.../collects/syntax/parse/private/parse.rkt | 18 +++----
racket/collects/syntax/parse/private/rep.rkt | 14 +++---
.../syntax/parse/private/residual.rkt | 6 +--
.../syntax/parse/private/runtime-progress.rkt | 2 +-
.../syntax/parse/private/runtime-reflect.rkt | 30 +++++++++---
.../syntax/parse/private/runtime-report.rkt | 6 +--
.../collects/syntax/parse/private/runtime.rkt | 4 +-
racket/collects/syntax/parse/private/sc.rkt | 4 +-
27 files changed, 128 insertions(+), 99 deletions(-)
create mode 100644 racket/collects/syntax/parse/experimental/private/substitute.rkt
diff --git racket/collects/racket/private/stxcase-scheme.rkt racket/collects/racket/private/stxcase-scheme.rkt
index 9f1a21abbb..46bddba4e5 100644
--- racket/collects/racket/private/stxcase-scheme.rkt
+++ racket/collects/racket/private/stxcase-scheme.rkt
@@ -4,8 +4,8 @@
;; check-duplicate-identifier, and assembles everything we have so far
(module stxcase-scheme '#%kernel
- (#%require "small-scheme.rkt" "stx.rkt" "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
- (for-syntax '#%kernel "small-scheme.rkt" "stx.rkt" "stxcase.rkt"
+ (#%require racket/private/small-scheme racket/private/stx "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
+ (for-syntax '#%kernel racket/private/small-scheme racket/private/stx "stxcase.rkt"
"stxloc.rkt"))
(-define (check-duplicate-identifier names)
@@ -68,7 +68,8 @@
(syntax-arm stx #f #t)
(raise-argument-error 'syntax-protect "syntax?" stx)))
- (#%provide syntax datum (all-from "with-stx.rkt") (all-from "stxloc.rkt")
+ (#%provide syntax datum (all-from "with-stx.rkt")
+ (all-from "stxloc.rkt")
check-duplicate-identifier syntax-protect
syntax-rules syntax-id-rules
(for-syntax syntax-pattern-variable?)))
diff --git racket/collects/racket/private/stxcase.rkt racket/collects/racket/private/stxcase.rkt
index 69832a27a1..ca8f8f631b 100644
--- racket/collects/racket/private/stxcase.rkt
+++ racket/collects/racket/private/stxcase.rkt
@@ -2,10 +2,10 @@
;; syntax-case and syntax
(module stxcase '#%kernel
- (#%require "stx.rkt" "small-scheme.rkt" '#%paramz '#%unsafe
- "ellipses.rkt"
- (for-syntax "stx.rkt" "small-scheme.rkt"
- "gen-temp.rkt" "member.rkt" "sc.rkt" '#%kernel))
+ (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
+ racket/private/ellipses
+ (for-syntax racket/private/stx racket/private/small-scheme
+ racket/private/gen-temp racket/private/member racket/private/sc '#%kernel))
(-define interp-match
(lambda (pat e literals immediate=?)
@@ -379,6 +379,6 @@
m))))])))
x)))))))
- (#%require "template.rkt")
- (#%provide (all-from "ellipses.rkt") syntax-case** syntax syntax/loc datum
+ (#%require racket/private/template)
+ (#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
(for-syntax syntax-pattern-variable?)))
diff --git racket/collects/racket/private/stxloc.rkt racket/collects/racket/private/stxloc.rkt
index c9e0d54324..e26417c7bc 100644
--- racket/collects/racket/private/stxloc.rkt
+++ racket/collects/racket/private/stxloc.rkt
@@ -3,8 +3,8 @@
;; syntax/loc
(module stxloc '#%kernel
- (#%require "qq-and-or.rkt" "stxcase.rkt" "define-et-al.rkt"
- (for-syntax '#%kernel "stxcase.rkt" "sc.rkt"))
+ (#%require racket/private/qq-and-or "stxcase.rkt" racket/private/define-et-al
+ (for-syntax '#%kernel "stxcase.rkt" racket/private/sc))
(begin-for-syntax
(define-values (transform-to-syntax-case**)
diff --git racket/collects/racket/private/template.rkt racket/collects/racket/private/template.rkt
index 9037109f38..06dfba3033 100644
--- racket/collects/racket/private/template.rkt
+++ racket/collects/racket/private/template.rkt
@@ -1,25 +1,25 @@
(module template '#%kernel
-(#%require "stx.rkt" "small-scheme.rkt" "performance-hint.rkt"
- (rename "small-scheme.rkt" define -define)
- (rename "small-scheme.rkt" define-syntax -define-syntax)
- "ellipses.rkt"
- (for-syntax "stx.rkt" "small-scheme.rkt"
- (rename "small-scheme.rkt" define -define)
- (rename "small-scheme.rkt" define-syntax -define-syntax)
- "member.rkt" "sc.rkt" '#%kernel))
+(#%require racket/private/stx racket/private/small-scheme racket/private/performance-hint
+ (rename racket/private/small-scheme define -define)
+ (rename racket/private/small-scheme define-syntax -define-syntax)
+ racket/private/ellipses
+ (for-syntax racket/private/stx racket/private/small-scheme
+ (rename racket/private/small-scheme define -define)
+ (rename racket/private/small-scheme define-syntax -define-syntax)
+ racket/private/member racket/private/sc '#%kernel))
(#%provide syntax
syntax/loc
datum
~? ~@
~@! signal-absent-pvar
- (protect
- (for-syntax attribute-mapping
- attribute-mapping?
- attribute-mapping-name
- attribute-mapping-var
- attribute-mapping-depth
- attribute-mapping-check
- metafunction metafunction?)))
+ (for-syntax attribute-mapping
+ attribute-mapping?
+ attribute-mapping-name
+ attribute-mapping-var
+ attribute-mapping-depth
+ attribute-mapping-check
+ (protect metafunction
+ metafunction?)))
;; ============================================================
;; Syntax of templates
@@ -87,7 +87,14 @@
;; (struct attribute-mapping (var name depth check) ...)
;; check : #f (trusted) or Id, ref to Checker
;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) )
- (define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
+ (#%require (for-template (only racket/private/template
+ attribute-mapping
+ attribute-mapping?
+ attribute-mapping-var
+ attribute-mapping-name
+ attribute-mapping-depth
+ attribute-mapping-check)))
+ #;(define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
attribute-mapping-ref _attribute-mapping-set!)
(make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector)
(lambda (self stx)
@@ -106,10 +113,10 @@
(quote-syntax ,source-name)))
(datum->syntax here-stx code stx))
(attribute-mapping-var self)))))
- (define (attribute-mapping-var a) (attribute-mapping-ref a 0))
- (define (attribute-mapping-name a) (attribute-mapping-ref a 1))
- (define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
- (define (attribute-mapping-check a) (attribute-mapping-ref a 3))
+ #;(define (attribute-mapping-var a) (attribute-mapping-ref a 0))
+ #;(define (attribute-mapping-name a) (attribute-mapping-ref a 1))
+ #;(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
+ #;(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
;; (struct metafunction (var))
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
diff --git racket/collects/racket/private/with-stx.rkt racket/collects/racket/private/with-stx.rkt
index b10fc4ec7c..1e22edcd99 100644
--- racket/collects/racket/private/with-stx.rkt
+++ racket/collects/racket/private/with-stx.rkt
@@ -2,9 +2,9 @@
;; with-syntax, generate-temporaries
(module with-stx '#%kernel
- (#%require "stx.rkt" "small-scheme.rkt" "stxcase.rkt"
- (for-syntax '#%kernel "stx.rkt" "stxcase.rkt" "stxloc.rkt"
- "gen-temp.rkt" "sc.rkt" "qq-and-or.rkt" "cond.rkt"))
+ (#%require racket/private/stx racket/private/small-scheme "stxcase.rkt"
+ (for-syntax '#%kernel racket/private/stx "stxcase.rkt" "stxloc.rkt"
+ racket/private/gen-temp racket/private/sc racket/private/qq-and-or racket/private/cond))
(-define (with-syntax-fail stx)
(raise-syntax-error
diff --git racket/collects/racket/syntax.rkt racket/collects/racket/syntax.rkt
index ce0a72d1fc..428c195971 100644
--- racket/collects/racket/syntax.rkt
+++ racket/collects/racket/syntax.rkt
@@ -1,5 +1,6 @@
#lang racket/base
-(require (for-syntax racket/base
+(require (only-in "stxloc.rkt" syntax-case)
+ (for-syntax racket/base
racket/private/sc))
(provide define/with-syntax
diff --git racket/collects/syntax/parse.rkt racket/collects/syntax/parse.rkt
index 6e81621a07..643de4ddda 100644
--- racket/collects/syntax/parse.rkt
+++ racket/collects/syntax/parse.rkt
@@ -24,7 +24,8 @@
[syntax-local-syntax-parse-pattern-introduce
(-> syntax? syntax?)]))
- (define pattern-expander
+ (require (only-in (for-template syntax/parse) pattern-expander))
+ #;(define pattern-expander
(let ()
(struct pattern-expander (proc) #:transparent
#:omit-define-syntaxes
diff --git racket/collects/syntax/parse/debug.rkt racket/collects/syntax/parse/debug.rkt
index a092ab6263..c62849b212 100644
--- racket/collects/syntax/parse/debug.rkt
+++ racket/collects/syntax/parse/debug.rkt
@@ -2,20 +2,20 @@
(require (for-syntax racket/base
syntax/stx
racket/syntax
- "private/rep-data.rkt"
+ syntax/parse/private/rep-data
"private/rep.rkt"
- "private/kws.rkt")
+ syntax/parse/private/kws)
racket/list
racket/pretty
"../parse.rkt"
- (except-in syntax/parse/private/residual
+ (except-in stxparse-info/parse/private/residual
prop:syntax-class
prop:pattern-expander
syntax-local-syntax-parse-pattern-introduce)
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"
- "private/kws.rkt")
+ syntax/parse/private/kws)
;; No lazy loading for this module's dependencies.
diff --git racket/collects/syntax/parse/define.rkt racket/collects/syntax/parse/define.rkt
index 80af669b22..6392c75adb 100644
--- racket/collects/syntax/parse/define.rkt
+++ racket/collects/syntax/parse/define.rkt
@@ -1,10 +1,10 @@
#lang racket/base
(require (for-syntax racket/base
- syntax/parse
+ stxparse-info/parse
"private/sc.rkt"))
(provide define-simple-macro
define-syntax-parser
- (for-syntax (all-from-out syntax/parse)))
+ (for-syntax (all-from-out stxparse-info/parse)))
(define-syntax (define-simple-macro stx)
(syntax-parse stx
diff --git racket/collects/syntax/parse/experimental/contract.rkt racket/collects/syntax/parse/experimental/contract.rkt
index 022e590958..b0f932b3ff 100644
--- racket/collects/syntax/parse/experimental/contract.rkt
+++ racket/collects/syntax/parse/experimental/contract.rkt
@@ -1,8 +1,8 @@
#lang racket/base
-(require syntax/parse/pre
+(require stxparse-info/parse/pre
"provide.rkt"
syntax/contract
- (only-in syntax/parse/private/residual ;; keep abs. path
+ (only-in stxparse-info/parse/private/residual ;; keep abs. path
this-context-syntax
this-role)
racket/contract/base)
diff --git racket/collects/syntax/parse/experimental/eh.rkt racket/collects/syntax/parse/experimental/eh.rkt
index 305080721f..f8e1b09302 100644
--- racket/collects/syntax/parse/experimental/eh.rkt
+++ racket/collects/syntax/parse/experimental/eh.rkt
@@ -1,5 +1,5 @@
#lang racket/base
(require "../private/sc.rkt"
- "../private/keywords.rkt")
+ syntax/parse/private/keywords)
(provide ~eh-var
define-eh-alternative-set)
diff --git racket/collects/syntax/parse/experimental/private/substitute.rkt racket/collects/syntax/parse/experimental/private/substitute.rkt
new file mode 100644
index 0000000000..7bc35af1c4
--- /dev/null
+++ racket/collects/syntax/parse/experimental/private/substitute.rkt
@@ -0,0 +1 @@
+#lang racket/base
diff --git racket/collects/syntax/parse/experimental/provide.rkt racket/collects/syntax/parse/experimental/provide.rkt
index 86a3b6fd88..173d81e428 100644
--- racket/collects/syntax/parse/experimental/provide.rkt
+++ racket/collects/syntax/parse/experimental/provide.rkt
@@ -4,10 +4,10 @@
syntax/location
(for-syntax racket/base
racket/syntax
- "../private/minimatch.rkt"
- syntax/parse/pre
+ syntax/parse/private/minimatch
+ stxparse-info/parse/pre
syntax/parse/private/residual-ct ;; keep abs. path
- "../private/kws.rkt"
+ syntax/parse/private/kws
syntax/contract))
(provide provide-syntax-class/contract
syntax-class/c
diff --git racket/collects/syntax/parse/experimental/reflect.rkt racket/collects/syntax/parse/experimental/reflect.rkt
index 7e4daa3e5a..8f18781e9a 100644
--- racket/collects/syntax/parse/experimental/reflect.rkt
+++ racket/collects/syntax/parse/experimental/reflect.rkt
@@ -5,10 +5,10 @@
syntax/parse/private/residual-ct) ;; keep abs.path
racket/contract/base
racket/contract/combinator
- "../private/minimatch.rkt"
- "../private/keywords.rkt"
+ syntax/parse/private/minimatch
+ syntax/parse/private/keywords
"../private/runtime-reflect.rkt"
- "../private/kws.rkt")
+ syntax/parse/private/kws)
(begin-for-syntax
(lazy-require
[syntax/parse/private/rep-data ;; keep abs. path
diff --git racket/collects/syntax/parse/experimental/specialize.rkt racket/collects/syntax/parse/experimental/specialize.rkt
index e32b077825..ad569c1cb0 100644
--- racket/collects/syntax/parse/experimental/specialize.rkt
+++ racket/collects/syntax/parse/experimental/specialize.rkt
@@ -1,8 +1,8 @@
#lang racket/base
(require (for-syntax racket/base
racket/syntax
- "../private/kws.rkt"
- "../private/rep-data.rkt"
+ syntax/parse/private/kws
+ syntax/parse/private/rep-data
"../private/rep.rkt")
"../private/runtime.rkt")
(provide define-syntax-class/specialize)
diff --git racket/collects/syntax/parse/experimental/splicing.rkt racket/collects/syntax/parse/experimental/splicing.rkt
index 510b2a7361..56abbd5cd2 100644
--- racket/collects/syntax/parse/experimental/splicing.rkt
+++ racket/collects/syntax/parse/experimental/splicing.rkt
@@ -1,9 +1,9 @@
#lang racket/base
(require (for-syntax racket/base
- syntax/parse
+ stxparse-info/parse
racket/lazy-require
- "../private/kws.rkt")
- syntax/parse/private/residual) ;; keep abs. path
+ syntax/parse/private/kws)
+ stxparse-info/parse/private/residual) ;; keep abs. path
(provide define-primitive-splicing-syntax-class)
(begin-for-syntax
diff --git racket/collects/syntax/parse/private/lib.rkt racket/collects/syntax/parse/private/lib.rkt
index 5eaa74c946..01e110c45b 100644
--- racket/collects/syntax/parse/private/lib.rkt
+++ racket/collects/syntax/parse/private/lib.rkt
@@ -1,6 +1,6 @@
#lang racket/base
(require "sc.rkt"
- "keywords.rkt"
+ syntax/parse/private/keywords
(only-in "residual.rkt" state-cons!)
(for-syntax syntax/parse/private/residual-ct)
(for-syntax racket/base))
diff --git racket/collects/syntax/parse/private/litconv.rkt racket/collects/syntax/parse/private/litconv.rkt
index 772930c301..9e25611d96 100644
--- racket/collects/syntax/parse/private/litconv.rkt
+++ racket/collects/syntax/parse/private/litconv.rkt
@@ -3,14 +3,14 @@
racket/lazy-require
"sc.rkt"
"lib.rkt"
- "kws.rkt"
+ syntax/parse/private/kws
racket/syntax)
syntax/parse/private/residual-ct ;; keep abs. path
- syntax/parse/private/residual) ;; keep abs. path
+ stxparse-info/parse/private/residual) ;; keep abs. path
(begin-for-syntax
(lazy-require
[syntax/private/keyword (options-select-value parse-keyword-options)]
- [syntax/parse/private/rep ;; keep abs. path
+ [stxparse-info/parse/private/rep ;; keep abs. path
(parse-kw-formals
check-conventions-rules
check-datum-literals-list
@@ -18,7 +18,7 @@
;; FIXME: workaround for phase>0 bug in racket/runtime-path (and thus lazy-require)
;; Without this, dependencies don't get collected.
(require racket/runtime-path racket/syntax (for-meta 2 '#%kernel))
-(define-runtime-module-path-index _unused_ 'syntax/parse/private/rep)
+(define-runtime-module-path-index _unused_ 'stxparse-info/parse/private/rep)
(provide define-conventions
define-literal-set
@@ -215,7 +215,7 @@ change between when define-literal-set is compiled and the comparison
involving L. For example:
(module M racket
- (require syntax/parse)
+ (require stxparse-info/parse)
(define-literal-set LS (lambda))
(require (only-in some-other-lang lambda))
.... LS ....)
diff --git racket/collects/syntax/parse/private/opt.rkt racket/collects/syntax/parse/private/opt.rkt
index 0e7af8e5a8..12714d6be1 100644
--- racket/collects/syntax/parse/private/opt.rkt
+++ racket/collects/syntax/parse/private/opt.rkt
@@ -2,9 +2,9 @@
(require racket/syntax
racket/pretty
syntax/parse/private/residual-ct ;; keep abs. path
- "minimatch.rkt"
- "rep-patterns.rkt"
- "kws.rkt")
+ syntax/parse/private/minimatch
+ syntax/parse/private/rep-patterns
+ syntax/parse/private/kws)
(provide (struct-out pk1)
(rename-out [optimize-matrix0 optimize-matrix]))
diff --git racket/collects/syntax/parse/private/parse.rkt racket/collects/syntax/parse/private/parse.rkt
index 609d0a48b4..e14cc3aea9 100644
--- racket/collects/syntax/parse/private/parse.rkt
+++ racket/collects/syntax/parse/private/parse.rkt
@@ -4,22 +4,22 @@
syntax/private/id-table
syntax/keyword
racket/syntax
- "minimatch.rkt"
- "datum-to-expr.rkt"
- "rep-attrs.rkt"
- "rep-data.rkt"
- "rep-patterns.rkt"
+ syntax/parse/private/minimatch
+ syntax/parse/private/datum-to-expr
+ syntax/parse/private/rep-attrs
+ syntax/parse/private/rep-data
+ syntax/parse/private/rep-patterns
"rep.rkt"
- "kws.rkt"
+ syntax/parse/private/kws
"opt.rkt"
"txlift.rkt")
- "keywords.rkt"
+ syntax/parse/private/keywords
racket/syntax
racket/stxparam
syntax/stx
- syntax/parse/private/residual ;; keep abs. path
+ stxparse-info/parse/private/residual ;; keep abs. path
"runtime.rkt"
- syntax/parse/private/runtime-reflect) ;; keep abs. path
+ stxparse-info/parse/private/runtime-reflect) ;; keep abs. path
;; ============================================================
diff --git racket/collects/syntax/parse/private/rep.rkt racket/collects/syntax/parse/private/rep.rkt
index 1264a0398f..be08bc36c1 100644
--- racket/collects/syntax/parse/private/rep.rkt
+++ racket/collects/syntax/parse/private/rep.rkt
@@ -1,12 +1,12 @@
#lang racket/base
(require (for-template racket/base
syntax/parse/private/keywords
- syntax/parse/private/residual ;; keep abs. path
- syntax/parse/private/runtime)
+ stxparse-info/parse/private/residual ;; keep abs. path
+ stxparse-info/parse/private/runtime)
racket/list
racket/contract/base
"make.rkt"
- "minimatch.rkt"
+ syntax/parse/private/minimatch
syntax/apply-transformer
syntax/private/id-table
syntax/stx
@@ -14,11 +14,11 @@
racket/syntax
racket/struct
"txlift.rkt"
- "rep-attrs.rkt"
- "rep-data.rkt"
- "rep-patterns.rkt"
+ syntax/parse/private/rep-attrs
+ syntax/parse/private/rep-data
+ syntax/parse/private/rep-patterns
syntax/parse/private/residual-ct ;; keep abs. path
- "kws.rkt")
+ syntax/parse/private/kws)
;; Error reporting
;; All entry points should have explicit, mandatory #:context arg
diff --git racket/collects/syntax/parse/private/residual.rkt racket/collects/syntax/parse/private/residual.rkt
index 3f9416c950..528885697b 100644
--- racket/collects/syntax/parse/private/residual.rkt
+++ racket/collects/syntax/parse/private/residual.rkt
@@ -7,10 +7,10 @@
;; ============================================================
;; Compile-time
-(require (for-syntax racket/private/sc "residual-ct.rkt"))
-(provide (for-syntax (all-from-out "residual-ct.rkt")))
+(require (for-syntax racket/private/sc syntax/parse/private/residual-ct))
+(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
-(require racket/private/template)
+(require "../../case/template.rkt")
(provide (for-syntax attribute-mapping attribute-mapping?))
;; ============================================================
diff --git racket/collects/syntax/parse/private/runtime-progress.rkt racket/collects/syntax/parse/private/runtime-progress.rkt
index 4065357c76..ad894d2c70 100644
--- racket/collects/syntax/parse/private/runtime-progress.rkt
+++ racket/collects/syntax/parse/private/runtime-progress.rkt
@@ -1,6 +1,6 @@
#lang racket/base
(require racket/list
- "minimatch.rkt")
+ syntax/parse/private/minimatch)
(provide ps-empty
ps-add-car
ps-add-cdr
diff --git racket/collects/syntax/parse/private/runtime-reflect.rkt racket/collects/syntax/parse/private/runtime-reflect.rkt
index e3bc47a4c5..59125cf0ac 100644
--- racket/collects/syntax/parse/private/runtime-reflect.rkt
+++ racket/collects/syntax/parse/private/runtime-reflect.rkt
@@ -1,7 +1,7 @@
#lang racket/base
(require "residual.rkt"
- (only-in "residual-ct.rkt" attr-name attr-depth)
- "kws.rkt")
+ (only-in syntax/parse/private/residual-ct attr-name attr-depth)
+ syntax/parse/private/kws)
(provide reflect-parser
(struct-out reified)
(struct-out reified-syntax-class)
@@ -11,10 +11,28 @@
A Reified is
(reified symbol ParserFunction nat (listof (list symbol nat)))
|#
-(define-struct reified-base (name) #:transparent)
-(define-struct (reified reified-base) (parser arity signature))
-(define-struct (reified-syntax-class reified) ())
-(define-struct (reified-splicing-syntax-class reified) ())
+(require (only-in syntax/parse/private/runtime-reflect
+ reified
+ reified?
+ reified-parser
+ reified-arity
+ reified-signature
+ make-reified
+ struct:reified
+
+ reified-syntax-class
+ reified-syntax-class?
+ make-reified-syntax-class
+ struct:reified-syntax-class
+
+ reified-splicing-syntax-class
+ reified-splicing-syntax-class?
+ make-reified-splicing-syntax-class
+ struct:reified-splicing-syntax-class))
+#;(define-struct reified-base (name) #:transparent)
+#;(define-struct (reified reified-base) (parser arity signature))
+#;(define-struct (reified-syntax-class reified) ())
+#;(define-struct (reified-splicing-syntax-class reified) ())
(define (reflect-parser obj e-arity e-attrs splicing?)
;; e-arity represents single call; min and max are same
diff --git racket/collects/syntax/parse/private/runtime-report.rkt racket/collects/syntax/parse/private/runtime-report.rkt
index 59733c4cd2..a1d09e11ad 100644
--- racket/collects/syntax/parse/private/runtime-report.rkt
+++ racket/collects/syntax/parse/private/runtime-report.rkt
@@ -4,9 +4,9 @@
syntax/stx
racket/struct
syntax/srcloc
- "minimatch.rkt"
- syntax/parse/private/residual
- "kws.rkt")
+ syntax/parse/private/minimatch
+ stxparse-info/parse/private/residual
+ syntax/parse/private/kws)
(provide call-current-failure-handler
current-failure-handler
invert-failure
diff --git racket/collects/syntax/parse/private/runtime.rkt racket/collects/syntax/parse/private/runtime.rkt
index d100d2c564..41b321499e 100644
--- racket/collects/syntax/parse/private/runtime.rkt
+++ racket/collects/syntax/parse/private/runtime.rkt
@@ -1,13 +1,13 @@
#lang racket/base
(require racket/stxparam
- syntax/parse/private/residual ;; keep abs. path
+ stxparse-info/parse/private/residual ;; keep abs. path
(for-syntax racket/base
racket/list
syntax/kerncase
syntax/strip-context
racket/private/sc
racket/syntax
- "rep-data.rkt"))
+ syntax/parse/private/rep-data))
(provide with
fail-handler
diff --git racket/collects/syntax/parse/private/sc.rkt racket/collects/syntax/parse/private/sc.rkt
index 27b069059d..d4e5ff695a 100644
--- racket/collects/syntax/parse/private/sc.rkt
+++ racket/collects/syntax/parse/private/sc.rkt
@@ -1,6 +1,6 @@
#lang racket/base
(require racket/lazy-require
- "keywords.rkt"
+ syntax/parse/private/keywords
"residual.rkt")
(lazy-require-syntax
@@ -21,7 +21,7 @@
syntax-parser
define/syntax-parse
- (except-out (all-from-out "keywords.rkt")
+ (except-out (all-from-out syntax/parse/private/keywords)
~reflect
~splicing-reflect
~eh-var)
--
2.30.0

197
7-4/0002-auto-syntax-e-and-template-metafunction-stuff.patch Normal file
View File

@ -0,0 +1,197 @@
From 544b1d8c15e32f5ce722d69d3f9ec51b73430b5a Mon Sep 17 00:00:00 2001
From: Suzanne Soy <ligo@suzanne.soy>
Date: Tue, 2 Mar 2021 21:20:46 +0000
Subject: [PATCH 2/2] auto-syntax-e and template-metafunction stuff
---
racket/collects/racket/private/stxcase.rkt | 14 ++++++++++----
racket/collects/racket/syntax.rkt | 9 ++++++---
.../syntax/parse/experimental/template.rkt | 17 +++++++++++++++--
racket/collects/syntax/parse/private/parse.rkt | 7 ++++++-
.../collects/syntax/parse/private/residual.rkt | 4 +++-
.../collects/syntax/parse/private/runtime.rkt | 12 ++++++++----
6 files changed, 48 insertions(+), 15 deletions(-)
diff --git racket/collects/racket/private/stxcase.rkt racket/collects/racket/private/stxcase.rkt
index ca8f8f631b..cded343601 100644
--- racket/collects/racket/private/stxcase.rkt
+++ racket/collects/racket/private/stxcase.rkt
@@ -4,8 +4,10 @@
(module stxcase '#%kernel
(#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
racket/private/ellipses
+ stxparse-info/current-pvars
(for-syntax racket/private/stx racket/private/small-scheme
- racket/private/gen-temp racket/private/member racket/private/sc '#%kernel))
+ racket/private/gen-temp racket/private/member racket/private/sc '#%kernel
+ auto-syntax-e/utils))
(-define interp-match
(lambda (pat e literals immediate=?)
@@ -346,7 +348,7 @@
(list
(if s-exp?
(quote-syntax make-s-exp-mapping)
- (quote-syntax make-syntax-mapping))
+ (quote-syntax make-auto-pvar))
;; Tell it the shape of the variable:
(let loop ([var unflat-pattern-var][d 0])
(if (syntax? var)
@@ -361,9 +363,13 @@
null
(if fender
(list (quote-syntax if) fender
- answer
+ (list (quote-syntax with-pvars)
+ pattern-vars
+ answer)
do-try-next)
- answer)))
+ (list (quote-syntax with-pvars)
+ pattern-vars
+ answer))))
do-try-next))])
(if fender
(list
diff --git racket/collects/racket/syntax.rkt racket/collects/racket/syntax.rkt
index 428c195971..85c41d155f 100644
--- racket/collects/racket/syntax.rkt
+++ racket/collects/racket/syntax.rkt
@@ -1,7 +1,9 @@
#lang racket/base
(require (only-in "stxloc.rkt" syntax-case)
+ stxparse-info/current-pvars
(for-syntax racket/base
- racket/private/sc))
+ racket/private/sc
+ auto-syntax-e/utils))
(provide define/with-syntax
current-recorded-disappeared-uses
@@ -44,8 +46,9 @@
(with-syntax ([pattern rhs])
(values (pvar-value pvar) ...)))
(define-syntax pvar
- (make-syntax-mapping 'depth (quote-syntax valvar)))
- ...)))]))
+ (make-auto-pvar 'depth (quote-syntax valvar)))
+ ...
+ (define-pvars pvar ...))))]))
;; Ryan: alternative name: define/syntax-pattern ??
;; auxiliary macro
diff --git racket/collects/syntax/parse/experimental/template.rkt racket/collects/syntax/parse/experimental/template.rkt
index b52fd80e6e..160eccc84b 100644
--- racket/collects/syntax/parse/experimental/template.rkt
+++ racket/collects/syntax/parse/experimental/template.rkt
@@ -1,5 +1,6 @@
#lang racket/base
-(require (for-syntax racket/base)
+(require (for-syntax racket/base
+ auto-syntax-e/utils)
(only-in racket/private/template
metafunction))
(provide (rename-out [syntax template]
@@ -26,10 +27,22 @@
(define current-template-metafunction-introducer
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
+(define old-template-metafunction-introducer
+ (make-parameter #f))
+
+(define (syntax-local-template-metafunction-introduce stx)
+ (let ([mark (current-template-metafunction-introducer)]
+ [old-mark (old-template-metafunction-introducer)])
+ (unless old-mark
+ (error 'syntax-local-template-metafunction-introduce
+ "must be called within the dynamic extent of a template metafunction"))
+ (mark (old-mark stx))))
+
(define ((make-hygienic-metafunction transformer) stx)
(define mark (make-syntax-introducer))
(define old-mark (current-template-metafunction-introducer))
- (parameterize ((current-template-metafunction-introducer mark))
+ (parameterize ((current-template-metafunction-introducer mark)
+ (old-template-metafunction-introducer old-mark))
(define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
(unless (syntax? r)
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
diff --git racket/collects/syntax/parse/private/parse.rkt racket/collects/syntax/parse/private/parse.rkt
index e14cc3aea9..7e5c61dee1 100644
--- racket/collects/syntax/parse/private/parse.rkt
+++ racket/collects/syntax/parse/private/parse.rkt
@@ -435,7 +435,12 @@ Conventions:
((body-sequence)
(syntax-case rest ()
[(e0 e ...)
- #'(let () e0 e ...)]
+ ;; Should we use a shadower (works on the whole file, unhygienically),
+ ;; or use the context of the syntax-parse identifier?
+ (let ([the-#%intdef-begin (datum->syntax #'ctx '#%intdef-begin)])
+ (if (syntax-local-value the-#%intdef-begin (λ () #f)) ;; Defined as a macro
+ #`(let () (#,the-#%intdef-begin e0 e ...))
+ #'(let () e0 e ...)))]
[_ (raise-syntax-error #f "expected non-empty clause body"
#'ctx clause)]))
(else
diff --git racket/collects/syntax/parse/private/residual.rkt racket/collects/syntax/parse/private/residual.rkt
index 528885697b..1624b6394a 100644
--- racket/collects/syntax/parse/private/residual.rkt
+++ racket/collects/syntax/parse/private/residual.rkt
@@ -18,7 +18,9 @@
(require "runtime-progress.rkt"
"3d-stx.rkt"
- syntax/stx)
+ auto-syntax-e
+ syntax/stx
+ stxparse-info/current-pvars)
(provide (all-from-out "runtime-progress.rkt")
diff --git racket/collects/syntax/parse/private/runtime.rkt racket/collects/syntax/parse/private/runtime.rkt
index 41b321499e..90d7ea88f4 100644
--- racket/collects/syntax/parse/private/runtime.rkt
+++ racket/collects/syntax/parse/private/runtime.rkt
@@ -1,11 +1,13 @@
#lang racket/base
(require racket/stxparam
stxparse-info/parse/private/residual ;; keep abs. path
+ stxparse-info/current-pvars
(for-syntax racket/base
racket/list
syntax/kerncase
syntax/strip-context
racket/private/sc
+ auto-syntax-e/utils
racket/syntax
syntax/parse/private/rep-data))
@@ -111,9 +113,10 @@ residual.rkt.
...)
([(vtmp) value] ...)
(letrec-syntaxes+values
- ([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
+ ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...)
()
- . body))))]))
+ (with-pvars (name ...)
+ . body)))))]))
;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
;; Special case: empty attrs need not match number of value exprs.
@@ -147,8 +150,9 @@ residual.rkt.
(attribute-mapping (quote-syntax vtmp) 'name 'depth
(if 'syntax? #f (quote-syntax check-attr-value))))
...
- (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
- ...)))]))
+ (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp)))
+ ...
+ (define-pvars name ...))))]))
(define-syntax-rule (phase-of-enclosing-module)
(variable-reference->module-base-phase
--
2.30.0

1
7-4/base_commit.txt Normal file
View File

@ -0,0 +1 @@
cc06a5e2523ae3049b69d15cd2548eed5a887100

75
7-4/racket/collects/racket/private/stxcase-scheme.rkt Normal file
View File

@ -0,0 +1,75 @@
;;----------------------------------------------------------------------
;; #%stxcase-scheme: adds let-syntax, syntax-rules, and
;; check-duplicate-identifier, and assembles everything we have so far
(module stxcase-scheme '#%kernel
(#%require racket/private/small-scheme racket/private/stx "stxcase.rkt" "with-stx.rkt" "stxloc.rkt"
(for-syntax '#%kernel racket/private/small-scheme racket/private/stx "stxcase.rkt"
"stxloc.rkt"))
(-define (check-duplicate-identifier names)
(unless (and (list? names) (andmap identifier? names))
(raise-argument-error 'check-duplicate-identifier "(listof identifier?)" names))
(let/ec escape
(let ([ht (make-hasheq)])
(for-each
(lambda (defined-name)
(unless (identifier? defined-name)
(raise-argument-error 'check-duplicate-identifier
"(listof identifier?)" names))
(let ([l (hash-ref ht (syntax-e defined-name) null)])
(when (ormap (lambda (i) (bound-identifier=? i defined-name)) l)
(escape defined-name))
(hash-set! ht (syntax-e defined-name) (cons defined-name l))))
names)
#f)))
(begin-for-syntax
(define-values (check-sr-rules)
(lambda (stx kws)
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"pattern must start with an identifier, found something else"
stx
id)))
(syntax->list kws)))))
;; From Dybvig, mostly:
(-define-syntax syntax-rules
(lambda (stx)
(syntax-case** syntax-rules #t stx () free-identifier=? #f
((sr (k ...) ((keyword . pattern) template) ...)
(andmap identifier? (syntax->list (syntax (k ...))))
(begin
(check-sr-rules stx (syntax (keyword ...)))
(syntax/loc stx
(lambda (x)
(syntax-case** sr #t x (k ...) free-identifier=? #f
((_ . pattern) (syntax-protect (syntax/loc x template)))
...))))))))
(-define-syntax syntax-id-rules
(lambda (x)
(syntax-case** syntax-id-rules #t x () free-identifier=? #f
((sidr (k ...) (pattern template) ...)
(andmap identifier? (syntax->list (syntax (k ...))))
(syntax/loc x
(make-set!-transformer
(lambda (x)
(syntax-case** sidr #t x (k ...) free-identifier=? #f
(pattern (syntax-protect (syntax/loc x template)))
...))))))))
(-define (syntax-protect stx)
(if (syntax? stx)
(syntax-arm stx #f #t)
(raise-argument-error 'syntax-protect "syntax?" stx)))
(#%provide syntax datum (all-from "with-stx.rkt")
(all-from "stxloc.rkt")
check-duplicate-identifier syntax-protect
syntax-rules syntax-id-rules
(for-syntax syntax-pattern-variable?)))

390
7-4/racket/collects/racket/private/stxcase.rkt Normal file
View File

@ -0,0 +1,390 @@
;;----------------------------------------------------------------------
;; syntax-case and syntax
(module stxcase '#%kernel
(#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe
racket/private/ellipses
stxparse-info/current-pvars
(for-syntax racket/private/stx racket/private/small-scheme
racket/private/gen-temp racket/private/member racket/private/sc '#%kernel
auto-syntax-e/utils))
(-define interp-match
(lambda (pat e literals immediate=?)
(interp-gen-match pat e literals immediate=? #f)))
(-define interp-s-match
(lambda (pat e literals immediate=?)
(interp-gen-match pat e literals immediate=? #t)))
(-define interp-gen-match
(lambda (pat e literals immediate=? s-exp?)
(let loop ([pat pat][e e][cap e])
(cond
[(null? pat)
(if s-exp?
(null? e)
(stx-null? e))]
[(number? pat)
(and (if s-exp? (symbol? e) (identifier? e))
(immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))]
[(not pat)
#t]
[else
(let ([i (vector-ref pat 0)])
(cond
[(eq? i 'bind)
(let ([e (if s-exp?
e
(if (vector-ref pat 2)
(datum->syntax cap e cap)
e))])
(if (vector-ref pat 1)
e
(list e)))]
[(eq? i 'pair)
(let ([match-head (vector-ref pat 1)]
[match-tail (vector-ref pat 2)]
[mh-did-var? (vector-ref pat 3)]
[mt-did-var? (vector-ref pat 4)])
(let ([cap (if (syntax? e) e cap)])
(and (stx-pair? e)
(let ([h (loop match-head (stx-car e) cap)])
(and h
(let ([t (loop match-tail (stx-cdr e) cap)])
(and t
(if mh-did-var?
(if mt-did-var?
(append h t)
h)
t))))))))]
[(eq? i 'quote)
(if s-exp?
(and (equal? (vector-ref pat 1) e)
null)
(and (syntax? e)
(equal? (vector-ref pat 1) (syntax-e e))
null))]
[(eq? i 'ellipses)
(let ([match-head (vector-ref pat 1)]
[nest-cnt (vector-ref pat 2)]
[last? (vector-ref pat 3)])
(and (if s-exp?
(list? e)
(stx-list? e))
(if (zero? nest-cnt)
(andmap (lambda (e) (loop match-head e cap))
(if s-exp? e (stx->list e)))
(let/ec esc
(let ([l (map (lambda (e)
(let ([m (loop match-head e cap)])
(if m
m
(esc #f))))
(if s-exp? e (stx->list e)))])
(if (null? l)
(let loop ([cnt nest-cnt])
(cond
[(= 1 cnt) (if last? '() '(()))]
[else (cons '() (loop (sub1 cnt)))]))
((if last? stx-rotate* stx-rotate) l)))))))]
[(eq? i 'mid-ellipses)
(let ([match-head (vector-ref pat 1)]
[match-tail (vector-ref pat 2)]
[tail-cnt (vector-ref pat 3)]
[prop? (vector-ref pat 4)]
[mh-did-var? (vector-ref pat 5)]
[mt-did-var? (vector-ref pat 6)])
(let-values ([(pre-items post-items ok?)
(split-stx-list e tail-cnt prop?)]
[(cap) (if (syntax? e) e cap)])
(and ok?
(let ([h (loop match-head pre-items cap)])
(and h
(let ([t (loop match-tail post-items cap)])
(and t
(if mt-did-var?
(if mh-did-var?
(append h t)
t)
h))))))))]
[(eq? i 'veclist)
(and (if s-exp?
(vector? e)
(stx-vector? e #f))
(loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))]
[(eq? i 'vector)
(and (if s-exp?
(and (vector? e) (= (vector-length e) (vector-ref pat 1)))
(stx-vector? e (vector-ref pat 1)))
(let vloop ([p (vector-ref pat 2)][pos 0])
(cond
[(null? p) null]
[else
(let ([clause (car p)])
(let ([match-elem (car clause)]
[elem-did-var? (cdr clause)])
(let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)])
(and m
(let ([body (vloop (cdr p) (add1 pos))])
(and body
(if elem-did-var?
(if (null? body)
m
(append m body))
body)))))))])))]
[(eq? i 'box)
(let ([match-content (vector-ref pat 1)])
(and (if s-exp?
(box? e)
(stx-box? e))
(loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))]
[(eq? i 'prefab)
(and (if s-exp?
(equal? (vector-ref pat 1) (prefab-struct-key e))
(stx-prefab? (vector-ref pat 1) e))
(loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))]
[else (error "yikes!" pat)]))]))))
(-define-syntax syntax-case**
(lambda (x)
(-define l (and (stx-list? x) (cdr (stx->list x))))
(unless (and (stx-list? x)
(> (length l) 3))
(raise-syntax-error
#f
"bad form"
x))
(let ([who (car l)]
[arg-is-stx? (cadr l)]
[expr (caddr l)]
[kws (cadddr l)]
[lit-comp (cadddr (cdr l))]
[s-exp? (syntax-e (cadddr (cddr l)))]
[clauses (cddddr (cddr l))])
(unless (stx-list? kws)
(raise-syntax-error
(syntax-e who)
"expected a parenthesized sequence of literal identifiers"
kws))
(for-each
(lambda (lit)
(unless (identifier? lit)
(raise-syntax-error
(syntax-e who)
"literal is not an identifier"
lit)))
(stx->list kws))
(for-each
(lambda (clause)
(unless (and (stx-list? clause)
(<= 2 (length (stx->list clause)) 3))
(raise-syntax-error
(syntax-e who)
"expected a clause containing a pattern, an optional guard expression, and an expression"
clause)))
clauses)
(let ([patterns (map stx-car clauses)]
[fenders (map (lambda (clause)
(and (stx-pair? (stx-cdr (stx-cdr clause)))
(stx-car (stx-cdr clause))))
clauses)]
[answers (map (lambda (clause)
(let ([r (stx-cdr (stx-cdr clause))])
(if (stx-pair? r)
(stx-car r)
(stx-car (stx-cdr clause)))))
clauses)])
(let* ([arg (quote-syntax arg)]
[rslt (quote-syntax rslt)]
[pattern-varss (map
(lambda (pattern)
(get-match-vars who pattern pattern (stx->list kws)))
(stx->list patterns))]
[lit-comp-is-mod? (and (identifier? lit-comp)
(free-identifier=?
lit-comp
(quote-syntax free-identifier=?)))])
(syntax-arm
(datum->syntax
(quote-syntax here)
(list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?))
expr
(list (quote-syntax datum->syntax)
(list
(quote-syntax quote-syntax)
(datum->syntax
expr
'here))
expr))))
(let loop ([patterns patterns]
[fenders fenders]
[unflat-pattern-varss pattern-varss]
[answers answers])
(cond
[(null? patterns)
(list
(quote-syntax raise-syntax-error)
#f
"bad syntax"
arg)]
[else
(let ([rest (loop (cdr patterns) (cdr fenders)
(cdr unflat-pattern-varss) (cdr answers))])
(let ([pattern (car patterns)]
[fender (car fenders)]
[unflat-pattern-vars (car unflat-pattern-varss)]
[answer (car answers)])
(-define pattern-vars
(map (lambda (var)
(let loop ([var var])
(if (syntax? var)
var
(loop (car var)))))
unflat-pattern-vars))
(-define temp-vars
(map
(lambda (p) (gen-temp-id 'sc))
pattern-vars))
(-define tail-pattern-var (sub1 (length pattern-vars)))
;; Here's the result expression for one match:
(let* ([do-try-next (if (car fenders)
(list (quote-syntax try-next))
rest)]
[mtch (make-match&env
who
pattern
pattern
(stx->list kws)
(not lit-comp-is-mod?)
s-exp?)]
[cant-fail? (if lit-comp-is-mod?
(equal? mtch '(lambda (e) e))
(equal? mtch '(lambda (e free-identifier=?) e)))]
;; Avoid generating gigantic matching expressions.
;; If it's too big, interpret at run time, instead
[interp? (and (not cant-fail?)
(zero?
(let sz ([mtch mtch][fuel 100])
(cond
[(zero? fuel) 0]
[(pair? mtch) (sz (cdr mtch)
(sz (car mtch)
fuel))]
[(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))]
[else (sub1 fuel)]))))]
[mtch (if interp?
(let ([interp-box (box null)])
(let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)])
(list 'lambda
'(e)
(list (if s-exp? 'interp-s-match 'interp-match)
(list 'quote pat)
'e
(if (null? (unbox interp-box))
#f
(list (if s-exp? 'quote 'quote-syntax)
(list->vector (reverse (unbox interp-box)))))
lit-comp))))
mtch)]
[m
;; Do match, bind result to rslt:
(list (quote-syntax let)
(list
(list rslt
(if cant-fail?
arg
(list* (datum->syntax
(quote-syntax here)
mtch
pattern)
arg
(if (or interp? lit-comp-is-mod?)
null
(list lit-comp))))))
;; If match succeeded...
(list
(quote-syntax if)
(if cant-fail?
#t
rslt)
;; Extract each name binding into a temp variable:
(list
(quote-syntax let)
(map (lambda (pattern-var temp-var)
(list
temp-var
(let ([pos (stx-memq-pos pattern-var pattern-vars)])
(let ([accessor (cond
[(= tail-pattern-var pos)
(cond
[(eq? pos 0) 'tail]
[(eq? pos 1) (quote-syntax unsafe-cdr)]
[else 'tail])]
[(eq? pos 0) (quote-syntax unsafe-car)]
[else #f])])
(cond
[(eq? accessor 'tail)
(if (zero? pos)
rslt
(list
(quote-syntax unsafe-list-tail)
rslt
pos))]
[accessor (list
accessor
rslt)]
[else (list
(quote-syntax unsafe-list-ref)
rslt
pos)])))))
pattern-vars temp-vars)
;; Tell nested `syntax' forms about the
;; pattern-bound variables:
(list
(quote-syntax letrec-syntaxes+values)
(map (lambda (pattern-var unflat-pattern-var temp-var)
(list (list pattern-var)
(list
(if s-exp?
(quote-syntax make-s-exp-mapping)
(quote-syntax make-auto-pvar))
;; Tell it the shape of the variable:
(let loop ([var unflat-pattern-var][d 0])
(if (syntax? var)
d
(loop (car var) (add1 d))))
;; Tell it the variable name:
(list
(quote-syntax quote-syntax)
temp-var))))
pattern-vars unflat-pattern-vars
temp-vars)
null
(if fender
(list (quote-syntax if) fender
(list (quote-syntax with-pvars)
pattern-vars
answer)
do-try-next)
(list (quote-syntax with-pvars)
pattern-vars
answer))))
do-try-next))])
(if fender
(list
(quote-syntax let)
;; Bind try-next to try next case
(list (list (quote try-next)
(list (quote-syntax lambda)
(list)
rest)))
;; Try one match
m)
;; Match try already embed the rest case
m))))])))
x)))))))
(#%require racket/private/template)
(#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum
(for-syntax syntax-pattern-variable?)))

59
7-4/racket/collects/racket/private/stxloc.rkt Normal file
View File

@ -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
... _ ~? ~@))

705
7-4/racket/collects/racket/private/template.rkt Normal file
View File

@ -0,0 +1,705 @@
(module template '#%kernel
(#%require racket/private/stx racket/private/small-scheme racket/private/performance-hint
(rename racket/private/small-scheme define -define)
(rename racket/private/small-scheme define-syntax -define-syntax)
racket/private/ellipses
(for-syntax racket/private/stx racket/private/small-scheme
(rename racket/private/small-scheme define -define)
(rename racket/private/small-scheme define-syntax -define-syntax)
racket/private/member racket/private/sc '#%kernel))
(#%provide syntax
syntax/loc
datum
~? ~@
~@! signal-absent-pvar
(for-syntax attribute-mapping
attribute-mapping?
attribute-mapping-name
attribute-mapping-var
attribute-mapping-depth
attribute-mapping-check
(protect metafunction
metafunction?)))
;; ============================================================
;; Syntax of templates
;; A Template (T) is one of:
;; - pattern-variable
;; - constant (including () and non-pvar identifiers)
;; - (metafunction . T)
;; - (H . T)
;; - (H ... . T), (H ... ... . T), etc
;; - (... T) -- escapes inner ..., ~?, ~@
;; - (~? T T)
;; - #(T*) -- actually, vector->list interpreted as T
;; - #s(prefab-struct-key T*) -- likewise
;; A HeadTemplate (H) is one of:
;; - T
;; - (~? H)
;; - (~? H H)
;; - (~@ . T)
(define-syntax ~@! #f) ;; private, escape-ignoring version of ~@, used by unsyntax-splicing
;; ============================================================
;; Compile-time
;; Parse template syntax into a Guide (AST--the name is left over from
;; when the "guide" was a data structure interpreted at run time).
;; The AST representation is designed to coincide with the run-time
;; support, so compilation is just (datum->syntax #'here guide). The
;; variants listed below are the ones recognized and treated specially
;; by other functions (eg optimize-resyntax, relocate-guide).
;; A Guide (G) is one of:
;; - (list 't-resyntax Expr Expr G)
;; - (list 't-quote Datum) ;; constant, but not null
;; - (list 't-quote-syntax Syntax)
;; - (list 't-var Id) ;; trusted pattern variable
;; - (list 't-list G ...)
;; - (list 't-list* G ... G)
;; - (list 't-append HG G)
;; - (list 't-orelse G G)
;; - (list 't-subst Expr Expr '({Subst} ...) Expr ...) ;; apply susbstitutions
;; -- where Subst = Nat ;; replace nth car with arg
;; | 'tail Nat ;; replace nth cdr with arg
;; | 'append Nat ;; replace nth car by appending arg
;; | 'recur Nat ;; replace nth car by recurring on it with arg
;; - other expression (must be pair!)
;; A HeadGuide (HG) is one of:
;; - (list 'h-t G)
;; - other expression (must be pair!)
(begin-for-syntax
(define here-stx (quote-syntax here))
(define template-logger (make-logger 'template (current-logger)))
;; An Attribute is an identifier statically bound to a syntax-mapping
;; (see sc.rkt) whose valvar is an identifier statically bound to an
;; attribute-mapping.
;; (struct attribute-mapping (var name depth check) ...)
;; check : #f (trusted) or Id, ref to Checker
;; Checker = ( Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any)) )
(#%require (for-template (only racket/private/template
attribute-mapping
attribute-mapping?
attribute-mapping-var
attribute-mapping-name
attribute-mapping-depth
attribute-mapping-check)))
#;(define-values (struct:attribute-mapping attribute-mapping attribute-mapping?
attribute-mapping-ref _attribute-mapping-set!)
(make-struct-type 'attribute-mapping #f 4 0 #f null (current-inspector)
(lambda (self stx)
(if (attribute-mapping-check self)
(let ([source-name
(or (let loop ([p (syntax-property stx 'disappeared-use)])
(cond [(identifier? p) p]
[(pair? p) (or (loop (car p)) (loop (cdr p)))]
[else #f]))
(attribute-mapping-name self))])
(define code
`(,(attribute-mapping-check self)
,(attribute-mapping-var self)
,(attribute-mapping-depth self)
#t
(quote-syntax ,source-name)))
(datum->syntax here-stx code stx))
(attribute-mapping-var self)))))
#;(define (attribute-mapping-var a) (attribute-mapping-ref a 0))
#;(define (attribute-mapping-name a) (attribute-mapping-ref a 1))
#;(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
#;(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
;; (struct metafunction (var))
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
(make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector)))
(define (metafunction-var mf) (metafunction-ref mf 0))
(define (guide-is? x tag) (and (pair? x) (eq? (car x) tag)))
(define (ht-guide? x) (guide-is? x 'h-t))
(define (ht-guide-t x) (cadr x))
(define (quote-guide? x) (guide-is? x 't-quote))
(define (quote-guide-v x) (cadr x))
(define (quote-syntax-guide? x) (guide-is? x 't-quote-syntax))
(define (quote-syntax-guide-v x) (cadr x))
(define (null-guide? x) (and (guide-is? x 't-list) (null? (cdr x))))
(define (datum-guide? x) (or (quote-guide? x) (null-guide? x)))
(define (datum-guide-v x) (if (null-guide? x) null (quote-guide-v x)))
(define (list-guide? x) (guide-is? x 't-list))
(define (list-guide-vs x) (cdr x))
(define (list*-guide? x) (guide-is? x 't-list*))
(define (list*-guide-vs x) (cdr x))
(define (struct-guide? x) (guide-is? x 't-struct))
(define (struct-guide-key x) (cadr (cadr x)))
(define (struct-guide-v x) (caddr x))
(define (vector-guide? x) (guide-is? x 't-vector))
(define (vector-guide-v x) (cadr x))
(define (box-guide? x) (guide-is? x 't-box))
(define (box-guide-v x) (cadr x))
(define (append-guide gh gt)
(cond [(ht-guide? gh) (cons-guide (ht-guide-t gh) gt)]
[(null-guide? gt) gh]
[else `(t-append ,gh ,gt)]))
(define (cons-guide g1 g2)
(cond [(and (datum-guide? g1) (datum-guide? g2))
`(t-quote ,(cons (datum-guide-v g1) (datum-guide-v g2)))]
[(list-guide? g2) (list* 't-list g1 (list-guide-vs g2))]
[(list*-guide? g2) (list* 't-list* g1 (list*-guide-vs g2))]
[else (list 't-list* g1 g2)]))
(define (const-stx-guide? x)
(cond [(quote-guide? x) #t]
[(quote-syntax-guide? x) #t]
[(list-guide? x) (andmap const-stx-guide? (list-guide-vs x))]
[(list*-guide? x) (andmap const-stx-guide? (list*-guide-vs x))]
[(struct-guide? x) (const-stx-guide? (struct-guide-v x))]
[(vector-guide? x) (const-stx-guide? (vector-guide-v x))]
[(box-guide? x) (const-stx-guide? (box-guide-v x))]
[else #f]))
(define (const-stx-guide-v x)
(cond [(quote-guide? x) (quote-guide-v x)]
[(quote-syntax-guide? x) (quote-syntax-guide-v x)]
[(list-guide? x) (map const-stx-guide-v (list-guide-vs x))]
[(list*-guide? x) (apply list* (map const-stx-guide-v (list*-guide-vs x)))]
[(struct-guide? x)
(apply make-prefab-struct (struct-guide-key x) (const-stx-guide-v (struct-guide-v x)))]
[(vector-guide? x) (list->vector (const-stx-guide-v (vector-guide-v x)))]
[(box-guide? x) (box (const-stx-guide-v (box-guide-v x)))]
[else (error 'const-stx-guide-v "bad guide: ~e" x)]))
(define (dots-guide hguide frame head at-stx)
(let ([cons? (ht-guide? hguide)]
[hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]
[env (dotsframe-env frame)])
(cond [(and (guide-is? hguide 't-var) (= (length env) 1)
(eq? (cadr hguide) (caar env)))
;; (x ...), where x is trusted
(cond [cons? `(t-var ,(cdar env))]
[else `(apply append (t-var ,(cdar env)))])]
[else
`(t-dots ,cons? ,hguide ,(map car env) ,(map cdr env)
(quote ,head) (quote-syntax ,at-stx))])))
;; A Depth is (Listof MapFrame)
;; A DotsFrame is (vector (Listof (cons Id Syntax)) (Hash Id => Id) Id Bool)
;; Each ellipsis in a template has a corresponding DotsFrame of the form
;; (vector env ht ellipsis-id any-vars?), where
;; -- env is (list (cons iter-id src-list-expr) ...), where src-list-expr
;; is a src-list-id either by itself or wrapped in a check
;; -- ht maps a src-list-id to the corresponding iter-id
;; -- ellipsis-id is the identifier for the ellipsis (for error reporting)
;; -- any-vars? is a flag that indicates whether any pattern variables occur
;; in this frame's subtemplate (for error reporting)
;; When a pattern variable of depth D is found, it is added to the D current
;; innermost (ie, topmost) dotsframes (see `lookup`).
(define (new-dotsframe ellipsis-stx)
(vector null (make-hasheq) ellipsis-stx #f))
(define (dotsframe-env frame) (vector-ref frame 0))
(define (dotsframe-ref frame src-id)
(hash-ref (vector-ref frame 1) src-id #f))
(define (dotsframe-add! frame iter-id src-id src-expr)
(vector-set! frame 0 (cons (cons iter-id src-expr) (vector-ref frame 0)))
(hash-set! (vector-ref frame 1) src-id iter-id))
(define (dotsframe-index-iter frame) (vector-ref frame 2))
(define (dotsframe-index-iter! frame)
(cond [(vector-ref frame 2) => (lambda (x) x)]
[else (let ([index-var (gentemp)])
(vector-set! frame 2 index-var)
index-var)]))
(define (dotsframe-ellipsis-id frame) (vector-ref frame 2))
(define (dotsframe-has-mapvars? frame) (pair? (vector-ref frame 0)))
(define (dotsframe-has-any-vars? frame) (vector-ref frame 3))
(define (frames-seen-pvar! frames)
(when (pair? frames)
(unless (vector-ref (car frames) 3)
(vector-set! (car frames) 3 #t)
(frames-seen-pvar! (cdr frames)))))
(define (ellipsis? x)
(and (identifier? x) (free-identifier=? x (quote-syntax ...))))
;; ----------------------------------------
;; Parsing templates
;; parse-template : Syntax Syntax Boolean -> (values Guide (Listof Id))
(define (parse-template ctx t stx?)
;; wrong-syntax : Syntax Format-String Any ... -> (error)
(define (wrong-syntax x fmt . args) (raise-syntax-error #f (apply format fmt args) ctx x))
;; disappeared-uses : (Listof Id)
(define disappeared-uses null)
;; disappeared! : Id -> Void
(define (disappeared! id) (set! disappeared-uses (cons id disappeared-uses)))
;; parse-t : Stx Nat Boolean -> Guide
(define (parse-t t depth esc?)
(cond [(stx-pair? t)
(if (identifier? (stx-car t))
(parse-t-pair/command t depth esc?)
(parse-t-pair/dots t depth esc?))]
[else (parse-t-nonpair t depth esc?)]))
;; parse-t-pair/command : Stx Nat Boolean -> ...
;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc)
(define (parse-t-pair/command t depth esc?)
(cond [esc?
(parse-t-pair/dots t depth esc?)]
[(parse-form t (quote-syntax ...) 1)
=> (lambda (t)
(disappeared! (car t))
(parse-t (cadr t) depth #t))]
[(parse-form t (quote-syntax ~?) 2)
=> (lambda (t)
(disappeared! (car t))
(define t1 (cadr t))
(define t2 (caddr t))
(define guide1 (parse-t t1 depth esc?))
(define guide2 (parse-t t2 depth esc?))
`(t-orelse ,guide1 ,guide2))]
[(lookup-metafun (stx-car t))
=> (lambda (mf)
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
(disappeared! (stx-car t))
(define guide (parse-t (stx-cdr t) depth esc?))
`(t-metafun ,(metafunction-var mf) ,guide
(quote-syntax
,(let ([tstx (and (syntax? t) t)])
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))]
[else (parse-t-pair/dots t depth esc?)]))
;; parse-t-pair/dots : Stx Nat Boolean -> ...
;; t is a stx pair; check for dots
(define (parse-t-pair/dots t depth esc?)
(define head (stx-car t))
(define-values (tail frames) ;; first-in-stx = innermost is first in list
(let loop ([tail (stx-cdr t)] [frames null])
(cond [(and (not esc?) (stx-pair? tail) (ellipsis? (stx-car tail)))
(disappeared! (stx-car tail))
(loop (stx-cdr tail) (cons (new-dotsframe (stx-car tail)) frames))]
[else (values tail (reverse frames))])))
(define at-stx (datum->syntax #f '... head))
(define hguide
(let loop ([frames frames] [hguide (parse-h head (append frames depth) esc?)])
(cond [(pair? frames)
(define frame (car frames))
(unless (dotsframe-has-mapvars? frame)
(unless (dotsframe-has-any-vars? frame)
(wrong-syntax head "no pattern variables before ellipsis in template"))
(wrong-syntax (dotsframe-ellipsis-id frame) "too many ellipses in template"))
(loop (cdr frames) (dots-guide hguide frame head at-stx))]
[else hguide])))
(define tguide (parse-t tail depth esc?))
(resyntax t (append-guide hguide tguide)))
;; parse-t-nonpair : Syntax Nat Boolean -> ...
;; PRE: t is not a stxpair
(define (parse-t-nonpair t depth esc?)
(define td (if (syntax? t) (syntax-e t) t))
(cond [(identifier? t)
(cond [(and (not esc?)
(or (free-identifier=? t (quote-syntax ...))
(free-identifier=? t (quote-syntax ~?))
(free-identifier=? t (quote-syntax ~@))))
(wrong-syntax t "illegal use")]
[(lookup-metafun t)
(wrong-syntax t "illegal use of syntax metafunction")]
[(lookup t depth) => (lambda (ref) ref)]
[else (const-guide t)])]
[(vector? td)
(define guide (parse-t (vector->list td) depth esc?))
(resyntax t `(t-vector ,guide))]
[(prefab-struct-key td)
=> (lambda (key)
(define elems (cdr (vector->list (struct->vector td))))
(define guide (parse-t elems depth esc?))
(resyntax t `(t-struct (quote ,key) ,guide)))]
[(box? td)
(define guide (parse-t (unbox td) depth esc?))
(resyntax t `(t-box ,guide))]
[else (const-guide t)]))
;; parse-h : Syntax Depth Boolean -> HeadGuide
(define (parse-h h depth esc?)
(cond [(and (not esc?) (parse-form h (quote-syntax ~?) 1))
=> (lambda (h)
(disappeared! (car h))
(define guide (parse-h (cadr h) depth esc?))
`(h-orelse ,guide null))]
[(and (not esc?) (parse-form h (quote-syntax ~?) 2))
=> (lambda (h)
(disappeared! (car h))
(define guide1 (parse-h (cadr h) depth esc?))
(define guide2 (parse-h (caddr h) depth esc?))
(if (and (ht-guide? guide1) (ht-guide? guide2))
`(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
`(h-orelse ,guide1 ,guide2)))]
[(and (stx-pair? h)
(let ([h-head (stx-car h)])
(and (identifier? h-head)
(or (and (free-identifier=? h-head (quote-syntax ~@)) (not esc?))
(free-identifier=? h-head (quote-syntax ~@!))))))
(disappeared! (stx-car h))
(define guide (parse-t (stx-cdr h) depth esc?))
`(h-splice ,guide (quote ,h) (quote-syntax ,(stx-car h)))]
[else
(define guide (parse-t h depth esc?))
`(h-t ,guide)]))
;; lookup : Identifier Depth -> Syntax/#f
;; If pattern variable with depth>0, insert into depth innermost ellipsis envs.
(define (lookup id depth0)
(define (make-pvar var check pvar-depth)
(define (make-ref var)
(cond [check `(t-check-var (,check ,var 0 #t (quote-syntax ,id)))]
[else `(t-var ,var)]))
(define (make-src-ref var id)
(cond [check `(#%expression (,check ,var 1 #f (quote-syntax ,id)))]
[else var]))
(disappeared! id)
(frames-seen-pvar! depth0)
(make-ref
(let dloop ([depth depth0] [pvar-depth pvar-depth]) ;; ... -> Identifier
;; Returns variable reference whose value has not been checked yet.
(cond [(zero? pvar-depth) var]
[(null? depth)
(if (null? depth0)
(wrong-syntax id "missing ellipsis with pattern variable in template")
(wrong-syntax id "too few ellipses for pattern variable in template"))]
[else
(define src (dloop (cdr depth) (sub1 pvar-depth)))
(or (dotsframe-ref (car depth) src)
(let ([iter (gentemp)])
(dotsframe-add! (car depth) iter src (make-src-ref src id))
iter))]))))
(let ([v (syntax-local-value id (lambda () #f))])
(cond [(and stx? (syntax-pattern-variable? v))
(define pvar-depth (syntax-mapping-depth v))
(define attr
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
(and (attribute-mapping? attr) attr)))
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
(define check (and attr (attribute-mapping-check attr)))
(make-pvar var check pvar-depth)]
[(and (not stx?) (s-exp-pattern-variable? v))
(define pvar-depth (s-exp-mapping-depth v))
(define var (s-exp-mapping-valvar v))
(make-pvar var #f pvar-depth)]
[else
;; id is a constant; check that for all x s.t. id = x.y, x is not an attribute
(for-each
(lambda (pfx)
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
(if (and (syntax-pattern-variable? pfx-v)
(let ([valvar (syntax-mapping-valvar pfx-v)])
(attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
(wrong-syntax id "undefined nested attribute of attribute `~a'"
(syntax-e pfx))
(void))))
(dotted-prefixes id))
#f])))
;; resyntax : Stx Guide -> Guide
(define (resyntax t g)
(cond [(not (and stx? (syntax? t))) g]
[(const-stx-guide? g)
`(t-quote-syntax ,(datum->syntax t (const-stx-guide-v g) t t))]
[#t (optimize-resyntax t g)]
[else `(t-resyntax #f (quote-syntax ,(datum->syntax t 'STX t t)) ,g)]))
;; optimize-resyntax : Syntax Guide -> Guide
(define (optimize-resyntax t0 g)
(define HOLE (datum->syntax #f '_))
(define (finish i rt rs re)
(values (sub1 i) (reverse rs) (reverse re)
(datum->syntax t0 (apply list* (reverse rt)) t0 t0)))
(define (loop-gs list*? gs i rt rs re)
(cond [(null? gs)
(finish i (cons null rt) rs re)]
[(and list*? (null? (cdr gs)))
(loop-g (car gs) i rt rs re)]
[else
(define g0 (car gs))
(cond [(quote-syntax-guide? g0)
(let ([const (quote-syntax-guide-v g0)])
(loop-gs list*? (cdr gs) (add1 i) (cons const rt) rs re))]
[(eq? (car g0) 't-subst) ;; (t-subst LOC STX <substs>)
(let ([subt (cadr (list-ref g0 2))] ;; extract from (quote-syntax _)
[subargs (list-tail g0 3)])
(loop-gs list*? (cdr gs) (add1 i) (cons subt rt)
(list* i 'recur rs) (cons `(list . ,subargs) re)))]
[else (loop-gs list*? (cdr gs) (add1 i) (cons HOLE rt)
(cons i rs) (cons g0 re))])]))
(define (loop-g g i rt rs re)
(cond [(list-guide? g)
(loop-gs #f (list-guide-vs g) i rt rs re)]
[(list*-guide? g)
(loop-gs #t (list*-guide-vs g) i rt rs re)]
[(guide-is? g 't-append)
(loop-g (caddr g) (add1 i) (cons HOLE rt)
(list* i 'append rs) (cons (cadr g) re))]
[(eq? (car g) 't-quote-syntax)
(let ([const (quote-syntax-guide-v g)])
(finish i (cons const rt) rs re))]
[else (finish i (cons HOLE rt) (list* i 'tail rs) (cons g re))]))
(define-values (npairs substs exprs t*) (loop-g g 0 null null null))
(cond [(and substs
;; Tunable condition for choosing whether to create a t-subst.
;; Avoid creating useless (t-subst loc stx '(tail 0) g).
(<= (length substs) (* 2 npairs)))
#;(log-message template-logger 'debug
(format "OPTIMIZED ~s" (syntax->datum t0)) #f)
`(t-subst #f (quote-syntax ,t*) (quote ,substs) . ,exprs)]
[else
#;(log-message template-logger 'debug
(format "NOT opt ~s" (syntax->datum t0)) #f)
(let ([rep (datum->syntax t0 'STX t0 t0)])
`(t-resyntax #f (quote-syntax ,rep) ,g))]))
;; const-guide : Any -> Guide
(define (const-guide x)
(cond [(and stx? (syntax? x)) `(t-quote-syntax ,x)]
[(null? x) `(t-list)]
[else `(t-quote , x)]))
(let ([guide (parse-t t null #f)])
(values guide disappeared-uses)))
;; parse-form : Stx Id Nat -> (list[arity+1] Syntax)
(define (parse-form stx form-id arity)
(and (stx-pair? stx)
(let ([stx-h (stx-car stx)] [stx-t (stx-cdr stx)])
(and (identifier? stx-h) (free-identifier=? stx-h form-id)
(let ([stx-tl (stx->list stx-t)])
(and (list? stx-tl)
(= (length stx-tl) arity)
(cons stx-h stx-tl)))))))
;; lookup-metafun : Identifier -> Metafunction/#f
(define (lookup-metafun id)
(define v (syntax-local-value id (lambda () #f)))
(and (metafunction? v) v))
(define (dotted-prefixes id)
(let* ([id-string (symbol->string (syntax-e id))]
[dot-locations
(let loop ([i 0])
(if (< i (string-length id-string))
(if (eqv? (string-ref id-string i) #\.)
(cons i (loop (add1 i)))
(loop (add1 i)))
null))])
(map (lambda (loc) (datum->syntax id (string->symbol (substring id-string 0 loc))))
dot-locations)))
(define gentemp-counter 0)
(define (gentemp)
(set! gentemp-counter (add1 gentemp-counter))
((make-syntax-introducer)
(datum->syntax #f (string->symbol (format "pv_~s" gentemp-counter)))))
(define (stx-drop n x)
(if (zero? n) x (stx-drop (sub1 n) (stx-cdr x))))
;; ----------------------------------------
;; Relocating (eg, syntax/loc)
;; Only relocate if relocation would affect a syntax pair originating
;; from template structure. For example (x,y are pvars):
;; (syntax/loc loc-stx (1 2 3)) => relocate
;; (syntax/loc loc-stx y) => don't relocate
;; (syntax/loc loc-stx (x ... . y) => relocate iff at least one x!
;; Deciding whether to relocate after the fact is hard. But with explicit
;; t-resyntax, it's much easier.
;; relocate-guide : Syntax Guide Id -> Guide
(define (relocate-guide ctx g0 loc-id)
(define (loop g)
(define gtag (car g))
(cond [(guide-is? g 't-resyntax)
`(t-resyntax ,loc-id . ,(cddr g))]
[(quote-syntax-guide? g)
`(t-relocate ,g ,loc-id)]
[(guide-is? g 't-subst)
`(t-subst ,loc-id . ,(cddr g))]
;; ----
[(guide-is? g 't-orelse)
`(t-orelse ,(loop (cadr g)) ,(loop (caddr g)))]
;; ----
;; Nothing else should be relocated
[else g]))
(loop g0))
;; ----------------------------------------
;; do-template : Syntax Syntax Id/#f Boolean -> Syntax
(define (do-template ctx tstx loc-id stx?)
(define-values (pre-guide disappeared-uses)
(parse-template ctx tstx stx?))
(define guide (if loc-id (relocate-guide ctx pre-guide loc-id) pre-guide))
(define code (syntax-arm (datum->syntax here-stx guide ctx)))
(syntax-property code 'disappeared-use (map syntax-local-introduce disappeared-uses)))
)
(define-syntax (syntax stx)
(define s (syntax->list stx))
(if (and (list? s) (= (length s) 2))
(do-template stx (cadr s) #f #t)
(raise-syntax-error #f "bad syntax" stx)))
(define-syntax (syntax/loc stx)
(define s (syntax->list stx))
(if (and (list? s) (= (length s) 3))
(let ([loc-id (quote-syntax loc)])
(define code
`(let ([,loc-id (check-loc (quote ,(car s)) ,(cadr s))])
,(do-template stx (caddr s) loc-id #t)))
(syntax-arm (datum->syntax here-stx code stx)))
(raise-syntax-error #f "bad syntax" stx)))
(define-syntax (datum stx)
(define s (syntax->list stx))
(if (and (list? s) (= (length s) 2))
(do-template stx (cadr s) #f #f)
(raise-syntax-error #f "bad syntax" stx)))
;; check-loc : Symbol Any -> (U Syntax #f)
;; Raise exn if not syntax. Returns same syntax if suitable for srcloc
;; (ie, if at least syntax-source or syntax-position set), #f otherwise.
(define (check-loc who x)
(if (syntax? x)
(if (or (syntax-source x) (syntax-position x))
x
#f)
(raise-argument-error who "syntax?" x)))
;; ============================================================
;; Run-time support
;; (t-dots cons? hguide iter-vars src-vars head-datum at-stx) : Expr[(Listof Syntax)]
(define-syntax (t-dots stx)
(define s (syntax->list stx))
(define cons? (syntax-e (list-ref s 1)))
(define head (list-ref s 2))
(define iter-vars (syntax->list (list-ref s 3)))
(define src-exprs (syntax->list (list-ref s 4)))
(define in-stx (list-ref s 5))
(define at-stx (list-ref s 6))
(define code
`(let ,(map list iter-vars src-exprs)
,(if (> (length iter-vars) 1) `(check-same-length ,in-stx ,at-stx . ,iter-vars) '(void))
,(if cons?
`(map (lambda ,iter-vars ,head) . ,iter-vars)
`(apply append (map (lambda ,iter-vars ,head) . ,iter-vars)))))
(datum->syntax here-stx code stx))
(define-syntaxes (t-orelse h-orelse)
(let ()
(define (orelse-transformer stx)
(define s (syntax->list stx))
(datum->syntax here-stx
`(t-orelse* (lambda () ,(cadr s)) (lambda () ,(caddr s)))))
(values orelse-transformer orelse-transformer)))
(#%require (rename '#%kernel t-quote quote)
(rename '#%kernel t-quote-syntax quote-syntax)
(rename '#%kernel t-var #%expression)
(rename '#%kernel t-check-var #%expression)
;; (rename '#%kernel t-append append)
(rename '#%kernel t-list list)
(rename '#%kernel t-list* list*)
(rename '#%kernel t-escaped #%expression)
(rename '#%kernel t-vector list->vector)
(rename '#%kernel t-box box-immutable)
(rename '#%kernel h-t list))
(begin-encourage-inline
(define (t-append xs ys) (if (null? ys) xs (append xs ys)))
(define (t-resyntax loc stx g) (datum->syntax stx g (or loc stx) stx))
(define (t-relocate g loc) (datum->syntax g (syntax-e g) (or loc g) g))
(define (t-orelse* g1 g2)
((let/ec escape
(with-continuation-mark
absent-pvar-escape-key
(lambda () (escape g2))
(let ([v (g1)]) (lambda () v))))))
(define (t-struct key g) (apply make-prefab-struct key g))
(define (t-metafun mf g stx)
(mf (datum->syntax stx (cons (stx-car stx) g) stx stx)))
(define (h-splice g in-stx at-stx)
(if (stx-list? g) (stx->list g) (error/splice g in-stx at-stx)))
#| end begin-encourage-inline |#)
;; t-subst : Syntax/#f Syntax Substs Any ... -> Syntax
;; where Substs = '() | (cons Nat Substs) | (list* (U 'tail 'append 'recur) Nat Substs)
;; There is one arg for each index in substs. See also defn of Guide above.
(define (t-subst loc stx substs . args)
(define (loop/mode s i mode seek substs args)
(cond [(< i seek) (cons (car s) (loop/mode (cdr s) (add1 i) mode seek substs args))]
[(eq? mode #f) (cons (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
[(eq? mode 'tail) (car args)]
[(eq? mode 'append) (append (car args) (loop (cdr s) (add1 i) substs (cdr args)))]
[(eq? mode 'recur) (cons (apply t-subst #f (car s) (car args))
(loop (cdr s) (add1 i) substs (cdr args)))]))
(define (loop s i substs args)
(cond [(null? substs) s]
[(symbol? (car substs))
(loop/mode s i (car substs) (cadr substs) (cddr substs) args)]
[else (loop/mode s i #f (car substs) (cdr substs) args)]))
(define v (loop (syntax-e stx) 0 substs args))
(datum->syntax stx v (or loc stx) stx))
(define absent-pvar-escape-key (gensym 'absent-pvar-escape))
;; signal-absent-pvar : -> escapes or #f
;; Note: Only escapes if in ~? form.
(define (signal-absent-pvar)
(let ([escape (continuation-mark-set-first #f absent-pvar-escape-key)])
(if escape (escape) #f)))
;; error/splice : Any Stx Stx -> (escapes)
(define (error/splice r in-stx at-stx)
(raise-syntax-error 'syntax
(format "splicing template did not produce a syntax list\n got: ~e" r) in-stx at-stx))
;; check-same-length : Stx Stx List ... -> Void
(define check-same-length
(case-lambda
[(in at a) (void)]
[(in at a b)
(if (= (length a) (length b))
(void)
(raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
(list in '...) at))]
[(in at a . bs)
(define alen (length a))
(for-each (lambda (b)
(if (= alen (length b))
(void)
(raise-syntax-error 'syntax "incompatible ellipsis match counts for template"
(list in '...) at)))
bs)]))
)

99
7-4/racket/collects/racket/private/with-stx.rkt Normal file
View File

@ -0,0 +1,99 @@
;;----------------------------------------------------------------------
;; with-syntax, generate-temporaries
(module with-stx '#%kernel
(#%require racket/private/stx racket/private/small-scheme "stxcase.rkt"
(for-syntax '#%kernel racket/private/stx "stxcase.rkt" "stxloc.rkt"
racket/private/gen-temp racket/private/sc racket/private/qq-and-or racket/private/cond))
(-define (with-syntax-fail stx)
(raise-syntax-error
'with-syntax
"binding match failed"
stx))
(-define (with-datum-fail stx)
(raise-syntax-error
'with-datum
"binding match failed"
stx))
;; Partly from Dybvig
(begin-for-syntax
(define-values (gen-with-syntax)
(let ([here-stx (quote-syntax here)])
(lambda (x s-exp?)
(syntax-case x ()
((_ () e1 e2 ...)
(syntax/loc x (let () e1 e2 ...)))
((_ ((out in) ...) e1 e2 ...)
(let ([ins (syntax->list (syntax (in ...)))])
;; Check for duplicates or other syntax errors:
(get-match-vars (syntax _) x (syntax (out ...)) null)
;; Generate temps and contexts:
(let ([tmps (map (lambda (x) (gen-temp-id 'ws)) ins)]
[heres (map (lambda (x)
(datum->syntax
x
'here
x))
ins)]
[outs (syntax->list (syntax (out ...)))])
;; Let-bind RHSs, then build up nested syntax-cases:
(datum->syntax
here-stx
`(let ,(map (lambda (tmp here in)
`[,tmp ,(if s-exp?
in
`(datum->syntax
(quote-syntax ,here)
,in))])
tmps heres ins)
,(let loop ([tmps tmps][outs outs])
(cond
[(null? tmps)
(syntax (begin e1 e2 ...))]
[else `(syntax-case** #f #t ,(car tmps) () ,(if s-exp? 'eq? 'free-identifier=?) ,s-exp?
[,(car outs) ,(loop (cdr tmps)
(cdr outs))]
[_ (,(if s-exp? 'with-datum-fail 'with-syntax-fail)
;; Minimize the syntax structure we keep:
(quote-syntax ,(datum->syntax
#f
(syntax->datum (car outs))
(car outs))))])])))
x)))))))))
(-define-syntax with-syntax (lambda (stx) (gen-with-syntax stx #f)))
(-define-syntax with-datum (lambda (stx) (gen-with-syntax stx #t)))
(-define counter 0)
(-define (append-number s)
(set! counter (add1 counter))
(string->symbol (format "~a~s" s counter)))
(-define (generate-temporaries sl)
(unless (stx-list? sl)
(raise-argument-error
'generate-temporaries
"(or/c list? syntax->list)"
sl))
(let ([l (stx->list sl)])
(map (lambda (x)
((make-syntax-introducer)
(cond
[(symbol? x)
(datum->syntax #f (append-number x))]
[(string? x)
(datum->syntax #f (append-number x))]
[(keyword? x)
(datum->syntax #f (append-number (keyword->string x)))]
[(identifier? x)
(datum->syntax #f (append-number (syntax-e x)))]
[(and (syntax? x) (keyword? (syntax-e x)))
(datum->syntax #f (append-number (keyword->string (syntax-e x))))]
[else
(datum->syntax #f (append-number 'temp))])))
l)))
(#%provide with-syntax with-datum generate-temporaries))

216
7-4/racket/collects/racket/syntax.rkt Normal file
View File

@ -0,0 +1,216 @@
#lang racket/base
(require (only-in "stxloc.rkt" syntax-case)
stxparse-info/current-pvars
(for-syntax racket/base
racket/private/sc
auto-syntax-e/utils))
(provide define/with-syntax
current-recorded-disappeared-uses
with-disappeared-uses
syntax-local-value/record
record-disappeared-uses
format-symbol
format-id
current-syntax-context
wrong-syntax
generate-temporary
internal-definition-context-apply
syntax-local-eval
with-syntax*)
;; == Defining pattern variables ==
(define-syntax (define/with-syntax stx)
(syntax-case stx ()
[(define/with-syntax pattern rhs)
(let* ([pvar-env (get-match-vars #'define/with-syntax
stx
#'pattern
'())]
[depthmap (for/list ([x pvar-env])
(let loop ([x x] [d 0])
(if (pair? x)
(loop (car x) (add1 d))
(cons x d))))]
[pvars (map car depthmap)]
[depths (map cdr depthmap)]
[mark (make-syntax-introducer)])
(with-syntax ([(pvar ...) pvars]
[(depth ...) depths]
[(valvar ...) (generate-temporaries pvars)])
#'(begin (define-values (valvar ...)
(with-syntax ([pattern rhs])
(values (pvar-value pvar) ...)))
(define-syntax pvar
(make-auto-pvar 'depth (quote-syntax valvar)))
...
(define-pvars pvar ...))))]))
;; Ryan: alternative name: define/syntax-pattern ??
;; auxiliary macro
(define-syntax (pvar-value stx)
(syntax-case stx ()
[(_ pvar)
(identifier? #'pvar)
(let ([mapping (syntax-local-value #'pvar)])
(unless (syntax-pattern-variable? mapping)
(raise-syntax-error #f "not a pattern variable" #'pvar))
(syntax-mapping-valvar mapping))]))
;; == Disappeared uses ==
(define current-recorded-disappeared-uses (make-parameter #f))
(define-syntax-rule (with-disappeared-uses body-expr ... stx-expr)
(let-values ([(stx disappeared-uses)
(parameterize ((current-recorded-disappeared-uses null))
(let ([result (let () body-expr ... stx-expr)])
(values result (current-recorded-disappeared-uses))))])
(syntax-property stx
'disappeared-use
(append (or (syntax-property stx 'disappeared-use) null)
disappeared-uses))))
(define (syntax-local-value/record id pred)
(unless (identifier? id)
(raise-argument-error 'syntax-local-value/record
"identifier?"
0 id pred))
(unless (and (procedure? pred)
(procedure-arity-includes? pred 1))
(raise-argument-error 'syntax-local-value/record
"(-> any/c boolean?)"
1 id pred))
(let ([value (syntax-local-value id (lambda () #f))])
(and (pred value)
(begin (record-disappeared-uses (list id))
value))))
(define (record-disappeared-uses ids [intro? (syntax-transforming?)])
(cond
[(identifier? ids) (record-disappeared-uses (list ids) intro?)]
[(and (list? ids) (andmap identifier? ids))
(let ([uses (current-recorded-disappeared-uses)])
(when uses
(current-recorded-disappeared-uses
(append
(if intro?
(map syntax-local-introduce ids)
ids)
uses))))]
[else (raise-argument-error 'record-disappeared-uses
"(or/c identifier? (listof identifier?))"
ids)]))
;; == Identifier formatting ==
(define (format-id lctx
#:source [src #f]
#:props [props #f]
#:cert [cert #f]
fmt . args)
(define (convert x) (->atom x 'format-id))
(check-restricted-format-string 'format-id fmt)
(let* ([args (map convert args)]
[str (apply format fmt args)]
[sym (string->symbol str)])
(datum->syntax lctx sym src props cert)))
;; Eli: This looks very *useful*, but I'd like to see it more convenient to
;; "preserve everything". Maybe add a keyword argument that when #t makes
;; all the others use values lctx, and when syntax makes the others use that
;; syntax?
;; Finally, if you get to add this, then another useful utility in the same
;; spirit is one that concatenates symbols and/or strings and/or identifiers
;; into a new identifier. I considered something like that, which expects a
;; single syntax among its inputs, and will use it for the context etc, or
;; throw an error if there's more or less than 1.
(define (format-symbol fmt . args)
(define (convert x) (->atom x 'format-symbol))
(check-restricted-format-string 'format-symbol fmt)
(let ([args (map convert args)])
(string->symbol (apply format fmt args))))
(define (restricted-format-string? fmt)
(regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt))
(define (check-restricted-format-string who fmt)
(unless (restricted-format-string? fmt)
(raise-arguments-error who
(format "format string should have ~a placeholders"
fmt)
"format string" fmt)))
(define (->atom x err)
(cond [(string? x) x]
[(symbol? x) x]
[(identifier? x) (syntax-e x)]
[(keyword? x) (keyword->string x)]
[(number? x) x]
[(char? x) x]
[else (raise-argument-error err
"(or/c string? symbol? identifier? keyword? char? number?)"
x)]))
;; == Error reporting ==
(define current-syntax-context
(make-parameter #f
(lambda (new-value)
(unless (or (syntax? new-value) (eq? new-value #f))
(raise-argument-error 'current-syntax-context
"(or/c syntax? #f)"
new-value))
new-value)))
(define (wrong-syntax stx #:extra [extras null] format-string . args)
(unless (or (eq? stx #f) (syntax? stx))
(raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args)))
(let* ([ctx (current-syntax-context)]
[blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))])
(raise-syntax-error (if (symbol? blame) blame #f)
(apply format format-string args)
ctx
stx
extras)))
;; Eli: The `report-error-as' thing seems arbitrary to me.
;; == Other utilities ==
;; generate-temporary : any -> identifier
(define (generate-temporary [stx 'g])
(car (generate-temporaries (list stx))))
;; Included for backwards compatibility.
(define (internal-definition-context-apply intdefs stx)
; The old implementation of internal-definition-context-apply implicitly converted its stx argument
; to syntax, which some things seem to (possibly unintentionally) rely on, so replicate that
; behavior here:
(internal-definition-context-introduce intdefs (datum->syntax #f stx) 'add))
(define (syntax-local-eval stx [intdefs '()])
(let* ([name (generate-temporary)]
[intdef (syntax-local-make-definition-context)])
(syntax-local-bind-syntaxes (list name)
#`(call-with-values (lambda () #,stx) list)
intdef
intdefs)
(apply values
(syntax-local-value (internal-definition-context-introduce intdef name)
#f intdef))))
(define-syntax (with-syntax* stx)
(syntax-case stx ()
[(_ () body ...) (syntax/loc stx (let () body ...))]
[(_ (cl) body ...) (syntax/loc stx (with-syntax (cl) body ...))]
[(_ (cl cls ...) body ...)
(with-syntax ([with-syntax/rest (syntax/loc stx (with-syntax* (cls ...) body ...))])
(syntax/loc stx (with-syntax (cl) with-syntax/rest)))]))

33
7-4/racket/collects/syntax/parse.rkt Normal file
View File

@ -0,0 +1,33 @@
#lang racket/base
(require (for-syntax racket/base)
racket/contract/base
"parse/pre.rkt"
"parse/experimental/provide.rkt"
"parse/experimental/contract.rkt")
(provide (except-out (all-from-out "parse/pre.rkt")
static)
expr/c)
(provide-syntax-class/contract
[static (syntax-class/c [(-> any/c any/c) (or/c string? symbol? #f)])])
(begin-for-syntax
(require racket/contract/base
syntax/parse/private/residual-ct)
(provide pattern-expander?
(contract-out
[prop:syntax-class
(struct-type-property/c (or/c identifier? (-> any/c identifier?)))]
[pattern-expander
(-> (-> syntax? syntax?) pattern-expander?)]
[prop:pattern-expander
(struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
[syntax-local-syntax-parse-pattern-introduce
(-> syntax? syntax?)]))
(require (only-in (for-template syntax/parse) pattern-expander))
#;(define pattern-expander
(let ()
(struct pattern-expander (proc) #:transparent
#:omit-define-syntaxes
#:property prop:pattern-expander (λ (this) (pattern-expander-proc this)))
pattern-expander)))

129
7-4/racket/collects/syntax/parse/debug.rkt Normal file
View File

@ -0,0 +1,129 @@
#lang racket/base
(require (for-syntax racket/base
syntax/stx
racket/syntax
syntax/parse/private/rep-data
"private/rep.rkt"
syntax/parse/private/kws)
racket/list
racket/pretty
"../parse.rkt"
(except-in stxparse-info/parse/private/residual
prop:syntax-class
prop:pattern-expander
syntax-local-syntax-parse-pattern-introduce)
"private/runtime.rkt"
"private/runtime-progress.rkt"
"private/runtime-report.rkt"
syntax/parse/private/kws)
;; No lazy loading for this module's dependencies.
(provide syntax-class-parse
syntax-class-attributes
syntax-class-arity
syntax-class-keywords
debug-rhs
debug-pattern
debug-parse
debug-syntax-parse!)
(define-syntax (syntax-class-parse stx)
(syntax-case stx ()
[(_ s x arg ...)
(parameterize ((current-syntax-context stx))
(with-disappeared-uses
(let* ([argu (parse-argu (syntax->list #'(arg ...)) #:context stx)]
[stxclass
(get-stxclass/check-arity #'s stx
(length (arguments-pargs argu))
(arguments-kws argu))]
[attrs (stxclass-attrs stxclass)])
(with-syntax ([parser (stxclass-parser stxclass)]
[argu argu]
[(name ...) (map attr-name attrs)]
[(depth ...) (map attr-depth attrs)])
#'(let ([fh (lambda (undos fs) fs)])
(app-argu parser x x (ps-empty x x) #f null fh fh #f
(lambda (fh undos . attr-values)
(map vector '(name ...) '(depth ...) attr-values))
argu))))))]))
(define-syntaxes (syntax-class-attributes
syntax-class-arity
syntax-class-keywords)
(let ()
(define ((mk handler) stx)
(syntax-case stx ()
[(_ s)
(parameterize ((current-syntax-context stx))
(with-disappeared-uses
(handler (get-stxclass #'s))))]))
(values (mk (lambda (s)
(let ([attrs (stxclass-attrs s)])
(with-syntax ([(a ...) (map attr-name attrs)]
[(d ...) (map attr-depth attrs)])
#'(quote ((a d) ...))))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(to-procedure-arity '#,(arity-minpos a) '#,(arity-maxpos a)))))
(mk (lambda (s)
(let ([a (stxclass-arity s)])
#`(values '#,(arity-minkws a) '#,(arity-maxkws a))))))))
(define-syntax (debug-rhs stx)
(syntax-case stx ()
[(debug-rhs rhs)
(let ([rhs (parse-rhs #'rhs #f #:context stx)])
#`(quote #,rhs))]))
(define-syntax (debug-pattern stx)
(syntax-case stx ()
[(debug-pattern p . rest)
(let-values ([(rest pattern defs)
(parse-pattern+sides #'p #'rest
#:splicing? #f
#:decls (new-declenv null)
#:context stx)])
(unless (stx-null? rest)
(raise-syntax-error #f "unexpected terms" stx rest))
#`(quote ((definitions . #,defs)
(pattern #,pattern))))]))
(define-syntax-rule (debug-parse x p ...)
(let/ec escape
(parameterize ((current-failure-handler
(lambda (_ fs)
(define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
(escape
`(parse-failure
#:raw-failures
,raw-fs-sexpr
#:maximal-failures
,maximal-fs-sexpr)))))
(syntax-parse x [p 'success] ...))))
(define (fs->sexprs fs)
(let* ([raw-fs (map invert-failure (reverse (flatten fs)))]
[selected-groups (maximal-failures raw-fs)])
(values (failureset->sexpr raw-fs)
(let ([selected (map (lambda (fs)
(cons 'progress-class
(map failure->sexpr fs)))
selected-groups)])
(if (= (length selected) 1)
(car selected)
(cons 'union selected))))))
(define (debug-syntax-parse!)
(define old-failure-handler (current-failure-handler))
(current-failure-handler
(lambda (ctx fs)
(define-values (raw-fs-sexpr maximal-fs-sexpr) (fs->sexprs fs))
(eprintf "*** syntax-parse debug info ***\n")
(eprintf "Raw failures:\n")
(pretty-write raw-fs-sexpr (current-error-port))
(eprintf "Maximal failures:\n")
(pretty-write maximal-fs-sexpr (current-error-port))
(old-failure-handler ctx fs))))

20
7-4/racket/collects/syntax/parse/define.rkt Normal file
View File

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

46
7-4/racket/collects/syntax/parse/experimental/contract.rkt Normal file
View File

@ -0,0 +1,46 @@
#lang racket/base
(require stxparse-info/parse/pre
"provide.rkt"
syntax/contract
(only-in stxparse-info/parse/private/residual ;; keep abs. path
this-context-syntax
this-role)
racket/contract/base)
(define not-given (gensym))
(define-syntax-class (expr/c ctc-stx
#:arg? [arg? #t]
#:positive [pos-blame 'from-macro]
#:negative [neg-blame 'use-site]
#:macro [macro-name #f]
#:name [expr-name not-given]
#:context [ctx #f]
#:phase [phase (syntax-local-phase-level)])
#:attributes (c)
#:commit
(pattern y:expr
#:with
c (wrap-expr/c ctc-stx
#'y
#:arg? arg?
#:positive pos-blame
#:negative neg-blame
#:name (if (eq? expr-name not-given)
this-role
expr-name)
#:macro macro-name
#:context (or ctx (this-context-syntax))
#:phase phase)))
(provide-syntax-class/contract
[expr/c (syntax-class/c (syntax?)
(#:arg? any/c
#:positive (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
#:negative (or/c syntax? string? module-path-index?
'from-macro 'use-site 'unknown)
#:name (or/c identifier? string? symbol? #f)
#:macro (or/c identifier? string? symbol? #f)
#:context (or/c syntax? #f)
#:phase exact-integer?))])

5
7-4/racket/collects/syntax/parse/experimental/eh.rkt Normal file
View File

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

1
7-4/racket/collects/syntax/parse/experimental/private/substitute.rkt Normal file
View File

@ -0,0 +1 @@
#lang racket/base

156
7-4/racket/collects/syntax/parse/experimental/provide.rkt Normal file
View File

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

147
7-4/racket/collects/syntax/parse/experimental/reflect.rkt Normal file
View File

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

40
7-4/racket/collects/syntax/parse/experimental/specialize.rkt Normal file
View File

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

95
7-4/racket/collects/syntax/parse/experimental/splicing.rkt Normal file
View File

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

49
7-4/racket/collects/syntax/parse/experimental/template.rkt Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require (for-syntax racket/base
auto-syntax-e/utils)
(only-in racket/private/template
metafunction))
(provide (rename-out [syntax template]
[syntax/loc template/loc]
[quasisyntax quasitemplate]
[quasisyntax/loc quasitemplate/loc]
[~? ??]
[~@ ?@])
define-template-metafunction)
;; ============================================================
;; Metafunctions
(define-syntax (define-template-metafunction stx)
(syntax-case stx ()
[(dsm (id arg ...) . body)
#'(dsm id (lambda (arg ...) . body))]
[(dsm id expr)
(identifier? #'id)
(with-syntax ([(internal-id) (generate-temporaries #'(id))])
#'(begin (define internal-id (make-hygienic-metafunction expr))
(define-syntax id (metafunction (quote-syntax internal-id)))))]))
(define current-template-metafunction-introducer
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))
(define old-template-metafunction-introducer
(make-parameter #f))
(define (syntax-local-template-metafunction-introduce stx)
(let ([mark (current-template-metafunction-introducer)]
[old-mark (old-template-metafunction-introducer)])
(unless old-mark
(error 'syntax-local-template-metafunction-introduce
"must be called within the dynamic extent of a template metafunction"))
(mark (old-mark stx))))
(define ((make-hygienic-metafunction transformer) stx)
(define mark (make-syntax-introducer))
(define old-mark (current-template-metafunction-introducer))
(parameterize ((current-template-metafunction-introducer mark)
(old-template-metafunction-introducer old-mark))
(define r (call-with-continuation-barrier (lambda () (transformer (mark (old-mark stx))))))
(unless (syntax? r)
(raise-syntax-error #f "result of template metafunction was not syntax" stx))
(old-mark (mark r))))

112
7-4/racket/collects/syntax/parse/lib/function-header.rkt Normal file
View File

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

49
7-4/racket/collects/syntax/parse/pre.rkt Normal file
View File

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

250
7-4/racket/collects/syntax/parse/private/3d-stx.rkt Normal file
View File

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

96
7-4/racket/collects/syntax/parse/private/lib.rkt Normal file
View File

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

284
7-4/racket/collects/syntax/parse/private/litconv.rkt Normal file
View File

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

43
7-4/racket/collects/syntax/parse/private/make.rkt Normal file
View File

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

456
7-4/racket/collects/syntax/parse/private/opt.rkt Normal file
View File

@ -0,0 +1,456 @@
#lang racket/base
(require racket/syntax
racket/pretty
syntax/parse/private/residual-ct ;; keep abs. path
syntax/parse/private/minimatch
syntax/parse/private/rep-patterns
syntax/parse/private/kws)
(provide (struct-out pk1)
(rename-out [optimize-matrix0 optimize-matrix]))
;; ----
;; A Matrix is a (listof PK) where each PK has same number of columns
;; A PK is one of
;; - (pk1 (listof pattern) expr) -- a simple row in a parsing matrix
;; - (pk/same pattern Matrix) -- a submatrix with a common first column factored out
;; - (pk/pair Matrix) -- a submatrix with pair patterns in the first column unfolded
;; - (pk/and Matrix) -- a submatrix with and patterns in the first column unfolded
(struct pk1 (patterns k) #:prefab)
(struct pk/same (pattern inner) #:prefab)
(struct pk/pair (inner) #:prefab)
(struct pk/and (inner) #:prefab)
(define (pk-columns pk)
(match pk
[(pk1 patterns k) (length patterns)]
[(pk/same p inner) (add1 (pk-columns inner))]
[(pk/pair inner) (sub1 (pk-columns inner))]
[(pk/and inner) (sub1 (pk-columns inner))]))
;; Can factor pattern P given clauses like
;; [ P P1 ... | e1] [ | [P1 ... | e1] ]
;; [ P : | :] => [P | [ : | :] ]
;; [ P PN ... | eN] [ | [PN ... | eN] ]
;; if P cannot cut and P succeeds at most once (otherwise may reorder backtracking)
;; Can unfold pair patterns as follows:
;; [ (P11 . P12) P1 ... | e1 ] [ P11 P12 P1 ... | e1 ]
;; [ : : | : ] => check pair, [ : | : ]
;; [ (PN1 . PN2) PN ... | eN ] [ PN1 PN2 PN ... | eN ]
;; Can unfold ~and patterns similarly; ~and patterns can hide
;; factoring opportunities.
;; ----
;; FIXME: New (unimplemented) optimization ideas
;; (1) When collecting pair patterns, can reorder rows with pair vs never-pair
;; first columns:
;; [ (P11 . P12) P1 ... | e1 ] [ (P11 . P12) P1 ... | e1 ]
;; [ P21 P2 ... | e2 ] => [ (P31 . P32) P3 ... | e3 ]
;; [ (P31 . P32) P3 ... | e3 ] [ P21 P2 ... | e2 ]
;; provided P21 does not cut and cannot match a pair term.
;; Likewise for literals and never-symbol patterns.
;; (2) If a row has a non-rejecting pattern (ie, always matches) in its first
;; column, then the rows above it do not need to produce failure information
;; *for their first columns*. For example, in the following matrix
;; [ P11 P1 ... | e1 ]
;; [ P21 P2 ... | e2 ]
;; [ P31 P3 ... | e3 ]
;; Suppose that P21 always matches (eg _) and assume P{1,3}1 are cut-free. Then
;; P{1,3}1 do not need to produce failure info (set es = #f, etc). Here's why.
;; If control reaches row 2, then since P21 cannot fail, if it fails the
;; progress must be greater than P11 or P31. FIXME: Must also check neither P11
;; nor P31 use ~post (or call stxclass that uses ~post, etc)!
;; ----
(define (optimize-matrix0 rows)
(define now (current-inexact-milliseconds))
(when (and (> (length rows) 1))
(log-syntax-parse-debug "OPT matrix (~s rows)\n~a" (length rows)
(pretty-format (matrix->sexpr rows) #:mode 'print)))
(define result (optimize-matrix rows))
(define then (current-inexact-milliseconds))
(when (and (> (length rows) 1))
(cond [(= (length result) (length rows))
(log-syntax-parse-debug "OPT FAILED (~s ms)" (floor (- then now)))]
[else
(log-syntax-parse-debug "OPT ==> (~s ms)\n~a" (floor (- then now))
(pretty-format (matrix->sexpr result) #:mode 'print))]))
result)
;; optimize-matrix : (listof pk1) -> Matrix
(define (optimize-matrix rows)
(cond [(null? rows) null]
[(null? (cdr rows)) rows] ;; no opportunities for 1 row
[(null? (pk1-patterns (car rows))) rows]
[else
;; first unfold and-patterns
(let-values ([(col1 col2)
(for/lists (col1 col2) ([row (in-list rows)])
(unfold-and (car (pk1-patterns row)) null))])
(cond [(ormap pair? col2)
(list
(pk/and
(optimize-matrix*
(for/list ([row (in-list rows)]
[col1 (in-list col1)]
[col2 (in-list col2)])
(pk1 (list* col1
(make-and-pattern col2)
(cdr (pk1-patterns row)))
(pk1-k row))))))]
[else (optimize-matrix* rows)]))]))
;; optimize-matrix* : (listof pk1) -> Matrix
;; The matrix is nonempty, and first column has no unfoldable pat:and.
;; Split into submatrixes (sequences of rows) starting with similar patterns,
;; handle according to similarity, then recursively optimize submatrixes.
(define (optimize-matrix* rows)
(define row1 (car rows))
(define pat1 (car (pk1-patterns row1)))
(define k1 (pk1-k row1))
;; Now accumulate rows starting with patterns like pat1
(define-values (like? combine) (pattern->partitioner pat1))
(let loop ([rows (cdr rows)] [rrows (list row1)])
(cond [(null? rows)
(cons (combine (reverse rrows)) null)]
[else
(define row1 (car rows))
(define pat1 (car (pk1-patterns row1)))
(cond [(like? pat1)
(loop (cdr rows) (cons row1 rrows))]
[else
(cons (combine (reverse rrows))
(optimize-matrix* rows))])])))
;; pattern->partitioner : pattern -> (values (pattern -> boolean) ((listof pk1) -> PK))
(define (pattern->partitioner pat1)
(match pat1
[(pat:pair head tail)
(values (lambda (p) (pat:pair? p))
(lambda (rows)
(log-syntax-parse-debug "-- got ~s pair rows like ~e" (length rows) (pattern->sexpr pat1))
(cond [(> (length rows) 1)
(pk/pair (optimize-matrix
(for/list ([row (in-list rows)])
(let* ([patterns (pk1-patterns row)]
[pat1 (car patterns)])
(pk1 (list* (pat:pair-head pat1)
(pat:pair-tail pat1)
(cdr patterns))
(pk1-k row))))))]
[else (car rows)])))]
[(? pattern-factorable?)
(values (lambda (pat2) (pattern-equal? pat1 pat2))
(lambda (rows)
(log-syntax-parse-debug "-- got ~s factorable like ~e" (length rows) (pattern->sexpr pat1))
(cond [(> (length rows) 1)
(pk/same pat1
(optimize-matrix
(for/list ([row (in-list rows)])
(pk1 (cdr (pk1-patterns row)) (pk1-k row)))))]
[else (car rows)])))]
[_
(values (lambda (pat2) #f)
(lambda (rows)
;; (length rows) = 1
(car rows)))]))
;; unfold-and : pattern (listof pattern) -> (values pattern (listof pattern))
(define (unfold-and p onto)
(match p
[(pat:and subpatterns)
;; pat:and is worth unfolding if first subpattern is not pat:action
;; if first subpattern is also pat:and, keep unfolding
(let* ([first-sub (car subpatterns)]
[rest-subs (cdr subpatterns)])
(cond [(not (pat:action? first-sub))
(unfold-and first-sub (*append rest-subs onto))]
[else (values p onto)]))]
[_ (values p onto)]))
;; pattern-factorable? : *Pattern -> Boolean
(define (pattern-factorable? p) (not (pattern-unfactorable? p)))
;; pattern-unfactorable? : *Pattern -> Boolean
(define (pattern-unfactorable? p)
;; Cannot factor out p if
;; - if p can succeed multiple times (factoring changes success order)
;; - if p can cut (factoring changes which choice points are discarded (too few))
;; Note: presence of sub-expressions handled by pattern-equal?.
(define (for-pattern p recur)
(match p
[(pat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
[(pat:action _act _pat) #t]
[(pat:dots heads tail)
;; Conservative approximation for common case: one head pattern
;; In general, check if heads don't overlap, don't overlap with tail.
(or (> (length heads) 1)
(not (equal? tail (pat:datum '())))
(recur))]
[(pat:or _ patterns _) #t]
[(pat:not pattern) #t]
[(pat:commit pattern) #f]
[(? pat:reflect?) #t]
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _)) (not commit?)]
[(hpat:commit inner) #f]
[(ehpat _ head repc _)
(or (not (equal? repc #f))
(recur))]
[_ (recur)]))
(pattern-ormap p for-pattern))
(define (subpatterns-equal? as bs)
(and (= (length as) (length bs))
(for/and ([a (in-list as)]
[b (in-list bs)])
(pattern-equal? a b))))
(define (pattern-equal? a b)
(define result
(cond [(and (pat:any? a) (pat:any? b)) #t]
[(and (pat:svar? a) (pat:svar? b))
(bound-identifier=? (pat:svar-name a) (pat:svar-name b))]
[(and (pat:var/p? a) (pat:var/p? b))
(and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
(bound-id/f-equal? (pat:var/p-name a) (pat:var/p-name b))
(equal-iattrs? (pat:var/p-nested-attrs a) (pat:var/p-nested-attrs b))
(equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
(expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
[(and (pat:integrated? a) (pat:integrated? b))
(and (bound-id/f-equal? (pat:integrated-name a) (pat:integrated-name b))
(free-identifier=? (pat:integrated-predicate a)
(pat:integrated-predicate b))
(expr-equal? (pat:integrated-role a) (pat:integrated-role b)))]
[(and (pat:literal? a) (pat:literal? b))
;; literals are hard to compare, so compare gensyms attached to
;; literal ids (see rep.rkt) instead
(let ([ka (syntax-property (pat:literal-id a) 'literal)]
[kb (syntax-property (pat:literal-id b) 'literal)])
(and ka kb (eq? ka kb)))]
[(and (pat:datum? a) (pat:datum? b))
(equal? (pat:datum-datum a)
(pat:datum-datum b))]
[(and (pat:head? a) (pat:head? b))
(and (pattern-equal? (pat:head-head a) (pat:head-head b))
(pattern-equal? (pat:head-tail a) (pat:head-tail b)))]
[(and (pat:dots? a) (pat:dots? b))
(and (subpatterns-equal? (pat:dots-heads a) (pat:dots-heads b))
(pattern-equal? (pat:dots-tail a) (pat:dots-tail b)))]
[(and (pat:and? a) (pat:and? b))
(subpatterns-equal? (pat:and-patterns a) (pat:and-patterns b))]
[(and (pat:or? a) (pat:or? b))
(subpatterns-equal? (pat:or-patterns a) (pat:or-patterns b))]
[(and (pat:not? a) (pat:not? b))
(pattern-equal? (pat:not-pattern a) (pat:not-pattern b))]
[(and (pat:pair? a) (pat:pair? b))
(and (pattern-equal? (pat:pair-head a) (pat:pair-head b))
(pattern-equal? (pat:pair-tail a) (pat:pair-tail b)))]
[(and (pat:vector? a) (pat:vector? b))
(pattern-equal? (pat:vector-pattern a) (pat:vector-pattern b))]
[(and (pat:box? a) (pat:box? b))
(pattern-equal? (pat:box-pattern a) (pat:box-pattern b))]
[(and (pat:pstruct? a) (pat:pstruct? b))
(and (equal? (pat:pstruct-key a)
(pat:pstruct-key b))
(pattern-equal? (pat:pstruct-pattern a)
(pat:pstruct-pattern b)))]
[(and (pat:describe? a) (pat:describe? b)) #f] ;; can't compare desc exprs
[(and (pat:delimit? a) (pat:delimit? b))
(pattern-equal? (pat:delimit-pattern a) (pat:delimit-pattern b))]
[(and (pat:commit? a) (pat:commit? b))
(pattern-equal? (pat:commit-pattern a) (pat:commit-pattern b))]
[(and (pat:reflect? a) (pat:reflect? b)) #f] ;; FIXME: ?
[(and (pat:ord? a) (pat:ord? b))
(and (pattern-equal? (pat:ord-pattern a) (pat:ord-pattern b))
(equal? (pat:ord-group a) (pat:ord-group b))
(equal? (pat:ord-index a) (pat:ord-index b)))]
[(and (pat:post? a) (pat:post? b))
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
[(and (pat:seq-end? a) (pat:seq-end? b)) #t]
;; ---
[(and (hpat:single? a) (hpat:single? b))
(pattern-equal? (hpat:single-pattern a) (hpat:single-pattern b))]
[(and (hpat:var/p? a) (hpat:var/p? b))
(and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
(bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
(equal-iattrs? (hpat:var/p-nested-attrs a) (hpat:var/p-nested-attrs b))
(equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
(expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
[(and (hpat:seq? a) (hpat:seq? b))
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
;; ---
[(and (ehpat? a) (ehpat? b))
(and (equal? (ehpat-repc a) #f)
(equal? (ehpat-repc b) #f)
(pattern-equal? (ehpat-head a) (ehpat-head b)))]
;; FIXME: more?
[else #f]))
(when (and (log-level? syntax-parse-logger 'debug)
(eq? result #f)
(equal? (syntax->datum #`#,a) (syntax->datum #`#,b)))
(log-syntax-parse-debug "** pattern-equal? failed on ~e" a))
result)
(define (equal-iattrs? as bs)
(and (= (length as) (length bs))
;; assumes attrs in same order
(for/and ([aa (in-list as)]
[ba (in-list bs)])
(and (bound-identifier=? (attr-name aa) (attr-name ba))
(equal? (attr-depth aa) (attr-depth ba))
(equal? (attr-syntax? aa) (attr-syntax? ba))))))
(define (expr-equal? a b)
;; Expression equality is undecidable in general. Especially difficult for unexpanded
;; code, but it would be very difficult to set up correct env for local-expand because of
;; attr binding rules. So, do *very* conservative approx: simple variables and literals.
;; FIXME: any other common cases?
(cond [(not (and (syntax? a) (syntax? b)))
(equal? a b)]
[(and (identifier? a) (identifier? b))
;; note: "vars" might be identifier macros (unsafe to consider equal),
;; so check var has no compile-time binding
(and (free-identifier=? a b)
(let/ec k (syntax-local-value a (lambda () (k #t))) #f))]
[(syntax-case (list a b) (quote)
[((quote ad) (quote bd))
(cons (syntax->datum #'ad) (syntax->datum #'bd))]
[_ #f])
=> (lambda (ad+bd)
(equal? (car ad+bd) (cdr ad+bd)))]
[else
;; approx: equal? only if both simple data (bool, string, etc), no inner stx
(let ([ad (syntax-e a)]
[bd (syntax-e b)])
(and (equal? ad bd)
(free-identifier=? (datum->syntax a '#%datum) #'#%datum)
(free-identifier=? (datum->syntax b '#%datum) #'#%datum)))]))
(define (equal-argu? a b)
(define (unwrap-arguments x)
(match x
[(arguments pargs kws kwargs)
(values pargs kws kwargs)]))
(define (list-equal? as bs inner-equal?)
(and (= (length as) (length bs))
(andmap inner-equal? as bs)))
(let-values ([(apargs akws akwargs) (unwrap-arguments a)]
[(bpargs bkws bkwargs) (unwrap-arguments b)])
(and (list-equal? apargs bpargs expr-equal?)
(equal? akws bkws)
(list-equal? akwargs bkwargs expr-equal?))))
(define (free-id/f-equal? a b)
(or (and (eq? a #f)
(eq? b #f))
(and (identifier? a)
(identifier? b)
(free-identifier=? a b))))
(define (bound-id/f-equal? a b)
(or (and (eq? a #f)
(eq? b #f))
(and (identifier? a)
(identifier? b)
(bound-identifier=? a b))))
(define (make-and-pattern subs)
(cond [(null? subs) (pat:any)] ;; shouldn't happen
[(null? (cdr subs)) (car subs)]
[else (pat:and subs)]))
(define (*append a b) (if (null? b) a (append a b)))
(define (stx-e x) (if (syntax? x) (syntax-e x) x))
;; ----
(define (matrix->sexpr rows)
(cond [(null? rows) ;; shouldn't happen
'(FAIL)]
[(null? (cdr rows))
(pk->sexpr (car rows))]
[else
(cons 'TRY (map pk->sexpr rows))]))
(define (pk->sexpr pk)
(match pk
[(pk1 pats k)
(cons 'MATCH (map pattern->sexpr pats))]
[(pk/same pat inner)
(list 'SAME (pattern->sexpr pat) (matrix->sexpr inner))]
[(pk/pair inner)
(list 'PAIR (matrix->sexpr inner))]
[(pk/and inner)
(list 'AND (matrix->sexpr inner))]))
(define (pattern->sexpr p)
(match p
[(pat:any) '_]
[(pat:integrated name pred desc _)
(format-symbol "~a:~a" (or name '_) desc)]
[(pat:svar name)
(syntax-e name)]
[(pat:var/p name parser _ _ _ _)
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
=> (lambda (m)
(format-symbol "~a:~a" (or name '_) (cadr m)))]
[else
(if name (syntax-e name) '_)])]
[(? pat:literal?) `(syntax ,(syntax->datum (pat:literal-id p)))]
[(pat:datum datum)
(cond [(or (symbol? datum) (pair? datum))
`(quote ,datum)]
[else datum])]
[(pat:action action (pat:any)) (pattern->sexpr action)]
[(pat:action action inner) (list '~AAND (pattern->sexpr action) (pattern->sexpr inner))]
[(pat:and patterns) (cons '~and (map pattern->sexpr patterns))]
[(pat:or _ patterns _) (cons '~or (map pattern->sexpr patterns))]
[(pat:not pattern) (list '~not (pattern->sexpr pattern))]
[(pat:pair head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:head head tail)
(cons (pattern->sexpr head) (pattern->sexpr tail))]
[(pat:dots (list eh) tail)
(list* (pattern->sexpr eh) '... (pattern->sexpr tail))]
[(pat:dots ehs tail)
(list* (cons '~alt (map pattern->sexpr ehs)) '... (pattern->sexpr tail))]
[(pat:describe sp _ _ _) (list '~describe (pattern->sexpr sp))]
[(pat:delimit sp) (list '~delimit-cut (pattern->sexpr sp))]
[(pat:commit sp) (list '~commit (pattern->sexpr sp))]
[(pat:ord pattern _ _) (list '~ord (pattern->sexpr pattern))]
[(pat:post sp) (list '~post (pattern->sexpr sp))]
[(pat:seq-end) '()]
[(action:cut) '~!]
[(action:fail cnd msg) (list '~fail)]
[(action:bind attr expr) (list '~bind)]
[(action:and as) (cons '~and (map pattern->sexpr as))]
[(action:parse sp expr) (list '~parse (pattern->sexpr sp))]
[(action:do stmts) (list '~do)]
[(action:undo stmts) (list '~undo)]
[(action:ord ap _ _) (list '~ord (pattern->sexpr ap))]
[(action:post ap) (list '~post (pattern->sexpr ap))]
[(hpat:single sp) (pattern->sexpr sp)]
[(hpat:var/p name parser _ _ _ _)
(cond [(and parser (regexp-match #rx"^parser-(.*)$" (symbol->string (syntax-e parser))))
=> (lambda (m) (format-symbol "~a:~a" (or name '_) (cadr m)))]
[else (if name (syntax-e name) '_)])]
[(hpat:seq lp) (cons '~seq (pattern->sexpr lp))]
[(hpat:action ap hp) (list '~AAND (pattern->sexpr ap) (pattern->sexpr hp))]
[(hpat:and hp sp) (list '~and (pattern->sexpr hp) (pattern->sexpr sp))]
[(hpat:or _ hps _) (cons '~or (map pattern->sexpr hps))]
[(hpat:describe hp _ _ _) (list '~describe (pattern->sexpr hp))]
[(hpat:delimit hp) (list '~delimit-cut (pattern->sexpr hp))]
[(hpat:commit hp) (list '~commit (pattern->sexpr hp))]
[(hpat:ord hp _ _) (list '~ord (pattern->sexpr hp))]
[(hpat:post hp) (list '~post (pattern->sexpr hp))]
[(hpat:peek hp) (list '~peek (pattern->sexpr hp))]
[(hpat:peek-not hp) (list '~peek-not (pattern->sexpr hp))]
[(ehpat _as hpat repc _cn)
(if (eq? repc #f) (pattern->sexpr hpat) (list '~REPC (pattern->sexpr hpat)))]
[_ '<Pattern>]))

1206
7-4/racket/collects/syntax/parse/private/parse.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

1965
7-4/racket/collects/syntax/parse/private/rep.rkt Normal file
View File

File diff suppressed because it is too large Load Diff

302
7-4/racket/collects/syntax/parse/private/residual.rkt Normal file
View File

@ -0,0 +1,302 @@
#lang racket/base
(require (for-syntax racket/base)
racket/stxparam
racket/lazy-require
racket/private/promise)
;; ============================================================
;; Compile-time
(require (for-syntax racket/private/sc syntax/parse/private/residual-ct))
(provide (for-syntax (all-from-out syntax/parse/private/residual-ct)))
(require "../../case/template.rkt")
(provide (for-syntax attribute-mapping attribute-mapping?))
;; ============================================================
;; Run-time
(require "runtime-progress.rkt"
"3d-stx.rkt"
auto-syntax-e
syntax/stx
stxparse-info/current-pvars)
(provide (all-from-out "runtime-progress.rkt")
this-syntax
this-role
this-context-syntax
attribute
attribute-binding
check-attr-value
stx-list-take
stx-list-drop/cx
datum->syntax/with-clause
check-literal*
error/null-eh-match
begin-for-syntax/once
name->too-few/once
name->too-few
name->too-many
normalize-context
syntax-patterns-fail)
;; == from runtime.rkt
;; this-syntax
;; Bound to syntax being matched inside of syntax class
(define-syntax-parameter this-syntax
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
(define-syntax-parameter this-role
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
;; this-context-syntax
;; Bound to (expression that extracts) context syntax (bottom frame in progress)
(define-syntax-parameter this-context-syntax
(lambda (stx)
(raise-syntax-error #f "used out of context: not within a syntax class" stx)))
(define-syntax (attribute stx)
(syntax-case stx ()
[(attribute name)
(identifier? #'name)
(let ([mapping (syntax-local-value #'name (lambda () #f))])
(unless (syntax-pattern-variable? mapping)
(raise-syntax-error #f "not bound as a pattern variable" stx #'name))
(let ([var (syntax-mapping-valvar mapping)])
(let ([attr (syntax-local-value var (lambda () #f))])
(unless (attribute-mapping? attr)
(raise-syntax-error #f "not bound as an attribute" stx #'name))
(syntax-property (attribute-mapping-var attr)
'disappeared-use
(list (syntax-local-introduce #'name))))))]))
;; (attribute-binding id)
;; mostly for debugging/testing
(define-syntax (attribute-binding stx)
(syntax-case stx ()
[(attribute-bound? name)
(identifier? #'name)
(let ([value (syntax-local-value #'name (lambda () #f))])
(if (syntax-pattern-variable? value)
(let ([value (syntax-local-value (syntax-mapping-valvar value) (lambda () #f))])
(if (attribute-mapping? value)
#`(quote #,(make-attr (attribute-mapping-name value)
(attribute-mapping-depth value)
(if (attribute-mapping-check value) #f #t)))
#'(quote #f)))
#'(quote #f)))]))
;; stx-list-take : stxish nat -> syntax
(define (stx-list-take stx n)
(datum->syntax #f
(let loop ([stx stx] [n n])
(if (zero? n)
null
(cons (stx-car stx)
(loop (stx-cdr stx) (sub1 n)))))))
;; stx-list-drop/cx : stxish stx nat -> (values stxish stx)
(define (stx-list-drop/cx x cx n)
(let loop ([x x] [cx cx] [n n])
(if (zero? n)
(values x
(if (syntax? x) x cx))
(loop (stx-cdr x)
(if (syntax? x) x cx)
(sub1 n)))))
;; check-attr-value : Any d:Nat b:Boolean Syntax/#f -> (Listof^d (if b Syntax Any))
(define (check-attr-value v0 depth0 base? ctx)
(define (bad kind v)
(raise-syntax-error #f (format "attribute contains non-~s value\n value: ~e" kind v) ctx))
(define (depthloop depth v)
(if (zero? depth)
(if base? (baseloop v) v)
(let listloop ([v v] [root? #t])
(cond [(null? v) null]
[(pair? v) (let ([new-car (depthloop (sub1 depth) (car v))]
[new-cdr (listloop (cdr v) #f)])
(cond [(and (eq? (car v) new-car) (eq? (cdr v) new-cdr)) v]
[else (cons new-car new-cdr)]))]
[(promise? v) (listloop (force v) root?)]
[(and root? (eq? v #f)) (begin (signal-absent-pvar) (bad 'list v))]
[else (bad 'list v)]))))
(define (baseloop v)
(cond [(syntax? v) v]
[(promise? v) (baseloop (force v))]
[(eq? v #f) (begin (signal-absent-pvar) (bad 'syntax v))]
[else (bad 'syntax v)]))
(depthloop depth0 v0))
;; datum->syntax/with-clause : any -> syntax
(define (datum->syntax/with-clause x)
(cond [(syntax? x) x]
[(2d-stx? x #:traverse-syntax? #f)
(datum->syntax #f x #f)]
[else
(error 'datum->syntax/with-clause
(string-append
"implicit conversion to 3D syntax\n"
" right-hand side of #:with clause or ~~parse pattern would be 3D syntax\n"
" value: ~e")
x)]))
;; check-literal* : id phase phase (listof phase) stx -> void
(define (check-literal* id used-phase mod-phase ok-phases/ct-rel ctx)
(unless (or (memv (and used-phase (- used-phase mod-phase))
ok-phases/ct-rel)
(identifier-binding id used-phase))
(raise-syntax-error
#f
(format "literal is unbound in phase ~a (phase ~a relative to the enclosing module)"
used-phase
(and used-phase (- used-phase mod-phase)))
ctx id)))
;; error/null-eh-match : -> (escapes)
(define (error/null-eh-match)
(error 'syntax-parse "an ellipsis-head pattern matched an empty sequence"))
;; (begin-for-syntax/once expr/phase1 ...)
;; evaluates in pass 2 of module/intdefs expansion
(define-syntax (begin-for-syntax/once stx)
(syntax-case stx ()
[(bfs/o e ...)
(cond [(list? (syntax-local-context))
#`(define-values ()
(begin (begin-for-syntax/once e ...)
(values)))]
[else
#'(let-syntax ([m (lambda _ (begin e ...) #'(void))])
(m))])]))
;; == parse.rkt
(define (name->too-few/once name)
(and name (format "missing required occurrence of ~a" name)))
(define (name->too-few name)
(and name (format "too few occurrences of ~a" name)))
(define (name->too-many name)
(and name (format "too many occurrences of ~a" name)))
;; == parse.rkt
;; normalize-context : Symbol Any Syntax -> (list Symbol/#f Syntax)
(define (normalize-context who ctx stx)
(cond [(syntax? ctx)
(list #f ctx)]
[(symbol? ctx)
(list ctx stx)]
[(eq? ctx #f)
(list #f stx)]
[(and (list? ctx)
(= (length ctx) 2)
(or (symbol? (car ctx)) (eq? #f (car ctx)))
(syntax? (cadr ctx)))
ctx]
[else (error who "bad #:context argument\n expected: ~s\n given: ~e"
'(or/c syntax? symbol? #f (list/c (or/c symbol? #f) syntax?))
ctx)]))
;; == parse.rkt
(lazy-require
["runtime-report.rkt"
(call-current-failure-handler)])
;; syntax-patterns-fail : (list Symbol/#f Syntax) -> (Listof (-> Any)) FailureSet -> escapes
(define ((syntax-patterns-fail ctx) undos fs)
(unwind-to undos null)
(call-current-failure-handler ctx fs))
;; == specialized ellipsis parser
;; returns (values 'ok attr-values) or (values 'fail failure)
(provide predicate-ellipsis-parser)
(define (predicate-ellipsis-parser x cx pr es pred? desc rl)
(let ([elems (stx->list x)])
(if (and elems (list? elems) (andmap pred? elems))
(values 'ok elems)
(let loop ([x x] [cx cx] [i 0])
(cond [(syntax? x)
(loop (syntax-e x) x i)]
[(pair? x)
(if (pred? (car x))
(loop (cdr x) cx (add1 i))
(let* ([pr (ps-add-cdr pr i)]
[pr (ps-add-car pr)]
[es (es-add-thing pr desc #t rl es)])
(values 'fail (failure pr es))))]
[else ;; not null, because stx->list failed
(let ([pr (ps-add-cdr pr i)]
#|
;; Don't extend es! That way we don't get spurious "expected ()"
;; that *should* have been cancelled out by ineffable pair failures.
|#)
(values 'fail (failure* pr es)))])))))
(provide illegal-cut-error)
(define (illegal-cut-error . _)
(error 'syntax-parse "illegal use of cut"))
;; ----
(provide unwind-to
maybe-add-state-undo
current-state
current-state-writable?
state-cons!
track-literals)
(define (unwind-to undos base)
;; PRE: undos = (list* proc/hash ... base)
(unless (eq? undos base)
(let ([top-undo (car undos)])
(cond [(procedure? top-undo) (top-undo)]
[(hash? top-undo) (current-state top-undo)]))
(unwind-to (cdr undos) base)))
(define (maybe-add-state-undo init-state new-state undos)
(if (eq? init-state new-state)
undos
(cons init-state undos)))
;; To make adding undos to rewind current-state simpler, only allow updates
;; in a few contexts:
;; - literals (handled automatically)
;; - in ~do/#:do blocks (sets current-state-writable? = #t)
(define current-state (make-parameter (hasheq)))
(define current-state-writable? (make-parameter #f))
(define (state-cons! key value)
(define state (current-state))
(current-state (hash-set state key (cons value (hash-ref state key null)))))
(define (track-literals who v #:introduce? [introduce? #t])
(unless (syntax? v)
(raise-argument-error who "syntax?" v))
(let* ([literals (hash-ref (current-state) 'literals '())])
(if (null? literals)
v
(let ([literals* (if (and introduce? (syntax-transforming?) (list? literals))
(for/list ([literal (in-list literals)])
(if (identifier? literal)
(syntax-local-introduce literal)
literal))
literals)]
[old-val (syntax-property v 'disappeared-use)])
(syntax-property v 'disappeared-use
(if old-val
(cons literals* old-val)
literals*))))))

258
7-4/racket/collects/syntax/parse/private/runtime-progress.rkt Normal file
View File

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

96
7-4/racket/collects/syntax/parse/private/runtime-reflect.rkt Normal file
View File

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

816
7-4/racket/collects/syntax/parse/private/runtime-report.rkt Normal file
View File

@ -0,0 +1,816 @@
#lang racket/base
(require racket/list
racket/format
syntax/stx
racket/struct
syntax/srcloc
syntax/parse/private/minimatch
stxparse-info/parse/private/residual
syntax/parse/private/kws)
(provide call-current-failure-handler
current-failure-handler
invert-failure
maximal-failures
invert-ps
ps->stx+index)
#|
TODO: given (expect:thing _ D _ R) and (expect:thing _ D _ #f),
simplify to (expect:thing _ D _ #f)
thus, "expected D" rather than "expected D or D for R" (?)
|#
#|
Note: there is a cyclic dependence between residual.rkt and this module,
broken by a lazy-require of this module into residual.rkt
|#
(define (call-current-failure-handler ctx fs)
(call-with-values (lambda () ((current-failure-handler) ctx fs))
(lambda vals
(error 'current-failure-handler
"current-failure-handler: did not escape, produced ~e"
(case (length vals)
((1) (car vals))
(else (cons 'values vals)))))))
(define (default-failure-handler ctx fs)
(handle-failureset ctx fs))
(define current-failure-handler
(make-parameter default-failure-handler))
;; ============================================================
;; Processing failure sets
#|
We use progress to select the maximal failures and determine the syntax
they're complaining about. After that, we no longer care about progress.
Old versions of syntax-parse (through 6.4) grouped failures into
progress-equivalence-classes and generated reports by class, but only showed
one report. New syntax-parse just mixes all maximal failures together and
deals with the fact that they might not be talking about the same terms.
|#
;; handle-failureset : (list Symbol/#f Syntax) FailureSet -> escapes
(define (handle-failureset ctx fs)
(define inverted-fs (map invert-failure (reverse (flatten fs))))
(define maximal-classes (maximal-failures inverted-fs))
(define ess (map failure-expectstack (append* maximal-classes)))
(define report (report/sync-shared ess))
;; Hack: alternative to new (primitive) phase-crossing exn type is to store
;; extra information in exn continuation marks. Currently for debugging only.
(with-continuation-mark 'syntax-parse-error
(hasheq 'raw-failures fs
'maximal maximal-classes)
(error/report ctx report)))
;; An RFailure is (failure IPS RExpectList)
;; invert-failure : Failure -> RFailure
(define (invert-failure f)
(match f
[(failure ps es)
(failure (invert-ps ps) (invert-expectstack es (ps->stx+index ps)))]))
;; A Report is (report String (Listof String) Syntax/#f Syntax/#f)
(define-struct report (message context stx within-stx) #:prefab)
;; Sometimes the point where an error occurred does not correspond to
;; a syntax object within the original term being matched. We use one
;; or two syntax objects to identify where an error occurred:
;; - the "at" term is the specific point of error, coerced to a syntax
;; object if it isn't already
;; - the "within" term is the closest enclosing original syntax object,
;; dropped (#f) if same as "at" term
;; Examples (AT is pre-coercion):
;; TERM PATTERN => AT WITHIN
;; #'(1) (a:id) #'1 -- ;; the happy case
;; #'(1) (a b) () #'(1) ;; tail of syntax list, too short
;; #'(1 . ()) (a b) #'() -- ;; tail is already syntax
;; #'#(1) #(a b) () #'#(1) ;; "tail" of syntax vector
;; #'#s(X 1) #s(X a b) () #'#s(X 1) ;; "tail" of syntax prefab
;; #'(1 2) (a) (#'2) #'(1 2) ;; tail of syntax list, too long
;; ============================================================
;; Progress
;; maximal-failures : (listof InvFailure) -> (listof (listof InvFailure))
(define (maximal-failures fs)
(maximal/progress
(for/list ([f (in-list fs)])
(cons (failure-progress f) f))))
#|
Progress ordering
-----------------
Nearly a lexicographic generalization of partial order on frames.
(( CAR < CDR ) || stx ) < POST )
- stx incomparable except with self
But ORD prefixes are sorted out (and discarded) before comparison with
rest of progress. Like post, ord comparable only w/in same group:
- (ord g n1) < (ord g n2) if n1 < n2
- (ord g1 n1) || (ord g2 n2) when g1 != g2
Progress equality
-----------------
If ps1 = ps2 then both must "blame" the same term,
ie (ps->stx+index ps1) = (ps->stx+index ps2).
|#
;; An Inverted PS (IPS) is a PS inverted for easy comparison.
;; An IPS may not contain any 'opaque frames.
;; invert-ps : PS -> IPS
;; Reverse and truncate at earliest 'opaque frame.
(define (invert-ps ps)
(reverse (ps-truncate-opaque ps)))
;; ps-truncate-opaque : PS -> PS
;; Returns maximal tail with no 'opaque frame.
(define (ps-truncate-opaque ps)
(let loop ([ps ps] [acc ps])
;; acc is the biggest tail that has not been seen to contain 'opaque
(cond [(null? ps) acc]
[(eq? (car ps) 'opaque)
(loop (cdr ps) (cdr ps))]
[else (loop (cdr ps) acc)])))
;; maximal/progress : (listof (cons IPS A)) -> (listof (listof A))
;; Eliminates As with non-maximal progress, then groups As into
;; equivalence classes according to progress.
(define (maximal/progress items)
(cond [(null? items)
null]
[(null? (cdr items))
(list (list (cdr (car items))))]
[else
(let loop ([items items] [non-ORD-items null])
(define-values (ORD non-ORD)
(partition (lambda (item) (ord? (item-first-prf item))) items))
(cond [(pair? ORD)
(loop (maximal-prf1/ord ORD) (append non-ORD non-ORD-items))]
[else
(maximal/prf1 (append non-ORD non-ORD-items))]))]))
;; maximal/prf1 : (Listof (Cons IPS A) -> (Listof (Listof A))
(define (maximal/prf1 items)
(define-values (POST rest1)
(partition (lambda (item) (eq? 'post (item-first-prf item))) items))
(cond [(pair? POST)
(maximal/progress (map item-pop-prf POST))]
[else
(define-values (STX rest2)
(partition (lambda (item) (syntax? (item-first-prf item))) rest1))
(define-values (CDR rest3)
(partition (lambda (item) (exact-integer? (item-first-prf item))) rest2))
(define-values (CAR rest4)
(partition (lambda (item) (eq? 'car (item-first-prf item))) rest3))
(define-values (NULL rest5)
(partition (lambda (item) (eq? '#f (item-first-prf item))) rest4))
(unless (null? rest5)
(error 'syntax-parse "INTERNAL ERROR: bad progress: ~e\n" rest5))
(cond [(pair? CDR)
(define leastCDR (apply min (map item-first-prf CDR)))
(append
(maximal/stx STX)
(maximal/progress (map (lambda (item) (item-pop-prf-ncdrs item leastCDR)) CDR)))]
[(pair? CAR)
(append
(maximal/stx STX)
(maximal/progress (map item-pop-prf CAR)))]
[(pair? STX)
(maximal/stx STX)]
[(pair? NULL)
(list (map cdr NULL))]
[else null])]))
;; maximal-prf1/ord : (NEListof (Cons IPS A)) -> (NEListof (Cons IPS A))
;; PRE: each item has ORD first frame
;; Keep only maximal by first frame and pop first frame from each item.
(define (maximal-prf1/ord items)
;; groups : (NEListof (NEListof (cons A IPS)))
(define groups (group-by (lambda (item) (ord-group (item-first-prf item))) items))
(append*
(for/list ([group (in-list groups)])
(define group* (filter-max group (lambda (item) (ord-index (item-first-prf item)))))
(map item-pop-prf group*))))
;; maximal/stx : (NEListof (cons IPS A)) -> (NEListof (NEListof A))
;; PRE: Each IPS starts with a stx frame.
(define (maximal/stx items)
;; groups : (Listof (Listof (cons IPS A)))
(define groups (group-by item-first-prf items))
(append*
(for/list ([group (in-list groups)])
(maximal/progress (map item-pop-prf group)))))
;; filter-max : (Listof X) (X -> Nat) -> (Listof X)
(define (filter-max xs x->nat)
(let loop ([xs xs] [nmax -inf.0] [r-keep null])
(cond [(null? xs)
(reverse r-keep)]
[else
(define n0 (x->nat (car xs)))
(cond [(> n0 nmax)
(loop (cdr xs) n0 (list (car xs)))]
[(= n0 nmax)
(loop (cdr xs) nmax (cons (car xs) r-keep))]
[else
(loop (cdr xs) nmax r-keep)])])))
;; item-first-prf : (cons IPS A) -> prframe/#f
(define (item-first-prf item)
(define ips (car item))
(and (pair? ips) (car ips)))
;; item-split-ord : (cons IPS A) -> (cons IPS (cons IPS A))
(define (item-split-ord item)
(define ips (car item))
(define a (cdr item))
(define-values (rest-ips r-ord)
(let loop ([ips ips] [r-ord null])
(cond [(and (pair? ips) (ord? (car ips)))
(loop (cdr ips) (cons (car ips) r-ord))]
[else (values ips r-ord)])))
(list* (reverse r-ord) rest-ips a))
;; item-pop-prf : (cons IPS A) -> (cons IPS A)
(define (item-pop-prf item)
(let ([ips (car item)]
[a (cdr item)])
(cons (cdr ips) a)))
;; item-pop-prf-ncdrs : (cons IPS A) -> (cons IPS A)
;; Assumes first frame is nat > ncdrs.
(define (item-pop-prf-ncdrs item ncdrs)
(let ([ips (car item)]
[a (cdr item)])
(cond [(= (car ips) ncdrs) (cons (cdr ips) a)]
[else (cons (cons (- (car ips) ncdrs) (cdr ips)) a)])))
;; StxIdx = (cons Syntax Nat), the "within" term and offset (#cdrs) of "at" subterm
;; ps->stx+index : Progress -> StxIdx
;; Gets the innermost stx that should have a real srcloc, and the offset
;; (number of cdrs) within that where the progress ends.
(define (ps->stx+index ps)
(define (interp ps top?)
;; if top?: first frame is 'car, must return Syntax, don't unwrap vector/struct
(match ps
[(cons (? syntax? stx) _) stx]
[(cons 'car parent)
(let* ([x (interp parent #f)]
[d (if (syntax? x) (syntax-e x) x)])
(cond [(pair? d) (car d)]
[(vector? d)
(if top? x (vector->list d))]
[(box? d) (unbox d)]
[(prefab-struct-key d)
(if top? x (struct->list d))]
[else (error 'ps->stx+index "INTERNAL ERROR: unexpected: ~e" d)]))]
[(cons (? exact-positive-integer? n) parent)
(for/fold ([stx (interp parent #f)]) ([i (in-range n)])
(stx-cdr stx))]
[(cons (? ord?) parent)
(interp parent top?)]
[(cons 'post parent)
(interp parent top?)]))
(let loop ([ps (ps-truncate-opaque ps)])
(match ps
[(cons (? syntax? stx) _)
(cons stx 0)]
[(cons 'car _)
(cons (interp ps #t) 0)]
[(cons (? exact-positive-integer? n) parent)
(match (loop parent)
[(cons stx m) (cons stx (+ m n))])]
[(cons (? ord?) parent)
(loop parent)]
[(cons 'post parent)
(loop parent)])))
;; stx+index->at+within : StxIdx -> (values Syntax Syntax/#f)
(define (stx+index->at+within stx+index)
(define within-stx (car stx+index))
(define index (cdr stx+index))
(cond [(zero? index)
(values within-stx #f)]
[else
(define d (syntax-e within-stx))
(define stx*
(cond [(vector? d) (vector->list d)]
[(prefab-struct-key d) (struct->list d)]
[else within-stx]))
(define at-stx*
(for/fold ([x stx*]) ([_i (in-range index)]) (stx-cdr x)))
(values (datum->syntax within-stx at-stx* within-stx)
within-stx)]))
;; ============================================================
;; Expectation simplification
;; normalize-expectstack : ExpectStack StxIdx -> ExpectList
;; Converts to list, converts expect:thing term rep, and truncates
;; expectstack after opaque (ie, transparent=#f) frames.
(define (normalize-expectstack es stx+index [truncate-opaque? #t])
(reverse (invert-expectstack es stx+index truncate-opaque?)))
;; invert-expectstack : ExpectStack StxIdx -> RExpectList
;; Converts to reversed list, converts expect:thing term rep,
;; and truncates expectstack after opaque (ie, transparent=#f) frames.
(define (invert-expectstack es stx+index [truncate-opaque? #t])
(let loop ([es es] [acc null])
(match es
['#f acc]
['#t acc]
[(expect:thing ps desc tr? role rest-es)
(let* (;; discard frames so far if opaque
[acc (if (and truncate-opaque? (not tr?)) null acc)]
;; discard this frame if desc is #f
[acc (if desc (cons (expect:thing #f desc tr? role (ps->stx+index ps)) acc) acc)])
(loop rest-es acc))]
[(expect:message message rest-es)
(loop rest-es (cons (expect:message message stx+index) acc))]
[(expect:atom atom rest-es)
(loop rest-es (cons (expect:atom atom stx+index) acc))]
[(expect:literal literal rest-es)
(loop rest-es (cons (expect:literal literal stx+index) acc))]
[(expect:proper-pair first-desc rest-es)
(loop rest-es (cons (expect:proper-pair first-desc stx+index) acc))])))
;; expect->stxidx : Expect -> StxIdx
(define (expect->stxidx e)
(cond [(expect:thing? e) (expect:thing-next e)]
[(expect:message? e) (expect:message-next e)]
[(expect:atom? e) (expect:atom-next e)]
[(expect:literal? e) (expect:literal-next e)]
[(expect:proper-pair? e) (expect:proper-pair-next e)]
[(expect:disj? e) (expect:disj-next e)]))
#| Simplification
A list of ExpectLists represents a tree, with shared tails meaning shared
branches of the tree. We need a "reasonable" way to simplify it to a list to
show to the user. Here we develop "reasonable" by example. (It would be nice,
of course, to also have some way of exploring the full failure trees.)
Notation: [A B X] means an ExpectList with class/description A at root and X
at leaf. If the term sequences differ, write [t1:A ...] etc.
Options:
(o) = "old behavior (through 6.4)"
(f) = "first divergence"
(s) = "sync on shared"
Case 1: [A B X], [A B Y]
This is nearly the ideal situation: report as
expected X or Y, while parsing B, while parsing A
Case 2: [A X], [A]
For example, matching #'1 as (~describe A (x:id ...)) yields [A], [A '()],
but we don't want to see "expected ()".
So simplify to [A]---that is, drop X.
But there are other cases that are more problematic.
Case 3: [t1:A t2:B t3:X], [t1:A t2:C t3:Y]
Could report as:
(o) expected X for t3, while parsing t2 as B, while parsing t1 as A (also other errors)
(f) expected B or C for t2, while parsing t1 as A
(x) expected X or Y for t3, while parsing t2 as B or C, while parsing t1 as A
(o) is not good
(b) loses the most specific error information
(x) implies spurious contexts (eg, X while parsing C)
I like (b) best for this situation, but ...
Case 4: [t1:A t2:B t4:X], [t1:A t3:C t4:Y]
Could report as:
(f') expected B or C, while parsing t1 as A
(s) expected X or Y for t4, while ..., while parsing t1 as A
(f) expected A for t1
(f') is problematic, since terms are different!
(s) okay, but nothing good to put in that ... space
(f) loses a lot of information
Case 5: [t1:A t2:B t3:X], [t1:A t4:C t5:Y]
Only feasible choice (no other sync points):
(f,s) expected A for t1
Case 6: [t1:A _ t2:B t3:X], [t1:A _ t2:C t3:Y]
Could report as:
(s') expected X or Y for t3, while parsing t2 as B or C, while ..., while parsing t1 as A
(s) expected X or Y for t3, while ..., while parsing t1 as A
(s') again implies spurious contexts, bad
(s) okay
Case 7: [_ t2:B t3:C _], [_ t3:C t2:B _]
Same frames show up in different orders. (Can this really happen? Probably,
with very weird uses of ~parse.)
--
This suggests the following new algorithm based on (s):
- Step 1: emit an intermediate "unified" expectstack (extended with "..." markers)
- make a list (in order) of frames shared by all expectstacks
- emit those frames with "..." markers if (sometimes) unshared stuff between
- continue processing with the tails after the last shared frame:
- find the last term shared by all expectstacks (if any)
- find the last frame for that term for each expectstack
- combine in expect:disj and emit
- Step 2:
- remove trailing and collapse adjacent "..." markers
|#
;; report* : (NEListof RExpectList) ((NEListof (NEListof RExpectList)) -> ExpectList)
;; -> Report
(define (report* ess handle-divergence)
(define es ;; ExpectList
(let loop ([ess ess] [acc null])
(cond [(ormap null? ess) acc]
[else
(define groups (group-by car ess))
(cond [(singleton? groups)
(define group (car groups))
(define frame (car (car group)))
(loop (map cdr group) (cons frame acc))]
[else ;; found point of divergence
(append (handle-divergence groups) acc)])])))
(define stx+index (if (pair? es) (expect->stxidx (car es)) (cons #f 0)))
(report/expectstack (clean-up es) stx+index))
;; clean-up : ExpectList -> ExpectList
;; Remove leading and collapse adjacent '... markers
(define (clean-up es)
(if (and (pair? es) (eq? (car es) '...))
(clean-up (cdr es))
(let loop ([es es])
(cond [(null? es) null]
[(eq? (car es) '...)
(cons '... (clean-up es))]
[else (cons (car es) (loop (cdr es)))]))))
;; --
;; report/first-divergence : (NEListof RExpectList) -> Report
;; Generate a single report, using frames from root to first divergence.
(define (report/first-divergence ess)
(report* ess handle-divergence/first))
;; handle-divergence/first : (NEListof (NEListof RExpectList)) -> ExpectList
(define (handle-divergence/first ess-groups)
(define representative-ess (map car ess-groups))
(define first-frames (map car representative-ess))
;; Do all of the first frames talk about the same term?
(cond [(all-equal? (map expect->stxidx first-frames))
(list (expect:disj first-frames #f))]
[else null]))
;; --
;; report/sync-shared : (NEListof RExpectList) -> Report
;; Generate a single report, syncing on shared frames (and later, terms).
(define (report/sync-shared ess)
(report* ess handle-divergence/sync-shared))
;; handle-divergence/sync-shared : (NEListof (NEListof RExpectList)) -> ExpectList
(define (handle-divergence/sync-shared ess-groups)
(define ess (append* ess-groups)) ;; (NEListof RExpectList)
(define shared-frames (get-shared ess values))
;; rsegs : (NEListof (Rev2n+1-Listof RExpectList))
(define rsegs (for/list ([es (in-list ess)]) (rsplit es values shared-frames)))
(define final-seg (map car rsegs)) ;; (NEListof RExpectList), no common frames
(define ctx-rsegs (transpose (map cdr rsegs))) ;; (Rev2n-Listof (NEListof RExpectList))
(append (hd/sync-shared/final final-seg)
(hd/sync-shared/ctx ctx-rsegs)))
;; hd/sync-shared/final : (NEListof RExpectList) -> ExpectList
;; PRE: ess has no shared frames, but may have shared terms.
(define (hd/sync-shared/final ess0)
(define ess (remove-extensions ess0))
(define shared-terms (get-shared ess expect->stxidx))
(cond [(null? shared-terms) null]
[else
;; split at the last shared term
(define rsegs ;; (NEListof (3-Listof RExpectList))
(for/list ([es (in-list ess)])
(rsplit es expect->stxidx (list (last shared-terms)))))
;; only care about the got segment and pre, not post
(define last-term-ess ;; (NEListof RExpectList)
(map cadr rsegs))
(define pre-term-ess ;; (NEListof RExpectList)
(map caddr rsegs))
;; last is most specific
(append
(list (expect:disj (remove-duplicates (reverse (map last last-term-ess)))
(last shared-terms)))
(if (ormap pair? pre-term-ess) '(...) '()))]))
;; hd/sync-shared/ctx : (Rev2n-Listof (NEListof RExpectList)) -> ExpectList
;; In [gotN preN ... got1 pre1] order, where 1 is root-most, N is leaf-most.
;; We want leaf-most-first, so just process naturally.
(define (hd/sync-shared/ctx rsegs)
(let loop ([rsegs rsegs])
(cond [(null? rsegs) null]
[(null? (cdr rsegs)) (error 'syntax-parse "INTERNAL ERROR: bad segments")]
[else (append
;; shared frame: possible for duplicate ctx frames, but unlikely
(let ([ess (car rsegs)]) (list (car (car ess))))
;; inter frames:
(let ([ess (cadr rsegs)]) (if (ormap pair? ess) '(...) '()))
;; recur
(loop (cddr rsegs)))])))
;; transpose : (Listof (Listof X)) -> (Listof (Listof X))
(define (transpose xss)
(cond [(ormap null? xss) null]
[else (cons (map car xss) (transpose (map cdr xss)))]))
;; get-shared : (Listof (Listof X)) (X -> Y) -> (Listof Y)
;; Return a list of Ys s.t. occur in order in (map of) each xs in xss.
(define (get-shared xss get-y)
(cond [(null? xss) null]
[else
(define yhs ;; (Listof (Hash Y => Nat))
(for/list ([xs (in-list xss)])
(for/hash ([x (in-list xs)] [i (in-naturals 1)])
(values (get-y x) i))))
(remove-duplicates
(let loop ([xs (car xss)] [last (for/list ([xs (in-list xss)]) 0)])
;; last is list of indexes of last accepted y; only accept next if occurs
;; after last in every sequence (see Case 7 above)
(cond [(null? xs) null]
[else
(define y (get-y (car xs)))
(define curr (for/list ([yh (in-list yhs)]) (hash-ref yh y -1)))
(cond [(andmap > curr last)
(cons y (loop (cdr xs) curr))]
[else (loop (cdr xs) last)])])))]))
;; rsplit : (Listof X) (X -> Y) (Listof Y) -> (Listof (Listof X))
;; Given [y1 ... yN], splits xs into [rest gotN preN ... got1 pre1].
;; Thus the result has 2N+1 elements. The sublists are in original order.
(define (rsplit xs get-y ys)
(define (loop xs ys segsacc)
(cond [(null? ys) (cons xs segsacc)]
[else (pre-loop xs ys segsacc null)]))
(define (pre-loop xs ys segsacc preacc)
(cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
(got-loop (cdr xs) ys segsacc preacc (list (car xs)))]
[else
(pre-loop (cdr xs) ys segsacc (cons (car xs) preacc))]))
(define (got-loop xs ys segsacc preacc gotacc)
(cond [(and (pair? xs) (equal? (get-y (car xs)) (car ys)))
(got-loop (cdr xs) ys segsacc preacc (cons (car xs) gotacc))]
[else
(loop xs (cdr ys) (list* (reverse gotacc) (reverse preacc) segsacc))]))
(loop xs ys null))
;; singleton? : list -> boolean
(define (singleton? x) (and (pair? x) (null? (cdr x))))
;; remove-extensions : (Listof (Listof X)) -> (Listof (Listof X))
;; Remove any element that is an extension of another.
(define (remove-extensions xss)
(cond [(null? xss) null]
[else
(let loop ([xss xss])
(cond [(singleton? xss) xss]
[(ormap null? xss) (list null)]
[else
(define groups (group-by car xss))
(append*
(for/list ([group (in-list groups)])
(define group* (loop (map cdr group)))
(map (lambda (x) (cons (caar group) x)) group*)))]))]))
;; all-equal? : (Listof Any) -> Boolean
(define (all-equal? xs) (for/and ([x (in-list xs)]) (equal? x (car xs))))
;; ============================================================
;; Reporting
;; report/expectstack : ExpectList StxIdx -> Report
(define (report/expectstack es stx+index)
(define frame-expect (and (pair? es) (car es)))
(define context-frames (if (pair? es) (cdr es) null))
(define context (append* (map context-prose-for-expect context-frames)))
(cond [(not frame-expect)
(report "bad syntax" context #f #f)]
[else
(define-values (frame-stx within-stx) (stx+index->at+within stx+index))
(cond [(and (match frame-expect [(expect:atom '() _) #t] [_ #f])
(stx-pair? frame-stx))
(report "unexpected term" context (stx-car frame-stx) #f)]
[(expect:disj? frame-expect)
(report (prose-for-expects (expect:disj-expects frame-expect))
context frame-stx within-stx)]
[else
(report (prose-for-expects (list frame-expect))
context frame-stx within-stx)])]))
;; prose-for-expects : (listof Expect) -> string
(define (prose-for-expects expects)
(define msgs (filter expect:message? expects))
(define things (filter expect:thing? expects))
(define literal (filter expect:literal? expects))
(define atom/symbol
(filter (lambda (e) (and (expect:atom? e) (symbol? (expect:atom-atom e)))) expects))
(define atom/nonsym
(filter (lambda (e) (and (expect:atom? e) (not (symbol? (expect:atom-atom e))))) expects))
(define proper-pairs (filter expect:proper-pair? expects))
(join-sep
(append (map prose-for-expect (append msgs things))
(prose-for-expects/literals literal "identifiers")
(prose-for-expects/literals atom/symbol "literal symbols")
(prose-for-expects/literals atom/nonsym "literals")
(prose-for-expects/pairs proper-pairs))
";" "or"))
(define (prose-for-expects/literals expects whats)
(cond [(null? expects) null]
[(singleton? expects) (map prose-for-expect expects)]
[else
(define (prose e)
(match e
[(expect:atom (? symbol? atom) _)
(format "`~s'" atom)]
[(expect:atom atom _)
(format "~s" atom)]
[(expect:literal literal _)
(format "`~s'" (syntax-e literal))]))
(list (string-append "expected one of these " whats ": "
(join-sep (map prose expects) "," "or")))]))
(define (prose-for-expects/pairs expects)
(if (pair? expects) (list (prose-for-proper-pair-expects expects)) null))
;; prose-for-expect : Expect -> string
(define (prose-for-expect e)
(match e
[(expect:thing _ description transparent? role _)
(if role
(format "expected ~a for ~a" description role)
(format "expected ~a" description))]
[(expect:atom (? symbol? atom) _)
(format "expected the literal symbol `~s'" atom)]
[(expect:atom atom _)
(format "expected the literal ~s" atom)]
[(expect:literal literal _)
(format "expected the identifier `~s'" (syntax-e literal))]
[(expect:message message _)
message]
[(expect:proper-pair '#f _)
"expected more terms"]))
;; prose-for-proper-pair-expects : (listof expect:proper-pair) -> string
(define (prose-for-proper-pair-expects es)
(define descs (remove-duplicates (map expect:proper-pair-first-desc es)))
(cond [(for/or ([desc descs]) (equal? desc #f))
;; FIXME: better way to indicate unknown ???
"expected more terms"]
[else
(format "expected more terms starting with ~a"
(join-sep (map prose-for-first-desc descs)
"," "or"))]))
;; prose-for-first-desc : FirstDesc -> string
(define (prose-for-first-desc desc)
(match desc
[(? string?) desc]
[(list 'any) "any term"] ;; FIXME: maybe should cancel out other descs ???
[(list 'literal id) (format "the identifier `~s'" id)]
[(list 'datum (? symbol? s)) (format "the literal symbol `~s'" s)]
[(list 'datum d) (format "the literal ~s" d)]))
;; context-prose-for-expect : (U '... expect:thing) -> (listof string)
(define (context-prose-for-expect e)
(match e
['...
(list "while parsing different things...")]
[(expect:thing '#f description transparent? role stx+index)
(let-values ([(stx _within-stx) (stx+index->at+within stx+index)])
(cons (~a "while parsing " description
(if role (~a " for " role) ""))
(if (error-print-source-location)
(list (~a " term: "
(~s (syntax->datum stx)
#:limit-marker "..."
#:max-width 50))
(~a " location: "
(or (source-location->string stx) "not available")))
null)))]))
;; ============================================================
;; Raise exception
(define (error/report ctx report)
(let* ([message (report-message report)]
[context (report-context report)]
[stx (cadr ctx)]
[who (or (car ctx) (infer-who stx))]
[sub-stx (report-stx report)]
[within-stx (report-within-stx report)]
[message
(format "~a: ~a~a~a~a~a"
who message
(format-if "at" (stx-if-loc sub-stx))
(format-if "within" (stx-if-loc within-stx))
(format-if "in" (stx-if-loc stx))
(if (null? context)
""
(apply string-append
"\n parsing context: "
(for/list ([c (in-list context)])
(format "\n ~a" c)))))]
[message
(if (error-print-source-location)
(let ([source-stx (or stx sub-stx within-stx)])
(string-append (source-location->prefix source-stx) message))
message)])
(raise
(exn:fail:syntax message (current-continuation-marks)
(map syntax-taint
(cond [within-stx (list within-stx)]
[sub-stx (list sub-stx)]
[stx (list stx)]
[else null]))))))
(define (format-if prefix val)
(if val
(format "\n ~a: ~a" prefix val)
""))
(define (stx-if-loc stx)
(and (syntax? stx)
(error-print-source-location)
(format "~.s" (syntax->datum stx))))
(define (infer-who stx)
(let* ([maybe-id (if (stx-pair? stx) (stx-car stx) stx)])
(if (identifier? maybe-id) (syntax-e maybe-id) '?)))
(define (comma-list items)
(join-sep items "," "or"))
(define (improper-stx->list stx)
(syntax-case stx ()
[(a . b) (cons #'a (improper-stx->list #'b))]
[() null]
[rest (list #'rest)]))
;; ============================================================
;; Debugging
(provide failureset->sexpr
failure->sexpr
expectstack->sexpr
expect->sexpr)
(define (failureset->sexpr fs)
(let ([fs (flatten fs)])
(case (length fs)
((1) (failure->sexpr (car fs)))
(else `(union ,@(map failure->sexpr fs))))))
(define (failure->sexpr f)
(match f
[(failure progress expectstack)
`(failure ,(progress->sexpr progress)
#:expected ,(expectstack->sexpr expectstack))]))
(define (expectstack->sexpr es)
(map expect->sexpr es))
(define (expect->sexpr e) e)
(define (progress->sexpr ps)
(for/list ([pf (in-list ps)])
(match pf
[(? syntax? stx) 'stx]
[_ pf])))

235
7-4/racket/collects/syntax/parse/private/runtime.rkt Normal file
View File

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

32
7-4/racket/collects/syntax/parse/private/sc.rkt Normal file
View File

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

45
7-4/racket/collects/syntax/parse/private/txlift.rkt Normal file
View File

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

357
7-4/stxparse-info.scrbl Normal file
View File

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

4
info.rkt
View File

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

6
my-include.rkt
View File

@ -42,7 +42,9 @@
#,(my-include1 (loc (string-append -updir "6-90-0-29" -filename)))]
[(version< (version) "7.3.0.1")
#,(my-include1 (loc (string-append -updir "7-0-0-20" -filename)))]
[(version< (version) "7.4")
#,(my-include1 (loc (string-append -updir "7-3-0-1" -filename)))]
;[(version< (version) "7.4")
; #,(my-include1 (loc (string-append -updir "7-3-0-1" -filename)))]
[(version< (version) "7.5")
#,(my-include1 (loc (string-append -updir "7-4" -filename)))]
[else
#,(my-include1 (loc (string-append -updir "8-0" -filename)))]))]))