[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-106-gd8
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-4-106-gd89fae2 |
|
Date: |
Sat, 14 Nov 2009 16:07:27 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d89fae24f516ed4aaadae531bef98de8d524b9f9
The branch, master has been updated
via d89fae24f516ed4aaadae531bef98de8d524b9f9 (commit)
via c3ae0ed441a9ed5ce80da73456e4ea163f57c4b9 (commit)
from ee2a69f565032c6699ce6291e48b8624b2da16ba (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d89fae24f516ed4aaadae531bef98de8d524b9f9
Author: Andy Wingo <address@hidden>
Date: Sat Nov 14 17:04:28 2009 +0100
add include-from-path
* module/ice-9/psyntax.scm (include-from-path): New syntax. Searches the
load path for a file, and includes it.
commit c3ae0ed441a9ed5ce80da73456e4ea163f57c4b9
Author: Andy Wingo <address@hidden>
Date: Sat Nov 14 16:53:36 2009 +0100
psyntax.scm uses #' shorthand for (syntax ...)
* module/ice-9/psyntax.scm: Convert to use #'.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/psyntax-pp.scm | 267 ++--
module/ice-9/psyntax.scm | 4240 ++++++++++++++++++++++---------------------
2 files changed, 2280 insertions(+), 2227 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index f2d3dfc..a606187 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -13694,18 +13694,41 @@
($sc-dispatch #{tmp\ 1950}# (quote (any any)))))
#{x\ 1943}#)))))
-(define unquote
+(define include-from-path
(make-syncase-macro
'macro
(lambda (#{x\ 1959}#)
((lambda (#{tmp\ 1960}#)
((lambda (#{tmp\ 1961}#)
(if #{tmp\ 1961}#
- (apply (lambda (#{_\ 1962}# #{e\ 1963}#)
- (syntax-violation
- 'unquote
- "expression not valid outside of quasiquote"
- #{x\ 1959}#))
+ (apply (lambda (#{k\ 1962}# #{filename\ 1963}#)
+ (let ((#{fn\ 1964}# (syntax->datum #{filename\ 1963}#)))
+ ((lambda (#{tmp\ 1965}#)
+ ((lambda (#{fn\ 1966}#)
+ (list '#(syntax-object
+ include
+ ((top)
+ #(ribcage #(fn) #((top)) #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(fn) #((top)) #("i"))
+ #(ribcage
+ #(k filename)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ #{fn\ 1966}#))
+ #{tmp\ 1965}#))
+ (let ((#{t\ 1967}# (%search-load-path #{fn\ 1964}#)))
+ (if #{t\ 1967}#
+ #{t\ 1967}#
+ (syntax-violation
+ 'include-from-path
+ "file not found in path"
+ #{x\ 1959}#
+ #{filename\ 1963}#))))))
#{tmp\ 1961}#)
(syntax-violation
#f
@@ -13714,40 +13737,60 @@
($sc-dispatch #{tmp\ 1960}# (quote (any any)))))
#{x\ 1959}#))))
+(define unquote
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 1968}#)
+ ((lambda (#{tmp\ 1969}#)
+ ((lambda (#{tmp\ 1970}#)
+ (if #{tmp\ 1970}#
+ (apply (lambda (#{_\ 1971}# #{e\ 1972}#)
+ (syntax-violation
+ 'unquote
+ "expression not valid outside of quasiquote"
+ #{x\ 1968}#))
+ #{tmp\ 1970}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1969}#)))
+ ($sc-dispatch #{tmp\ 1969}# (quote (any any)))))
+ #{x\ 1968}#))))
+
(define unquote-splicing
(make-syncase-macro
'macro
- (lambda (#{x\ 1964}#)
- ((lambda (#{tmp\ 1965}#)
- ((lambda (#{tmp\ 1966}#)
- (if #{tmp\ 1966}#
- (apply (lambda (#{_\ 1967}# #{e\ 1968}#)
+ (lambda (#{x\ 1973}#)
+ ((lambda (#{tmp\ 1974}#)
+ ((lambda (#{tmp\ 1975}#)
+ (if #{tmp\ 1975}#
+ (apply (lambda (#{_\ 1976}# #{e\ 1977}#)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- #{x\ 1964}#))
- #{tmp\ 1966}#)
+ #{x\ 1973}#))
+ #{tmp\ 1975}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1965}#)))
- ($sc-dispatch #{tmp\ 1965}# (quote (any any)))))
- #{x\ 1964}#))))
+ #{tmp\ 1974}#)))
+ ($sc-dispatch #{tmp\ 1974}# (quote (any any)))))
+ #{x\ 1973}#))))
(define case
(make-extended-syncase-macro
(module-ref (current-module) (quote case))
'macro
- (lambda (#{x\ 1969}#)
- ((lambda (#{tmp\ 1970}#)
- ((lambda (#{tmp\ 1971}#)
- (if #{tmp\ 1971}#
- (apply (lambda (#{_\ 1972}#
- #{e\ 1973}#
- #{m1\ 1974}#
- #{m2\ 1975}#)
- ((lambda (#{tmp\ 1976}#)
- ((lambda (#{body\ 1977}#)
+ (lambda (#{x\ 1978}#)
+ ((lambda (#{tmp\ 1979}#)
+ ((lambda (#{tmp\ 1980}#)
+ (if #{tmp\ 1980}#
+ (apply (lambda (#{_\ 1981}#
+ #{e\ 1982}#
+ #{m1\ 1983}#
+ #{m2\ 1984}#)
+ ((lambda (#{tmp\ 1985}#)
+ ((lambda (#{body\ 1986}#)
(list '#(syntax-object
let
((top)
@@ -13776,17 +13819,17 @@
#((top))
#("i")))
(hygiene guile))
- #{e\ 1973}#))
- #{body\ 1977}#))
- #{tmp\ 1976}#))
- (letrec ((#{f\ 1978}#
- (lambda (#{clause\ 1979}# #{clauses\ 1980}#)
- (if (null? #{clauses\ 1980}#)
- ((lambda (#{tmp\ 1982}#)
- ((lambda (#{tmp\ 1983}#)
- (if #{tmp\ 1983}#
- (apply (lambda (#{e1\ 1984}#
- #{e2\ 1985}#)
+ #{e\ 1982}#))
+ #{body\ 1986}#))
+ #{tmp\ 1985}#))
+ (letrec ((#{f\ 1987}#
+ (lambda (#{clause\ 1988}# #{clauses\ 1989}#)
+ (if (null? #{clauses\ 1989}#)
+ ((lambda (#{tmp\ 1991}#)
+ ((lambda (#{tmp\ 1992}#)
+ (if #{tmp\ 1992}#
+ (apply (lambda (#{e1\ 1993}#
+ #{e2\ 1994}#)
(cons '#(syntax-object
begin
((top)
@@ -13832,14 +13875,14 @@
#("i")))
(hygiene
guile))
- (cons #{e1\
1984}#
- #{e2\
1985}#)))
- #{tmp\ 1983}#)
- ((lambda (#{tmp\ 1987}#)
- (if #{tmp\ 1987}#
- (apply (lambda (#{k\ 1988}#
- #{e1\
1989}#
- #{e2\
1990}#)
+ (cons #{e1\
1993}#
+ #{e2\
1994}#)))
+ #{tmp\ 1992}#)
+ ((lambda (#{tmp\ 1996}#)
+ (if #{tmp\ 1996}#
+ (apply (lambda (#{k\ 1997}#
+ #{e1\
1998}#
+ #{e2\
1999}#)
(list
'#(syntax-object
if
((top)
@@ -14040,7 +14083,7 @@
#("i")))
(hygiene
guile))
-
#{k\ 1988}#))
+
#{k\ 1997}#))
(cons
'#(syntax-object
begin
((top)
@@ -14091,24 +14134,24 @@
#("i")))
(hygiene
guile))
- (cons
#{e1\ 1989}#
-
#{e2\ 1990}#))))
- #{tmp\ 1987}#)
- ((lambda (#{_\ 1993}#)
+ (cons
#{e1\ 1998}#
+
#{e2\ 1999}#))))
+ #{tmp\ 1996}#)
+ ((lambda (#{_\ 2002}#)
(syntax-violation
'case
"bad clause"
- #{x\ 1969}#
- #{clause\ 1979}#))
- #{tmp\ 1982}#)))
+ #{x\ 1978}#
+ #{clause\ 1988}#))
+ #{tmp\ 1991}#)))
($sc-dispatch
- #{tmp\ 1982}#
+ #{tmp\ 1991}#
'(each-any
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 1982}#
+ #{tmp\ 1991}#
'(#(free-id
#(syntax-object
else
@@ -14134,15 +14177,15 @@
any
.
each-any))))
- #{clause\ 1979}#)
- ((lambda (#{tmp\ 1994}#)
- ((lambda (#{rest\ 1995}#)
- ((lambda (#{tmp\ 1996}#)
- ((lambda (#{tmp\ 1997}#)
- (if #{tmp\ 1997}#
- (apply (lambda (#{k\
1998}#
- #{e1\
1999}#
- #{e2\
2000}#)
+ #{clause\ 1988}#)
+ ((lambda (#{tmp\ 2003}#)
+ ((lambda (#{rest\ 2004}#)
+ ((lambda (#{tmp\ 2005}#)
+ ((lambda (#{tmp\ 2006}#)
+ (if #{tmp\ 2006}#
+ (apply (lambda (#{k\
2007}#
+ #{e1\
2008}#
+ #{e2\
2009}#)
(list
'#(syntax-object
if
((top)
@@ -14359,7 +14402,7 @@
#("i")))
(hygiene
guile))
-
#{k\ 1998}#))
+
#{k\ 2007}#))
(cons
'#(syntax-object
begin
((top)
@@ -14414,47 +14457,47 @@
#("i")))
(hygiene
guile))
-
(cons #{e1\ 1999}#
-
#{e2\ 2000}#))
- #{rest\
1995}#))
- #{tmp\ 1997}#)
- ((lambda (#{_\ 2003}#)
+
(cons #{e1\ 2008}#
+
#{e2\ 2009}#))
+ #{rest\
2004}#))
+ #{tmp\ 2006}#)
+ ((lambda (#{_\ 2012}#)
(syntax-violation
'case
"bad clause"
- #{x\ 1969}#
- #{clause\ 1979}#))
- #{tmp\ 1996}#)))
+ #{x\ 1978}#
+ #{clause\ 1988}#))
+ #{tmp\ 2005}#)))
($sc-dispatch
- #{tmp\ 1996}#
+ #{tmp\ 2005}#
'(each-any
any
.
each-any))))
- #{clause\ 1979}#))
- #{tmp\ 1994}#))
- (#{f\ 1978}#
- (car #{clauses\ 1980}#)
- (cdr #{clauses\ 1980}#)))))))
- (#{f\ 1978}# #{m1\ 1974}# #{m2\ 1975}#))))
- #{tmp\ 1971}#)
+ #{clause\ 1988}#))
+ #{tmp\ 2003}#))
+ (#{f\ 1987}#
+ (car #{clauses\ 1989}#)
+ (cdr #{clauses\ 1989}#)))))))
+ (#{f\ 1987}# #{m1\ 1983}# #{m2\ 1984}#))))
+ #{tmp\ 1980}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1970}#)))
+ #{tmp\ 1979}#)))
($sc-dispatch
- #{tmp\ 1970}#
+ #{tmp\ 1979}#
'(any any any . each-any))))
- #{x\ 1969}#))))
+ #{x\ 1978}#))))
(define identifier-syntax
(make-syncase-macro
'macro
- (lambda (#{x\ 2004}#)
- ((lambda (#{tmp\ 2005}#)
- ((lambda (#{tmp\ 2006}#)
- (if #{tmp\ 2006}#
- (apply (lambda (#{_\ 2007}# #{e\ 2008}#)
+ (lambda (#{x\ 2013}#)
+ ((lambda (#{tmp\ 2014}#)
+ ((lambda (#{tmp\ 2015}#)
+ (if #{tmp\ 2015}#
+ (apply (lambda (#{_\ 2016}# #{e\ 2017}#)
(list '#(syntax-object
lambda
((top)
@@ -14543,8 +14586,8 @@
#((top))
#("i")))
(hygiene guile))
- #{e\ 2008}#))
- (list (cons #{_\ 2007}#
+ #{e\ 2017}#))
+ (list (cons #{_\ 2016}#
'(#(syntax-object
x
((top)
@@ -14584,7 +14627,7 @@
#((top))
#("i")))
(hygiene guile))
- (cons #{e\ 2008}#
+ (cons #{e\ 2017}#
'(#(syntax-object
x
((top)
@@ -14612,26 +14655,26 @@
#("i")))
(hygiene
guile)))))))))
- #{tmp\ 2006}#)
+ #{tmp\ 2015}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2005}#)))
- ($sc-dispatch #{tmp\ 2005}# (quote (any any)))))
- #{x\ 2004}#))))
+ #{tmp\ 2014}#)))
+ ($sc-dispatch #{tmp\ 2014}# (quote (any any)))))
+ #{x\ 2013}#))))
(define define*
(make-syncase-macro
'macro
- (lambda (#{x\ 2009}#)
- ((lambda (#{tmp\ 2010}#)
- ((lambda (#{tmp\ 2011}#)
- (if #{tmp\ 2011}#
- (apply (lambda (#{dummy\ 2012}#
- #{id\ 2013}#
- #{args\ 2014}#
- #{b0\ 2015}#
- #{b1\ 2016}#)
+ (lambda (#{x\ 2018}#)
+ ((lambda (#{tmp\ 2019}#)
+ ((lambda (#{tmp\ 2020}#)
+ (if #{tmp\ 2020}#
+ (apply (lambda (#{dummy\ 2021}#
+ #{id\ 2022}#
+ #{args\ 2023}#
+ #{b0\ 2024}#
+ #{b1\ 2025}#)
(list '#(syntax-object
define
((top)
@@ -14642,7 +14685,7 @@
#(ribcage () () ())
#(ribcage #(x) #(("m" top)) #("i")))
(hygiene guile))
- #{id\ 2013}#
+ #{id\ 2022}#
(cons '#(syntax-object
lambda*
((top)
@@ -14653,15 +14696,15 @@
#(ribcage () () ())
#(ribcage #(x) #(("m" top)) #("i")))
(hygiene guile))
- (cons #{args\ 2014}#
- (cons #{b0\ 2015}# #{b1\ 2016}#)))))
- #{tmp\ 2011}#)
+ (cons #{args\ 2023}#
+ (cons #{b0\ 2024}# #{b1\ 2025}#)))))
+ #{tmp\ 2020}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2010}#)))
+ #{tmp\ 2019}#)))
($sc-dispatch
- #{tmp\ 2010}#
+ #{tmp\ 2019}#
'(any (any . any) any . each-any))))
- #{x\ 2009}#))))
+ #{x\ 2018}#))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index b1c09f8..d0073c1 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -239,393 +239,393 @@
args))))))
(syntax-case x ()
((_ (name id1 ...))
- (and-map identifier? (syntax (name id1 ...)))
+ (and-map identifier? #'(name id1 ...))
(with-syntax
- ((constructor (construct-name (syntax name) "make-" (syntax name)))
- (predicate (construct-name (syntax name) (syntax name) "?"))
- ((access ...)
- (map (lambda (x) (construct-name x (syntax name) "-" x))
- (syntax (id1 ...))))
- ((assign ...)
- (map (lambda (x)
- (construct-name x "set-" (syntax name) "-" x "!"))
- (syntax (id1 ...))))
- (structure-length
- (+ (length (syntax (id1 ...))) 1))
- ((index ...)
- (let f ((i 1) (ids (syntax (id1 ...))))
- (if (null? ids)
- '()
- (cons i (f (+ i 1) (cdr ids)))))))
- (syntax (begin
- (define constructor
- (lambda (id1 ...)
- (vector 'name id1 ... )))
- (define predicate
- (lambda (x)
- (and (vector? x)
- (= (vector-length x) structure-length)
- (eq? (vector-ref x 0) 'name))))
- (define access
- (lambda (x)
- (vector-ref x index)))
- ...
- (define assign
- (lambda (x update)
- (vector-set! x index update)))
- ...)))))))
+ ((constructor (construct-name #'name "make-" #'name))
+ (predicate (construct-name #'name #'name "?"))
+ ((access ...)
+ (map (lambda (x) (construct-name x #'name "-" x))
+ #'(id1 ...)))
+ ((assign ...)
+ (map (lambda (x)
+ (construct-name x "set-" #'name "-" x "!"))
+ #'(id1 ...)))
+ (structure-length
+ (+ (length #'(id1 ...)) 1))
+ ((index ...)
+ (let f ((i 1) (ids #'(id1 ...)))
+ (if (null? ids)
+ '()
+ (cons i (f (+ i 1) (cdr ids)))))))
+ #'(begin
+ (define constructor
+ (lambda (id1 ...)
+ (vector 'name id1 ... )))
+ (define predicate
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) structure-length)
+ (eq? (vector-ref x 0) 'name))))
+ (define access
+ (lambda (x)
+ (vector-ref x index)))
+ ...
+ (define assign
+ (lambda (x update)
+ (vector-set! x index update)))
+ ...))))))
(let ()
-(define noexpand "noexpand")
-(define *mode* (make-fluid))
+ (define noexpand "noexpand")
+ (define *mode* (make-fluid))
;;; hooks to nonportable run-time helpers
-(begin
-(define fx+ +)
-(define fx- -)
-(define fx= =)
-(define fx< <)
-
-(define top-level-eval-hook
- (lambda (x mod)
- (primitive-eval
- `(,noexpand
- ,(case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) tree-il->scheme) x))
- (else x))))))
-
-(define local-eval-hook
- (lambda (x mod)
- (primitive-eval
- `(,noexpand
- ,(case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) tree-il->scheme) x))
- (else x))))))
-
-(define-syntax gensym-hook
- (syntax-rules ()
- ((_) (gensym))))
-
-(define put-global-definition-hook
- (lambda (symbol type val)
- (let ((existing (let ((v (module-variable (current-module) symbol)))
- (and v (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val)
- (not (syncase-macro-type val))
- val))))))
- (module-define! (current-module)
- symbol
- (if existing
- (make-extended-syncase-macro existing type val)
- (make-syncase-macro type val))))))
-
-(define get-global-definition-hook
- (lambda (symbol module)
- (if (and (not module) (current-module))
- (warn "module system is booted, we should have a module" symbol))
- (let ((v (module-variable (if module
- (resolve-module (cdr module))
- (current-module))
- symbol)))
- (and v (variable-bound? v)
- (let ((val (variable-ref v)))
- (and (macro? val) (syncase-macro-type val)
- (cons (syncase-macro-type val)
- (syncase-macro-binding val))))))))
-
-)
-
-
-(define (decorate-source e s)
- (if (and (pair? e) s)
- (set-source-properties! e s))
- e)
+ (begin
+ (define fx+ +)
+ (define fx- -)
+ (define fx= =)
+ (define fx< <)
+
+ (define top-level-eval-hook
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
+
+ (define local-eval-hook
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
+
+ (define-syntax gensym-hook
+ (syntax-rules ()
+ ((_) (gensym))))
+
+ (define put-global-definition-hook
+ (lambda (symbol type val)
+ (let ((existing (let ((v (module-variable (current-module) symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (not (syncase-macro-type val))
+ val))))))
+ (module-define! (current-module)
+ symbol
+ (if existing
+ (make-extended-syncase-macro existing type val)
+ (make-syncase-macro type val))))))
+
+ (define get-global-definition-hook
+ (lambda (symbol module)
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (syncase-macro-type val)
+ (cons (syncase-macro-type val)
+ (syncase-macro-binding val))))))))
+
+ )
+
+
+ (define (decorate-source e s)
+ (if (and (pair? e) s)
+ (set-source-properties! e s))
+ e)
;;; output constructors
-(define build-void
- (lambda (source)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-void) source))
- (else (decorate-source '(if #f #f) source)))))
-
-(define build-application
- (lambda (source fun-exp arg-exps)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
- (else (decorate-source `(,fun-exp . ,arg-exps) source)))))
-
-(define build-conditional
- (lambda (source test-exp then-exp else-exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-conditional)
- source test-exp then-exp else-exp))
- (else (decorate-source
- (if (equal? else-exp '(if #f #f))
- `(if ,test-exp ,then-exp)
- `(if ,test-exp ,then-exp ,else-exp))
- source)))))
-
-(define build-lexical-reference
- (lambda (type source name var)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lexical-ref) source name var))
- (else (decorate-source var source)))))
+ (define build-void
+ (lambda (source)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-void) source))
+ (else (decorate-source '(if #f #f) source)))))
-(define build-lexical-assignment
- (lambda (source name var exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
- (else (decorate-source `(set! ,var ,exp) source)))))
-
-;; Before modules are booted, we can't expand into data structures from
-;; (language tree-il) -- we need to give the evaluator the
-;; s-expressions that it understands natively. Actually the real truth
-;; of the matter is that the evaluator doesn't understand tree-il
-;; structures at all. So until we fix the evaluator, if ever, the
-;; conflation that we should use tree-il iff we are compiling
-;; holds true.
-;;
-(define (analyze-variable mod var modref-cont bare-cont)
- (if (not mod)
- (bare-cont var)
- (let ((kind (car mod))
- (mod (cdr mod)))
- (case kind
- ((public) (modref-cont mod var #t))
- ((private) (if (not (equal? mod (module-name (current-module))))
- (modref-cont mod var #f)
- (bare-cont var)))
- ((bare) (bare-cont var))
- ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
- (module-variable (resolve-module mod) var))
- (modref-cont mod var #f)
- (bare-cont var)))
- (else (syntax-violation #f "bad module kind" var mod))))))
-
-(define build-global-reference
- (lambda (source var mod)
- (analyze-variable
- mod var
- (lambda (mod var public?)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
- (else (decorate-source (list (if public? '@ '@@) mod var) source))))
- (lambda (var)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-toplevel-ref) source var))
- (else (decorate-source var source)))))))
-
-(define build-global-assignment
- (lambda (source var exp mod)
- (analyze-variable
- mod var
- (lambda (mod var public?)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-module-set) source mod var public?
exp))
- (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var)
,exp) source))))
- (lambda (var)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
- (else (decorate-source `(set! ,var ,exp) source)))))))
-
-;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
-;; from working. Hack around it.
-(define (maybe-name-value! name val)
- (cond
- (((@ (language tree-il) lambda?) val)
- (let ((meta ((@ (language tree-il) lambda-meta) val)))
- (if (not (assq 'name meta))
- ((setter (@ (language tree-il) lambda-meta))
- val
- (acons 'name name meta)))))))
-
-(define build-global-definition
- (lambda (source var exp)
- (case (fluid-ref *mode*)
- ((c)
- (maybe-name-value! var exp)
- ((@ (language tree-il) make-toplevel-define) source var exp))
- (else (decorate-source `(define ,var ,exp) source)))))
-
-;; Ideally we would have all lambdas be case lambdas, but that would
-;; need special support in the interpreter for the full capabilities of
-;; case-lambda, with optional and keyword args, predicates, and else
-;; clauses. This will come with the new interpreter, but for now we
-;; separate the cases.
-(define build-simple-lambda
- (lambda (src req rest vars docstring exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lambda) src
- (if docstring `((documentation . ,docstring)) '())
- ;; hah, a case in which kwargs would be nice.
- ((@ (language tree-il) make-lambda-case)
- ;; src req opt rest kw inits vars predicate body else
- src req #f rest #f '() vars #f exp #f)))
- (else (decorate-source
- `(lambda ,(if rest (apply cons* vars) vars)
- ,@(if docstring (list docstring) '())
- ,exp)
- src)))))
+ (define build-application
+ (lambda (source fun-exp arg-exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+ (else (decorate-source `(,fun-exp . ,arg-exps) source)))))
-(define build-case-lambda
- (lambda (src docstring body)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lambda) src
- (if docstring `((documentation . ,docstring)) '())
- body))
- (else (decorate-source
- ;; really gross hack
- `(lambda %%args
- ,@(if docstring (list docstring) '())
- (cond ,@body))
- src)))))
-
-(define build-lambda-case
- ;; req := (name ...)
- ;; opt := (name ...) | #f
- ;; rest := name | #f
- ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f
- ;; inits: (init ...)
- ;; vars: (sym ...)
- ;; vars map to named arguments in the following order:
- ;; required, optional (positional), rest, keyword.
- ;; predicate: something you can stuff in a (lambda ,vars ,pred), already
expanded
- ;; the body of a lambda: anything, already expanded
- ;; else: lambda-case | #f
- (lambda (src req opt rest kw inits vars predicate body else-case)
- (case (fluid-ref *mode*)
- ((c)
- ((@ (language tree-il) make-lambda-case)
- src req opt rest kw inits vars predicate body else-case))
- (else
- ;; Very much like the logic of (language tree-il compile-glil).
- (let* ((nreq (length req))
- (nopt (if opt (length opt) 0))
- (rest-idx (and rest (+ nreq nopt)))
- (allow-other-keys? (if kw (car kw) #f))
- (kw-indices (map (lambda (x)
- ;; (,key ,name ,var)
- (cons (car x) (list-index vars (caddr x))))
- (if kw (cdr kw) '())))
- (nargs (apply max (+ nreq nopt (if rest 1 0))
- (map 1+ (map cdr kw-indices)))))
- (or (= nargs
- (length vars)
- (+ nreq (length inits) (if rest 1 0)))
- (error "something went wrong"
- req opt rest kw inits vars nreq nopt kw-indices nargs))
- (decorate-source
- `((((@@ (ice-9 optargs) parse-lambda-case)
- '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
- (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
- ,(if predicate `(lambda ,vars ,predicate) #f)
- %%args)
- ;; FIXME: This _ is here to work around a bug in the
- ;; memoizer. The %%% makes it different from %%, also a
- ;; memoizer workaround. See the "interesting bug" mail from
- ;; 23 oct 2009. As soon as we change the evaluator, this
- ;; can be removed.
- => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args)))
- ,@(or else-case
- `((%%args (error "wrong number of arguments" %%args)))))
- src))))))
-
-(define build-primref
- (lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-toplevel-ref) src name))
- (else (decorate-source name src)))
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
- (else (decorate-source `(@@ (guile) ,name) src))))))
-
-(define (build-data src exp)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-const) src exp))
- (else (decorate-source
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp))
- src))))
-
-(define build-sequence
- (lambda (src exps)
- (if (null? (cdr exps))
- (car exps)
- (case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-sequence) src exps))
- (else (decorate-source `(begin ,@exps) src))))))
+ (define build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-conditional)
+ source test-exp then-exp else-exp))
+ (else (decorate-source
+ (if (equal? else-exp '(if #f #f))
+ `(if ,test-exp ,then-exp)
+ `(if ,test-exp ,then-exp ,else-exp))
+ source)))))
-(define build-let
- (lambda (src ids vars val-exps body-exp)
- (if (null? vars)
- body-exp
- (case (fluid-ref *mode*)
- ((c)
- (for-each maybe-name-value! ids val-exps)
- ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
- (else (decorate-source
- `(let ,(map list vars val-exps) ,body-exp)
- src))))))
+ (define build-lexical-reference
+ (lambda (type source name var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else (decorate-source var source)))))
-(define build-named-let
- (lambda (src ids vars val-exps body-exp)
- (let ((f (car vars))
- (f-name (car ids))
- (vars (cdr vars))
- (ids (cdr ids)))
+ (define build-lexical-assignment
+ (lambda (source name var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+ (else (decorate-source `(set! ,var ,exp) source)))))
+
+ ;; Before modules are booted, we can't expand into data structures from
+ ;; (language tree-il) -- we need to give the evaluator the
+ ;; s-expressions that it understands natively. Actually the real truth
+ ;; of the matter is that the evaluator doesn't understand tree-il
+ ;; structures at all. So until we fix the evaluator, if ever, the
+ ;; conflation that we should use tree-il iff we are compiling
+ ;; holds true.
+ ;;
+ (define (analyze-variable mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod))
+ (mod (cdr mod)))
+ (case kind
+ ((public) (modref-cont mod var #t))
+ ((private) (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((bare) (bare-cont var))
+ ((hygiene) (if (and (not (equal? mod (module-name
(current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))
+
+ (define build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) source mod var
public?))
+ (else (decorate-source (list (if public? '@ '@@) mod var) source))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else (decorate-source var source)))))))
+
+ (define build-global-assignment
+ (lambda (source var exp mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-set) source mod var public?
exp))
+ (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var)
,exp) source))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else (decorate-source `(set! ,var ,exp) source)))))))
+
+ ;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
+ ;; from working. Hack around it.
+ (define (maybe-name-value! name val)
+ (cond
+ (((@ (language tree-il) lambda?) val)
+ (let ((meta ((@ (language tree-il) lambda-meta) val)))
+ (if (not (assq 'name meta))
+ ((setter (@ (language tree-il) lambda-meta))
+ val
+ (acons 'name name meta)))))))
+
+ (define build-global-definition
+ (lambda (source var exp)
(case (fluid-ref *mode*)
((c)
- (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
- (maybe-name-value! f-name proc)
- (for-each maybe-name-value! ids val-exps)
- ((@ (language tree-il) make-letrec) src
- (list f-name) (list f) (list proc)
- (build-application src (build-lexical-reference 'fun src f-name f)
- val-exps))))
+ (maybe-name-value! var exp)
+ ((@ (language tree-il) make-toplevel-define) source var exp))
+ (else (decorate-source `(define ,var ,exp) source)))))
+
+ ;; Ideally we would have all lambdas be case lambdas, but that would
+ ;; need special support in the interpreter for the full capabilities of
+ ;; case-lambda, with optional and keyword args, predicates, and else
+ ;; clauses. This will come with the new interpreter, but for now we
+ ;; separate the cases.
+ (define build-simple-lambda
+ (lambda (src req rest vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src
+ (if docstring `((documentation . ,docstring)) '())
+ ;; hah, a case in which kwargs would be nice.
+ ((@ (language tree-il) make-lambda-case)
+ ;; src req opt rest kw inits vars predicate body else
+ src req #f rest #f '() vars #f exp #f)))
(else (decorate-source
- `(let ,f ,(map list vars val-exps) ,body-exp)
- src))))))
+ `(lambda ,(if rest (apply cons* vars) vars)
+ ,@(if docstring (list docstring) '())
+ ,exp)
+ src)))))
-(define build-letrec
- (lambda (src ids vars val-exps body-exp)
- (if (null? vars)
- body-exp
+ (define build-case-lambda
+ (lambda (src docstring body)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src
+ (if docstring `((documentation . ,docstring)) '())
+ body))
+ (else (decorate-source
+ ;; really gross hack
+ `(lambda %%args
+ ,@(if docstring (list docstring) '())
+ (cond ,@body))
+ src)))))
+
+ (define build-lambda-case
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f
+ ;; inits: (init ...)
+ ;; vars: (sym ...)
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ ;; predicate: something you can stuff in a (lambda ,vars ,pred), already
expanded
+ ;; the body of a lambda: anything, already expanded
+ ;; else: lambda-case | #f
+ (lambda (src req opt rest kw inits vars predicate body else-case)
+ (case (fluid-ref *mode*)
+ ((c)
+ ((@ (language tree-il) make-lambda-case)
+ src req opt rest kw inits vars predicate body else-case))
+ (else
+ ;; Very much like the logic of (language tree-il compile-glil).
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ ;; (,key ,name ,var)
+ (cons (car x) (list-index vars (caddr x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices)))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ (decorate-source
+ `((((@@ (ice-9 optargs) parse-lambda-case)
+ '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
+ ,(if predicate `(lambda ,vars ,predicate) #f)
+ %%args)
+ ;; FIXME: This _ is here to work around a bug in the
+ ;; memoizer. The %%% makes it different from %%, also a
+ ;; memoizer workaround. See the "interesting bug" mail from
+ ;; 23 oct 2009. As soon as we change the evaluator, this
+ ;; can be removed.
+ => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args)))
+ ,@(or else-case
+ `((%%args (error "wrong number of arguments" %%args)))))
+ src))))))
+
+ (define build-primref
+ (lambda (src name)
+ (if (equal? (module-name (current-module)) '(guile))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) src name))
+ (else (decorate-source name src)))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+ (else (decorate-source `(@@ (guile) ,name) src))))))
+
+ (define (build-data src exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-const) src exp))
+ (else (decorate-source
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp))
+ src))))
+
+ (define build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-sequence) src exps))
+ (else (decorate-source `(begin ,@exps) src))))))
+
+ (define build-let
+ (lambda (src ids vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
+ (else (decorate-source
+ `(let ,(map list vars val-exps) ,body-exp)
+ src))))))
+
+ (define build-named-let
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars))
+ (f-name (car ids))
+ (vars (cdr vars))
+ (ids (cdr ids)))
(case (fluid-ref *mode*)
((c)
- (for-each maybe-name-value! ids val-exps)
- ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
+ (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
+ (maybe-name-value! f-name proc)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src
+ (list f-name) (list f) (list proc)
+ (build-application src (build-lexical-reference 'fun src f-name
f)
+ val-exps))))
(else (decorate-source
- `(letrec ,(map list vars val-exps) ,body-exp)
+ `(let ,f ,(map list vars val-exps) ,body-exp)
src))))))
-;; FIXME: use a faster gensym
-(define-syntax build-lexical-var
- (syntax-rules ()
- ((_ src id) (gensym (string-append (symbol->string id) " ")))))
+ (define build-letrec
+ (lambda (src ids vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src ids vars val-exps
body-exp))
+ (else (decorate-source
+ `(letrec ,(map list vars val-exps) ,body-exp)
+ src))))))
-(define-structure (syntax-object expression wrap module))
+ ;; FIXME: use a faster gensym
+ (define-syntax build-lexical-var
+ (syntax-rules ()
+ ((_ src id) (gensym (string-append (symbol->string id) " ")))))
-(define-syntax no-source (identifier-syntax #f))
+ (define-structure (syntax-object expression wrap module))
-(define source-annotation
- (lambda (x)
- (cond
- ((syntax-object? x)
- (source-annotation (syntax-object-expression x)))
- ((pair? x) (let ((props (source-properties x)))
- (if (pair? props)
- props
- #f)))
- (else #f))))
-
-(define-syntax arg-check
- (syntax-rules ()
- ((_ pred? e who)
- (let ((x e))
- (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
+ (define-syntax no-source (identifier-syntax #f))
+
+ (define source-annotation
+ (lambda (x)
+ (cond
+ ((syntax-object? x)
+ (source-annotation (syntax-object-expression x)))
+ ((pair? x) (let ((props (source-properties x)))
+ (if (pair? props)
+ props
+ #f)))
+ (else #f))))
+
+ (define-syntax arg-check
+ (syntax-rules ()
+ ((_ pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
;;; compile-time environments
@@ -655,7 +655,7 @@
;;; (define-syntax) define-syntax
;;; (local-syntax . rec?) let-syntax/letrec-syntax
;;; (eval-when) eval-when
-;;; (syntax . (<var> . <level>)) pattern variables
+;;; #'. (<var> . <level>) pattern variables
;;; (global) assumed global variable
;;; (lexical . <var>) lexical variables
;;; (displaced-lexical) displaced lexicals
@@ -683,58 +683,58 @@
;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
;;; a displaced lexical should never occur with properly written macros.
-(define-syntax make-binding
- (syntax-rules (quote)
- ((_ type value) (cons type value))
- ((_ 'type) '(type))
- ((_ type) (cons type '()))))
-(define binding-type car)
-(define binding-value cdr)
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
- (lambda (labels bindings r)
- (if (null? labels)
- r
- (extend-env (cdr labels) (cdr bindings)
- (cons (cons (car labels) (car bindings)) r)))))
-
-(define extend-var-env
- ; variant of extend-env that forms "lexical" binding
- (lambda (labels vars r)
- (if (null? labels)
- r
- (extend-var-env (cdr labels) (cdr vars)
- (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
+ (define-syntax make-binding
+ (syntax-rules (quote)
+ ((_ type value) (cons type value))
+ ((_ 'type) '(type))
+ ((_ type) (cons type '()))))
+ (define binding-type car)
+ (define binding-value cdr)
+
+ (define-syntax null-env (identifier-syntax '()))
+
+ (define extend-env
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env (cdr labels) (cdr bindings)
+ (cons (cons (car labels) (car bindings)) r)))))
+
+ (define extend-var-env
+ ; variant of extend-env that forms
"lexical" binding
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env (cdr labels) (cdr vars)
+ (cons (cons (car labels) (make-binding 'lexical (car
vars))) r)))))
;;; we use a "macros only" environment in expansion of local macro
;;; definitions so that their definitions can use local macros without
;;; attempting to use other lexical identifiers.
-(define macros-only-env
- (lambda (r)
- (if (null? r)
- '()
- (let ((a (car r)))
- (if (eq? (cadr a) 'macro)
- (cons a (macros-only-env (cdr r)))
- (macros-only-env (cdr r)))))))
-
-(define lookup
- ; x may be a label or a symbol
- ; although symbols are usually global, we check the environment first
- ; anyway because a temporary binding may have been established by
- ; fluid-let-syntax
- (lambda (x r mod)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x mod) (make-binding 'global)))
- (else (make-binding 'displaced-lexical)))))
+ (define macros-only-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (eq? (cadr a) 'macro)
+ (cons a (macros-only-env (cdr r)))
+ (macros-only-env (cdr r)))))))
+
+ (define lookup
+ ; x may be a label or a symbol
+ ; although symbols are usually global,
we check the environment first
+ ; anyway because a temporary binding
may have been established by
+ ; fluid-let-syntax
+ (lambda (x r mod)
+ (cond
+ ((assq x r) => cdr)
+ ((symbol? x)
+ (or (get-global-definition-hook x mod) (make-binding 'global)))
+ (else (make-binding 'displaced-lexical)))))
-(define global-extend
- (lambda (type sym val)
- (put-global-definition-hook sym type val)))
+ (define global-extend
+ (lambda (type sym val)
+ (put-global-definition-hook sym type val)))
;;; Conceptually, identifiers are always syntax objects. Internally,
@@ -742,33 +742,33 @@
;;; efficiency and confusion), so that symbols are also considered
;;; identifiers by id?. Externally, they are always wrapped.
-(define nonsymbol-id?
- (lambda (x)
- (and (syntax-object? x)
- (symbol? (syntax-object-expression x)))))
+ (define nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x)
+ (symbol? (syntax-object-expression x)))))
-(define id?
- (lambda (x)
- (cond
- ((symbol? x) #t)
- ((syntax-object? x) (symbol? (syntax-object-expression x)))
- (else #f))))
+ (define id?
+ (lambda (x)
+ (cond
+ ((symbol? x) #t)
+ ((syntax-object? x) (symbol? (syntax-object-expression x)))
+ (else #f))))
-(define-syntax id-sym-name
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (if (syntax-object? x)
+ (define-syntax id-sym-name
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (if (syntax-object? x)
+ (syntax-object-expression x)
+ x)))))
+
+ (define id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
(syntax-object-expression x)
- x)))))
-
-(define id-sym-name&marks
- (lambda (x w)
- (if (syntax-object? x)
- (values
- (syntax-object-expression x)
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values x (wrap-marks w)))))
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values x (wrap-marks w)))))
;;; syntax object wraps
@@ -777,86 +777,86 @@
;;; <subs> ::= #(<old name> <label> (<mark> ...))
;;; <shift> ::= positive fixnum
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
+ (define make-wrap cons)
+ (define wrap-marks car)
+ (define wrap-subst cdr)
-(define-syntax subst-rename? (identifier-syntax vector?))
-(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
-(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
-(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
-(define-syntax make-rename
- (syntax-rules ()
- ((_ old new marks) (vector old new marks))))
+ (define-syntax subst-rename? (identifier-syntax vector?))
+ (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
+ (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
+ (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
+ (define-syntax make-rename
+ (syntax-rules ()
+ ((_ old new marks) (vector old new marks))))
;;; labels must be comparable with "eq?" and distinct from symbols.
-(define gen-label
- (lambda () (string #\i)))
+ (define gen-label
+ (lambda () (string #\i)))
-(define gen-labels
- (lambda (ls)
- (if (null? ls)
- '()
- (cons (gen-label) (gen-labels (cdr ls))))))
+ (define gen-labels
+ (lambda (ls)
+ (if (null? ls)
+ '()
+ (cons (gen-label) (gen-labels (cdr ls))))))
-(define-structure (ribcage symnames marks labels))
+ (define-structure (ribcage symnames marks labels))
-(define-syntax empty-wrap (identifier-syntax '(())))
+ (define-syntax empty-wrap (identifier-syntax '(())))
-(define-syntax top-wrap (identifier-syntax '((top))))
+ (define-syntax top-wrap (identifier-syntax '((top))))
-(define-syntax top-marked?
- (syntax-rules ()
- ((_ w) (memq 'top (wrap-marks w)))))
+ (define-syntax top-marked?
+ (syntax-rules ()
+ ((_ w) (memq 'top (wrap-marks w)))))
;;; Marks must be comparable with "eq?" and distinct from pairs and
;;; the symbol top. We do not use integers so that marks will remain
;;; unique even across file compiles.
-(define-syntax the-anti-mark (identifier-syntax #f))
+ (define-syntax the-anti-mark (identifier-syntax #f))
-(define anti-mark
- (lambda (w)
- (make-wrap (cons the-anti-mark (wrap-marks w))
- (cons 'shift (wrap-subst w)))))
+ (define anti-mark
+ (lambda (w)
+ (make-wrap (cons the-anti-mark (wrap-marks w))
+ (cons 'shift (wrap-subst w)))))
-(define-syntax new-mark
- (syntax-rules ()
- ((_) (string #\m))))
+ (define-syntax new-mark
+ (syntax-rules ()
+ ((_) (string #\m))))
;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
- (syntax-rules ()
- ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- (lambda (ribcage id label)
- (set-ribcage-symnames! ribcage
- (cons (syntax-object-expression id)
- (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks (syntax-object-wrap id))
- (ribcage-marks ribcage)))
- (set-ribcage-labels! ribcage
- (cons label (ribcage-labels ribcage)))))
+ (define-syntax make-empty-ribcage
+ (syntax-rules ()
+ ((_) (make-ribcage '() '() '()))))
+
+ (define extend-ribcage!
+ ; must receive ids with complete wraps
+ (lambda (ribcage id label)
+ (set-ribcage-symnames! ribcage
+ (cons (syntax-object-expression id)
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks (syntax-object-wrap id))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
- (lambda (ids labels w)
- (if (null? ids)
- w
- (make-wrap
- (wrap-marks w)
- (cons
+ (define make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (make-wrap
+ (wrap-marks w)
+ (cons
(let ((labelvec (list->vector labels)))
(let ((n (vector-length labelvec)))
(let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
(let f ((ids ids) (i 0))
(if (not (null? ids))
(call-with-values
- (lambda () (id-sym-name&marks (car ids) w))
+ (lambda () (id-sym-name&marks (car ids) w))
(lambda (symname marks)
(vector-set! symnamevec i symname)
(vector-set! marksvec i marks)
@@ -864,76 +864,76 @@
(make-ribcage symnamevec marksvec labelvec))))
(wrap-subst w))))))
-(define smart-append
- (lambda (m1 m2)
- (if (null? m2)
- m1
- (append m1 m2))))
-
-(define join-wraps
- (lambda (w1 w2)
- (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
- (if (null? m1)
- (if (null? s1)
- w2
- (make-wrap
- (wrap-marks w2)
- (smart-append s1 (wrap-subst w2))))
- (make-wrap
- (smart-append m1 (wrap-marks w2))
- (smart-append s1 (wrap-subst w2)))))))
-
-(define join-marks
- (lambda (m1 m2)
- (smart-append m1 m2)))
-
-(define same-marks?
- (lambda (x y)
- (or (eq? x y)
- (and (not (null? x))
- (not (null? y))
- (eq? (car x) (car y))
- (same-marks? (cdr x) (cdr y))))))
-
-(define id-var-name
- (lambda (id w)
- (define-syntax first
- (syntax-rules ()
- ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
- (define search
- (lambda (sym subst marks)
- (if (null? subst)
- (values #f marks)
- (let ((fst (car subst)))
- (if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
- (let ((symnames (ribcage-symnames fst)))
- (if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
- (define search-list-rib
- (lambda (sym subst marks symnames ribcage)
- (let f ((symnames symnames) (i 0))
- (cond
- ((null? symnames) (search sym (cdr subst) marks))
- ((and (eq? (car symnames) sym)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
- (else (f (cdr symnames) (fx+ i 1)))))))
- (define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
- (let ((n (vector-length symnames)))
- (let f ((i 0))
+ (define smart-append
+ (lambda (m1 m2)
+ (if (null? m2)
+ m1
+ (append m1 m2))))
+
+ (define join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+ (if (null? m1)
+ (if (null? s1)
+ w2
+ (make-wrap
+ (wrap-marks w2)
+ (smart-append s1 (wrap-subst w2))))
+ (make-wrap
+ (smart-append m1 (wrap-marks w2))
+ (smart-append s1 (wrap-subst w2)))))))
+
+ (define join-marks
+ (lambda (m1 m2)
+ (smart-append m1 m2)))
+
+ (define same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+
+ (define id-var-name
+ (lambda (id w)
+ (define-syntax first
+ (syntax-rules ()
+ ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
+ (define search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values #f marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks))
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))))))
+ (define search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
(cond
- ((fx= i n) (search sym (cdr subst) marks))
- ((and (eq? (vector-ref symnames i) sym)
- (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
- (else (f (fx+ i 1))))))))
- (cond
- ((symbol? id)
- (or (first (search id (wrap-subst w) (wrap-marks w))) id))
- ((syntax-object? id)
+ ((null? symnames) (search sym (cdr subst) marks))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ (else (f (cdr symnames) (fx+ i 1)))))))
+ (define search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond
+ ((fx= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage)
i)))
+ (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (else (f (fx+ i 1))))))))
+ (cond
+ ((symbol? id)
+ (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ ((syntax-object? id)
(let ((id (syntax-object-expression id))
(w1 (syntax-object-wrap id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
@@ -942,41 +942,41 @@
(or new-id
(first (search id (wrap-subst w1) marks))
id))))))
- (else (syntax-violation 'id-var-name "invalid id" id)))))
+ (else (syntax-violation 'id-var-name "invalid id" id)))))
;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-(define free-id=?
- (lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+ (define free-id=?
+ (lambda (i j)
+ (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+ (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;;; long as the missing portion of the wrap is common to both of the ids
;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-(define bound-id=?
- (lambda (i j)
- (if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (syntax-object-expression i)
- (syntax-object-expression j))
- (same-marks? (wrap-marks (syntax-object-wrap i))
- (wrap-marks (syntax-object-wrap j))))
- (eq? i j))))
+ (define bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (syntax-object-expression i)
+ (syntax-object-expression j))
+ (same-marks? (wrap-marks (syntax-object-wrap i))
+ (wrap-marks (syntax-object-wrap j))))
+ (eq? i j))))
;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
;;; as long as the missing portion of the wrap is common to all of the
;;; ids.
-(define valid-bound-ids?
- (lambda (ids)
- (and (let all-ids? ((ids ids))
- (or (null? ids)
- (and (id? (car ids))
- (all-ids? (cdr ids)))))
- (distinct-bound-ids? ids))))
+ (define valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids)
+ (and (id? (car ids))
+ (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
;;; distinct-bound-ids? expects a list of ids and returns #t if there are
;;; no duplicates. It is quadratic on the length of the id list; long
@@ -984,101 +984,101 @@
;;; may be passed unwrapped (or partially wrapped) ids as long as the
;;; missing portion of the wrap is common to all of the ids.
-(define distinct-bound-ids?
- (lambda (ids)
- (let distinct? ((ids ids))
- (or (null? ids)
- (and (not (bound-id-member? (car ids) (cdr ids)))
- (distinct? (cdr ids)))))))
+ (define distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
-(define bound-id-member?
- (lambda (x list)
+ (define bound-id-member?
+ (lambda (x list)
(and (not (null? list))
(or (bound-id=? x (car list))
(bound-id-member? x (cdr list))))))
;;; wrapping expressions and identifiers
-(define wrap
- (lambda (x w defmod)
- (cond
- ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
- ((syntax-object? x)
- (make-syntax-object
+ (define wrap
+ (lambda (x w defmod)
+ (cond
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
(syntax-object-expression x)
(join-wraps w (syntax-object-wrap x))
(syntax-object-module x)))
- ((null? x) x)
- (else (make-syntax-object x w defmod)))))
+ ((null? x) x)
+ (else (make-syntax-object x w defmod)))))
-(define source-wrap
- (lambda (x w s defmod)
- (wrap (decorate-source x s) w defmod)))
+ (define source-wrap
+ (lambda (x w s defmod)
+ (wrap (decorate-source x s) w defmod)))
;;; expanding
-(define chi-sequence
- (lambda (body r w s mod)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (mod mod))
- (if (null? body)
- '()
- (let ((first (chi (car body) r w mod)))
- (cons first (dobody (cdr body) r w mod))))))))
-
-(define chi-top-sequence
- (lambda (body r w s m esew mod)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
- (if (null? body)
- '()
- (let ((first (chi-top (car body) r w m esew mod)))
- (cons first (dobody (cdr body) r w m esew mod))))))))
-
-(define chi-install-global
- (lambda (name e)
- (build-global-definition
- no-source
- name
- ;; FIXME: seems nasty to call current-module here
- (if (let ((v (module-variable (current-module) name)))
- ;; FIXME use primitive-macro?
- (and v (variable-bound? v) (macro? (variable-ref v))
- (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
- (build-application
- no-source
- (build-primref no-source 'make-extended-syncase-macro)
- (list (build-application
- no-source
- (build-primref no-source 'module-ref)
- (list (build-application
- no-source
- (build-primref no-source 'current-module)
- '())
- (build-data no-source name)))
- (build-data no-source 'macro)
- e))
- (build-application
- no-source
- (build-primref no-source 'make-syncase-macro)
- (list (build-data no-source 'macro) e))))))
-
-(define chi-when-list
- (lambda (e when-list w)
- ; when-list is syntax'd version of list of situations
- (let f ((when-list when-list) (situations '()))
- (if (null? when-list)
- situations
- (f (cdr when-list)
- (cons (let ((x (car when-list)))
- (cond
- ((free-id=? x (syntax compile)) 'compile)
- ((free-id=? x (syntax load)) 'load)
- ((free-id=? x (syntax eval)) 'eval)
- (else (syntax-violation 'eval-when
- "invalid situation"
- e (wrap x w #f)))))
- situations))))))
+ (define chi-sequence
+ (lambda (body r w s mod)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (mod mod))
+ (if (null? body)
+ '()
+ (let ((first (chi (car body) r w mod)))
+ (cons first (dobody (cdr body) r w mod))))))))
+
+ (define chi-top-sequence
+ (lambda (body r w s m esew mod)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew)
(mod mod))
+ (if (null? body)
+ '()
+ (let ((first (chi-top (car body) r w m esew mod)))
+ (cons first (dobody (cdr body) r w m esew
mod))))))))
+
+ (define chi-install-global
+ (lambda (name e)
+ (build-global-definition
+ no-source
+ name
+ ;; FIXME: seems nasty to call current-module here
+ (if (let ((v (module-variable (current-module) name)))
+ ;; FIXME use primitive-macro?
+ (and v (variable-bound? v) (macro? (variable-ref v))
+ (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-extended-syncase-macro)
+ (list (build-application
+ no-source
+ (build-primref no-source 'module-ref)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '())
+ (build-data no-source name)))
+ (build-data no-source 'macro)
+ e))
+ (build-application
+ no-source
+ (build-primref no-source 'make-syncase-macro)
+ (list (build-data no-source 'macro) e))))))
+
+ (define chi-when-list
+ (lambda (e when-list w)
+ ; when-list is syntax'd version of
list of situations
+ (let f ((when-list when-list) (situations '()))
+ (if (null? when-list)
+ situations
+ (f (cdr when-list)
+ (cons (let ((x (car when-list)))
+ (cond
+ ((free-id=? x #'compile) 'compile)
+ ((free-id=? x #'load) 'load)
+ ((free-id=? x #'eval) 'eval)
+ (else (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap x w #f)))))
+ situations))))))
;;; syntax-type returns six values: type, value, e, w, s, and mod. The
;;; first two are described in the table below.
@@ -1116,684 +1116,684 @@
;;; one of the forms above. It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer.
-(define syntax-type
- (lambda (e r w s rib mod for-car?)
- (cond
- ((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r mod))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e w s mod))
- ((global) (values type n e w s mod))
- ((macro)
- (if for-car?
- (values type (binding-value b) e w s mod)
- (syntax-type (chi-macro (binding-value b) e r w rib mod)
- r empty-wrap s rib mod #f)))
- (else (values type (binding-value b) e w s mod)))))
- ((pair? e)
- (let ((first (car e)))
- (call-with-values
- (lambda () (syntax-type first r w s rib mod #t))
- (lambda (ftype fval fe fw fs fmod)
- (case ftype
- ((lexical)
- (values 'lexical-call fval e w s mod))
- ((global)
- ;; If we got here via an (@@ ...) expansion, we need to
- ;; make sure the fmod information is propagated back
- ;; correctly -- hence this consing.
- (values 'global-call (make-syntax-object fval w fmod)
- e w s mod))
- ((macro)
- (syntax-type (chi-macro fval e r w rib mod)
- r empty-wrap s rib mod for-car?))
- ((module-ref)
- (call-with-values (lambda () (fval e))
- (lambda (sym mod)
- (syntax-type sym r w s rib mod for-car?))))
- ((core)
- (values 'core-form fval e w s mod))
- ((local-syntax)
- (values 'local-syntax-form fval e w s mod))
- ((begin)
- (values 'begin-form #f e w s mod))
- ((eval-when)
- (values 'eval-when-form #f e w s mod))
- ((define)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values 'define-form (syntax name) (syntax val) w s mod))
- ((_ (name . args) e1 e2 ...)
- (and (id? (syntax name))
- (valid-bound-ids? (lambda-var-list (syntax args))))
+ (define syntax-type
+ (lambda (e r w s rib mod for-car?)
+ (cond
+ ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r mod))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values type (binding-value b) e w s mod))
+ ((global) (values type n e w s mod))
+ ((macro)
+ (if for-car?
+ (values type (binding-value b) e w s mod)
+ (syntax-type (chi-macro (binding-value b) e r w rib mod)
+ r empty-wrap s rib mod #f)))
+ (else (values type (binding-value b) e w s mod)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (call-with-values
+ (lambda () (syntax-type first r w s rib mod #t))
+ (lambda (ftype fval fe fw fs fmod)
+ (case ftype
+ ((lexical)
+ (values 'lexical-call fval e w s mod))
+ ((global)
+ ;; If we got here via an (@@ ...) expansion, we need to
+ ;; make sure the fmod information is propagated back
+ ;; correctly -- hence this consing.
+ (values 'global-call (make-syntax-object fval w fmod)
+ e w s mod))
+ ((macro)
+ (syntax-type (chi-macro fval e r w rib mod)
+ r empty-wrap s rib mod for-car?))
+ ((module-ref)
+ (call-with-values (lambda () (fval e))
+ (lambda (sym mod)
+ (syntax-type sym r w s rib mod for-car?))))
+ ((core)
+ (values 'core-form fval e w s mod))
+ ((local-syntax)
+ (values 'local-syntax-form fval e w s mod))
+ ((begin)
+ (values 'begin-form #f e w s mod))
+ ((eval-when)
+ (values 'eval-when-form #f e w s mod))
+ ((define)
+ (syntax-case e ()
+ ((_ name val)
+ (id? #'name)
+ (values 'define-form #'name #'val w s mod))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? #'name)
+ (valid-bound-ids? (lambda-var-list #'args)))
; need lambda here...
- (values 'define-form (wrap (syntax name) w mod)
- (decorate-source
- (cons (syntax lambda) (wrap (syntax (args e1 e2
...)) w mod))
- s)
- empty-wrap s mod))
- ((_ name)
- (id? (syntax name))
- (values 'define-form (wrap (syntax name) w mod)
- (syntax (if #f #f))
- empty-wrap s mod))))
- ((define-syntax)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values 'define-syntax-form (syntax name)
- (syntax val) w s mod))))
- (else
- (values 'call #f e w s mod)))))))
- ((syntax-object? e)
- (syntax-type (syntax-object-expression e)
- r
- (join-wraps w (syntax-object-wrap e))
- s rib (or (syntax-object-module e) mod) for-car?))
- ((self-evaluating? e) (values 'constant #f e w s mod))
- (else (values 'other #f e w s mod)))))
-
-(define chi-top
- (lambda (e r w m esew mod)
- (define-syntax eval-if-c&e
- (syntax-rules ()
- ((_ m e mod)
- (let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x mod))
- x))))
- (call-with-values
- (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
- (lambda (type value e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) (chi-void))
- ((_ e1 e2 ...)
- (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (chi-top-sequence body r w s m esew mod))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w))
- (body (syntax (e1 e2 ...))))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (chi-top-sequence body r w s 'e '(eval) mod)
- (chi-void)))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load) mod)
- (if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load) mod)
- (chi-void))))
- ((or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
+ (values 'define-form (wrap #'name w mod)
+ (decorate-source
+ (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
+ s)
+ empty-wrap s mod))
+ ((_ name)
+ (id? #'name)
+ (values 'define-form (wrap #'name w mod)
+ #'(if #f #f)
+ empty-wrap s mod))))
+ ((define-syntax)
+ (syntax-case e ()
+ ((_ name val)
+ (id? #'name)
+ (values 'define-syntax-form #'name
+ #'val w s mod))))
+ (else
+ (values 'call #f e w s mod)))))))
+ ((syntax-object? e)
+ (syntax-type (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ s rib (or (syntax-object-module e) mod) for-car?))
+ ((self-evaluating? e) (values 'constant #f e w s mod))
+ (else (values 'other #f e w s mod)))))
+
+ (define chi-top
+ (lambda (e r w m esew mod)
+ (define-syntax eval-if-c&e
+ (syntax-rules ()
+ ((_ m e mod)
+ (let ((x e))
+ (if (eq? m 'c&e) (top-level-eval-hook x mod))
+ x))))
+ (call-with-values
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value e w s mod)
+ (case type
+ ((begin-form)
+ (syntax-case e ()
+ ((_) (chi-void))
+ ((_ e1 e2 ...)
+ (chi-top-sequence #'(e1 e2 ...) r w s m esew mod))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s mod
+ (lambda (body r w s mod)
+ (chi-top-sequence body r w s m esew mod))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e #'(x ...) w))
+ (body #'(e1 e2 ...)))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (chi-top-sequence body r w s 'e '(eval) mod)
+ (chi-void)))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (chi-top-sequence body r w s 'c&e '(compile load) mod)
+ (if (memq m '(c c&e))
+ (chi-top-sequence body r w s 'c '(load) mod)
+ (chi-void))))
+ ((or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
mod)
- (chi-void))
- (else (chi-void)))))))
- ((define-syntax-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) e (chi-void)))
- (if (memq 'load esew)
- (chi-install-global n (chi e r w mod))
- (chi-void))))
- ((c&e)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- e))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (chi-install-global n (chi e r w mod))
- mod))
- (chi-void)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- ;; use value of the same-named imported variable, if
- ;; any
- (module-define! (current-module) n
- (if (variable? old)
- (variable-ref old)
- #f))))
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod))
- mod))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- e (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- e (wrap value w mod))))))
- (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
-
-(define chi
- (lambda (e r w mod)
- (call-with-values
- (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
- (lambda (type value e w s mod)
- (chi-expr type value e r w s mod)))))
-
-(define chi-expr
- (lambda (type value e r w s mod)
- (case type
- ((lexical)
- (build-lexical-reference 'value s e value))
- ((core core-form)
- ;; apply transformer
- (value e r w s mod))
- ((module-ref)
- (call-with-values (lambda () (value e))
- ;; we could add a public? arg here
- (lambda (id mod) (build-global-reference s id mod))))
- ((lexical-call)
- (chi-application
- (build-lexical-reference 'fun (source-annotation (car e))
- (car e) value)
- e r w s mod))
- ((global-call)
- (chi-application
- (build-global-reference (source-annotation (car e))
- (if (syntax-object? value)
- (syntax-object-expression value)
- value)
- (if (syntax-object? value)
- (syntax-object-module value)
- mod))
- e r w s mod))
- ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
- ((global) (build-global-reference s value mod))
- ((call) (chi-application (chi (car e) r w mod) e r w s mod))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s mod chi-sequence))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w)))
- (if (memq 'eval when-list)
- (chi-sequence (syntax (e1 e2 ...)) r w s mod)
- (chi-void))))))
- ((define-form define-syntax-form)
- (syntax-violation #f "definition in expression context"
- e (wrap value w mod)))
- ((syntax)
- (syntax-violation #f "reference to pattern variable outside syntax form"
- (source-wrap e w s mod)))
- ((displaced-lexical)
- (syntax-violation #f "reference to identifier outside its scope"
- (source-wrap e w s mod)))
- (else (syntax-violation #f "unexpected syntax"
- (source-wrap e w s mod))))))
-
-(define chi-application
- (lambda (x e r w s mod)
- (syntax-case e ()
- ((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
-
-(define chi-macro
- (lambda (p e r w rib mod)
- (define rebuild-macro-output
- (lambda (x m)
- (cond ((pair? x)
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m)))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
- (let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- ;; output is from original text
- (make-syntax-object
- (syntax-object-expression x)
- (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr
s)))
- (syntax-object-module x))
- ;; output introduced by macro
- (make-syntax-object
- (syntax-object-expression x)
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s)))
- (let ((pmod (procedure-module p)))
- (if pmod
- ;; hither the hygiene
- (cons 'hygiene (module-name pmod))
- ;; but it's possible for the proc to have
- ;; no mod, if it was made before modules
- ;; were booted
- '(hygiene guile))))))))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i n) v)
+ (chi-void))
+ (else (chi-void)))))))
+ ((define-syntax-form)
+ (let ((n (id-var-name value w)) (r (macros-only-env r)))
+ (case m
+ ((c)
+ (if (memq 'compile esew)
+ (let ((e (chi-install-global n (chi e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) e (chi-void)))
+ (if (memq 'load esew)
+ (chi-install-global n (chi e r w mod))
+ (chi-void))))
+ ((c&e)
+ (let ((e (chi-install-global n (chi e r w mod))))
+ (top-level-eval-hook e mod)
+ e))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (chi-install-global n (chi e r w mod))
+ mod))
+ (chi-void)))))
+ ((define-form)
+ (let* ((n (id-var-name value w))
+ (type (binding-type (lookup n r mod))))
+ (case type
+ ((global core macro module-ref)
+ ;; affect compile-time environment (once we have booted)
+ (if (and (not (module-local-variable (current-module) n))
+ (current-module))
+ (let ((old (module-variable (current-module) n)))
+ ;; use value of the same-named imported variable, if
+ ;; any
+ (module-define! (current-module) n
+ (if (variable? old)
+ (variable-ref old)
+ #f))))
+ (eval-if-c&e m
+ (build-global-definition s n (chi e r w mod))
+ mod))
+ ((displaced-lexical)
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
+ (else
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
+
+ (define chi
+ (lambda (e r w mod)
+ (call-with-values
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value e w s mod)
+ (chi-expr type value e r w s mod)))))
+
+ (define chi-expr
+ (lambda (type value e r w s mod)
+ (case type
+ ((lexical)
+ (build-lexical-reference 'value s e value))
+ ((core core-form)
+ ;; apply transformer
+ (value e r w s mod))
+ ((module-ref)
+ (call-with-values (lambda () (value e))
+ ;; we could add a public? arg here
+ (lambda (id mod) (build-global-reference s id mod))))
+ ((lexical-call)
+ (chi-application
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
+ e r w s mod))
+ ((global-call)
+ (chi-application
+ (build-global-reference (source-annotation (car e))
+ (if (syntax-object? value)
+ (syntax-object-expression value)
+ value)
+ (if (syntax-object? value)
+ (syntax-object-module value)
+ mod))
+ e r w s mod))
+ ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
+ ((global) (build-global-reference s value mod))
+ ((call) (chi-application (chi (car e) r w mod) e r w s mod))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s mod chi-sequence))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e #'(x ...) w)))
+ (if (memq 'eval when-list)
+ (chi-sequence #'(e1 e2 ...) r w s mod)
+ (chi-void))))))
+ ((define-form define-syntax-form)
+ (syntax-violation #f "definition in expression context"
+ e (wrap value w mod)))
+ ((syntax)
+ (syntax-violation #f "reference to pattern variable outside syntax
form"
+ (source-wrap e w s mod)))
+ ((displaced-lexical)
+ (syntax-violation #f "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
+ (else (syntax-violation #f "unexpected syntax"
+ (source-wrap e w s mod))))))
+
+ (define chi-application
+ (lambda (x e r w s mod)
+ (syntax-case e ()
+ ((e0 e1 ...)
+ (build-application s x
+ (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
+
+ (define chi-macro
+ (lambda (p e r w rib mod)
+ (define rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m)))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ ;; output is from original text
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr
s)))
+ (syntax-object-module x))
+ ;; output introduced by macro
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s)))
+ (let ((pmod (procedure-module p)))
+ (if pmod
+ ;; hither the hygiene
+ (cons 'hygiene (module-name pmod))
+ ;; but it's possible for the proc to have
+ ;; no mod, if it was made before modules
+ ;; were booted
+ '(hygiene guile))))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i n) v)
(vector-set! v i
- (rebuild-macro-output (vector-ref x i) m)))))
- ((symbol? x)
- (syntax-violation #f "encountered raw symbol in macro output"
- (source-wrap e w (wrap-subst w) mod) x))
- (else x))))
- (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
-
-(define chi-body
- ;; In processing the forms of the body, we create a new, empty wrap.
- ;; This wrap is augmented (destructively) each time we discover that
- ;; the next form is a definition. This is done:
- ;;
- ;; (1) to allow the first nondefinition form to be a call to
- ;; one of the defined ids even if the id previously denoted a
- ;; definition keyword or keyword for a macro expanding into a
- ;; definition;
- ;; (2) to prevent subsequent definition forms (but unfortunately
- ;; not earlier ones) and the first nondefinition form from
- ;; confusing one of the bound identifiers for an auxiliary
- ;; keyword; and
- ;; (3) so that we do not need to restart the expansion of the
- ;; first nondefinition form, which is problematic anyway
- ;; since it might be the first element of a begin that we
- ;; have just spliced into the body (meaning if we restarted,
- ;; we'd really need to restart with the begin or the macro
- ;; call that expanded into the begin, and we'd have to give
- ;; up allowing (begin <defn>+ <expr>+), which is itself
- ;; problematic since we don't know if a begin contains only
- ;; definitions until we've expanded it).
- ;;
- ;; Before processing the body, we also create a new environment
- ;; containing a placeholder for the bindings we will add later and
- ;; associate this environment with each form. In processing a
- ;; let-syntax or letrec-syntax, the associated environment may be
- ;; augmented with local keyword bindings, so the environment may
- ;; be different for different forms in the body. Once we have
- ;; gathered up all of the definitions, we evaluate the transformer
- ;; expressions and splice into r at the placeholder the new variable
- ;; and keyword bindings. This allows let-syntax or letrec-syntax
- ;; forms local to a portion or all of the body to shadow the
- ;; definition bindings.
- ;;
- ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
- ;; into the body.
- ;;
- ;; outer-form is fully wrapped w/source
- (lambda (body outer-form r w mod)
- (let* ((r (cons '("placeholder" . (placeholder)) r))
- (ribcage (make-empty-ribcage))
- (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
- (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
- (ids '()) (labels '())
- (var-ids '()) (vars '()) (vals '()) (bindings '()))
- (if (null? body)
- (syntax-violation #f "no expressions in body" outer-form)
- (let ((e (cdar body)) (er (caar body)))
- (call-with-values
- (lambda () (syntax-type e er empty-wrap (source-annotation er)
ribcage mod #f))
- (lambda (type value e w s mod)
- (case type
- ((define-form)
- (let ((id (wrap value w mod)) (label (gen-label)))
- (let ((var (gen-var id)))
+ (rebuild-macro-output (vector-ref x i) m)))))
+ ((symbol? x)
+ (syntax-violation #f "encountered raw symbol in macro output"
+ (source-wrap e w (wrap-subst w) mod) x))
+ (else x))))
+ (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
+
+ (define chi-body
+ ;; In processing the forms of the body, we create a new, empty wrap.
+ ;; This wrap is augmented (destructively) each time we discover that
+ ;; the next form is a definition. This is done:
+ ;;
+ ;; (1) to allow the first nondefinition form to be a call to
+ ;; one of the defined ids even if the id previously denoted a
+ ;; definition keyword or keyword for a macro expanding into a
+ ;; definition;
+ ;; (2) to prevent subsequent definition forms (but unfortunately
+ ;; not earlier ones) and the first nondefinition form from
+ ;; confusing one of the bound identifiers for an auxiliary
+ ;; keyword; and
+ ;; (3) so that we do not need to restart the expansion of the
+ ;; first nondefinition form, which is problematic anyway
+ ;; since it might be the first element of a begin that we
+ ;; have just spliced into the body (meaning if we restarted,
+ ;; we'd really need to restart with the begin or the macro
+ ;; call that expanded into the begin, and we'd have to give
+ ;; up allowing (begin <defn>+ <expr>+), which is itself
+ ;; problematic since we don't know if a begin contains only
+ ;; definitions until we've expanded it).
+ ;;
+ ;; Before processing the body, we also create a new environment
+ ;; containing a placeholder for the bindings we will add later and
+ ;; associate this environment with each form. In processing a
+ ;; let-syntax or letrec-syntax, the associated environment may be
+ ;; augmented with local keyword bindings, so the environment may
+ ;; be different for different forms in the body. Once we have
+ ;; gathered up all of the definitions, we evaluate the transformer
+ ;; expressions and splice into r at the placeholder the new variable
+ ;; and keyword bindings. This allows let-syntax or letrec-syntax
+ ;; forms local to a portion or all of the body to shadow the
+ ;; definition bindings.
+ ;;
+ ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+ ;; into the body.
+ ;;
+ ;; outer-form is fully wrapped w/source
+ (lambda (body outer-form r w mod)
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+ (ids '()) (labels '())
+ (var-ids '()) (vars '()) (vals '()) (bindings '()))
+ (if (null? body)
+ (syntax-violation #f "no expressions in body" outer-form)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap (source-annotation
er) ribcage mod #f))
+ (lambda (type value e w s mod)
+ (case type
+ ((define-form)
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids) (cons label labels)
+ (cons id var-ids)
+ (cons var vars) (cons (cons er (wrap e w
mod)) vals)
+ (cons (make-binding 'lexical var)
bindings)))))
+ ((define-syntax-form)
+ (let ((id (wrap value w mod)) (label (gen-label)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
- (cons id ids) (cons label labels)
- (cons id var-ids)
- (cons var vars) (cons (cons er (wrap e w mod)) vals)
- (cons (make-binding 'lexical var) bindings)))))
- ((define-syntax-form)
- (let ((id (wrap value w mod)) (label (gen-label)))
- (extend-ribcage! ribcage id label)
- (parse (cdr body)
- (cons id ids) (cons label labels)
- var-ids vars vals
- (cons (make-binding 'macro (cons er (wrap e w mod)))
- bindings))))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 ...)
- (parse (let f ((forms (syntax (e1 ...))))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w mod))
- (f (cdr forms)))))
- ids labels var-ids vars vals bindings))))
- ((local-syntax-form)
- (chi-local-syntax value e er w s mod
- (lambda (forms er w s mod)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w mod))
- (f (cdr forms)))))
- ids labels var-ids vars vals bindings))))
- (else ; found a non-definition
- (if (null? ids)
- (build-sequence no-source
- (map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
- (cons (cons er (source-wrap e w s mod))
- (cdr body))))
- (begin
- (if (not (valid-bound-ids? ids))
- (syntax-violation
- #f "invalid or duplicate identifier in
definition"
- outer-form))
- (let loop ((bs bindings) (er-cache #f) (r-cache #f))
- (if (not (null? bs))
- (let* ((b (car bs)))
- (if (eq? (car b) 'macro)
- (let* ((er (cadr b))
- (r-cache
- (if (eq? er er-cache)
- r-cache
- (macros-only-env er))))
- (set-cdr! b
- (eval-local-transformer
- (chi (cddr b) r-cache empty-wrap
mod)
- mod))
- (loop (cdr bs) er r-cache))
- (loop (cdr bs) er-cache r-cache)))))
- (set-cdr! r (extend-env labels bindings (cdr r)))
- (build-letrec no-source
- (map syntax->datum var-ids)
- vars
- (map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
- vals)
- (build-sequence no-source
- (map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
- (cons (cons er (source-wrap e w s mod))
- (cdr body)))))))))))))))))
-
-(define chi-local-syntax
- (lambda (rec? e r w s mod k)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation #f "duplicate bound keyword" e)
- (let ((labels (gen-labels ids)))
- (let ((new-w (make-binding-wrap ids labels w)))
- (k (syntax (e1 e2 ...))
- (extend-env
- labels
- (let ((w (if rec? new-w w))
- (trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer
- (chi x trans-r w mod)
- mod)))
- (syntax (val ...))))
- r)
- new-w
- s
- mod))))))
- (_ (syntax-violation #f "bad local syntax definition"
- (source-wrap e w s mod))))))
-
-(define eval-local-transformer
- (lambda (expanded mod)
- (let ((p (local-eval-hook expanded mod)))
- (if (procedure? p)
- p
- (syntax-violation #f "nonprocedure transformer" p)))))
-
-(define chi-void
- (lambda ()
- (build-void no-source)))
-
-(define ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (free-id=? x (syntax (... ...))))))
-
-(define lambda-formals
- (lambda (orig-args)
- (define (req args rreq)
- (syntax-case args ()
- (()
- (check (reverse rreq) #f))
- ((a . b) (id? #'a)
- (req #'b (cons #'a rreq)))
- (r (id? #'r)
- (check (reverse rreq) #'r))
- (else
- (syntax-violation 'lambda "invalid argument list" orig-args args))))
- (define (check req rest)
- (cond
- ((distinct-bound-ids? (if rest (cons rest req) req))
- (values req #f rest #f #f))
- (else
- (syntax-violation 'lambda "duplicate identifier in argument list"
- orig-args))))
- (req orig-args '())))
-
-(define chi-simple-lambda
- (lambda (e r w s mod req rest docstring body)
- (let* ((ids (if rest (append req (list rest)) req))
- (vars (map gen-var ids))
- (labels (gen-labels ids)))
- (build-simple-lambda
- s
- (map syntax->datum req) (and rest (syntax->datum rest)) vars
- docstring
- (chi-body body (source-wrap e w s mod)
- (extend-var-env labels vars r)
- (make-binding-wrap ids labels w)
- mod)))))
-
-(define lambda*-formals
- (lambda (orig-args)
- (define (req args rreq)
- (syntax-case args ()
- (()
- (check (reverse rreq) '() #f '() #f))
- ((a . b) (id? #'a)
- (req #'b (cons #'a rreq)))
- ((a . b) (eq? (syntax->datum #'a) #:optional)
- (opt #'b (reverse rreq) '()))
- ((a . b) (eq? (syntax->datum #'a) #:key)
- (key #'b (reverse rreq) '() '()))
- ((a . b) (eq? (syntax->datum #'a) #:predicate)
- (pred #'b (reverse rreq) '() '()))
- ((a b) (eq? (syntax->datum #'a) #:rest)
- (rest #'b (reverse rreq) '() '() #f))
- (r (id? #'r)
- (rest #'r (reverse rreq) '() '() #f))
- (else
- (syntax-violation 'lambda* "invalid argument list" orig-args args))))
- (define (opt args req ropt)
- (syntax-case args ()
- (()
- (check req (reverse ropt) #f '() #f))
- ((a . b) (id? #'a)
- (opt #'b req (cons #'(a #f) ropt)))
- (((a init) . b) (id? #'a)
- (opt #'b req (cons #'(a init) ropt)))
- ((a . b) (eq? (syntax->datum #'a) #:key)
- (key #'b req (reverse ropt) '()))
- ((a . b) (eq? (syntax->datum #'a) #:predicate)
- (pred #'b req (reverse ropt) '()))
- ((a b) (eq? (syntax->datum #'a) #:rest)
- (rest #'b req (reverse ropt) '() #f))
- (r (id? #'r)
- (rest #'r req (reverse ropt) '() #f))
- (else
- (syntax-violation 'lambda* "invalid optional argument list"
- orig-args args))))
- (define (key args req opt rkey)
- (syntax-case args ()
- (()
- (check req opt #f (cons #f (reverse rkey)) #f))
- ((a . b) (id? #'a)
- (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
- (key #'b req opt (cons #'(k a #f) rkey))))
- (((a init) . b) (id? #'a)
- (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
- (key #'b req opt (cons #'(k a init) rkey))))
- (((a init k) . b) (and (id? #'a)
- (keyword? (syntax->datum #'k)))
- (key #'b req opt (cons #'(k a init) rkey)))
- ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
- (check req opt #f (cons #t (reverse rkey)) #f))
- ((aok a . b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
- (eq? (syntax->datum #'a) #:predicate))
- (pred #'b req opt (cons #t (reverse rkey))))
- ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
- (eq? (syntax->datum #'a) #:rest))
- (rest #'b req opt (cons #t (reverse rkey)) #f))
- ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
- (id? #'r))
- (rest #'r req opt (cons #t (reverse rkey)) #f))
- ((a . b) (eq? (syntax->datum #'a) #:predicate)
- (pred #'b req opt (cons #f (reverse rkey))))
- ((a b) (eq? (syntax->datum #'a) #:rest)
- (rest #'b req opt (cons #f (reverse rkey)) #f))
- (r (id? #'r)
- (rest #'r req opt (cons #f (reverse rkey)) #f))
- (else
- (syntax-violation 'lambda* "invalid keyword argument list"
- orig-args args))))
- (define (pred args req opt kw)
- (syntax-case args ()
- ((x) (check req opt #f kw #'x))
- ((x a b) (eq? (syntax->datum #'a) #:rest)
- (rest #'b req opt kw #f))
- ((x . b) (id? #'b)
- (rest #'b req opt kw #f))
- (else
- (syntax-violation 'lambda* "invalid argument list following
#:predicate"
- orig-args args))))
- (define (rest args req opt kw pred)
- (syntax-case args ()
- (r (id? #'r)
- (check req opt #'r kw pred))
- (else
- (syntax-violation 'lambda* "invalid rest argument"
- orig-args args))))
- (define (check req opt rest kw pred)
- (cond
- ((distinct-bound-ids?
- (append req (map car opt) (if rest (list rest) '())
- (if (pair? kw) (map cadr (cdr kw)) '())))
- (values req opt rest kw pred))
- (else
- (syntax-violation 'lambda* "duplicate identifier in argument list"
- orig-args))))
- (req orig-args '())))
-
-(define chi-lambda-case
- (lambda (e r w s mod get-formals clauses)
- (define (expand-req req opt rest kw pred body)
- (let ((vars (map gen-var req))
- (labels (gen-labels req)))
- (let ((r* (extend-var-env labels vars r))
- (w* (make-binding-wrap req labels w)))
- (expand-opt (map syntax->datum req)
- opt rest kw pred body (reverse vars) r* w* '() '()))))
- (define (expand-opt req opt rest kw pred body vars r* w* out inits)
- (cond
- ((pair? opt)
- (syntax-case (car opt) ()
- ((id i)
- (let* ((v (gen-var #'id))
- (l (gen-labels (list v)))
- (r** (extend-var-env l (list v) r*))
- (w** (make-binding-wrap (list #'id) l w*)))
- (expand-opt req (cdr opt) rest kw pred body (cons v vars)
- r** w** (cons (syntax->datum #'id) out)
- (cons (chi #'i r* w* mod) inits))))))
- (rest
- (let* ((v (gen-var rest))
- (l (gen-labels (list v)))
- (r* (extend-var-env l (list v) r*))
- (w* (make-binding-wrap (list rest) l w*)))
- (expand-kw req (if (pair? out) (reverse out) #f)
- (syntax->datum rest)
+ (cons id ids) (cons label labels)
+ var-ids vars vals
+ (cons (make-binding 'macro (cons er (wrap e w
mod)))
+ bindings))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms #'(e1 ...)))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w mod))
+ (f (cdr forms)))))
+ ids labels var-ids vars vals bindings))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s mod
+ (lambda (forms er w s mod)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap
(car forms) w mod))
+ (f (cdr
forms)))))
+ ids labels var-ids vars vals
bindings))))
+ (else ; found a non-definition
+ (if (null? ids)
+ (build-sequence no-source
+ (map (lambda (x)
+ (chi (cdr x) (car x)
empty-wrap mod))
+ (cons (cons er (source-wrap e
w s mod))
+ (cdr body))))
+ (begin
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation
+ #f "invalid or duplicate identifier in
definition"
+ outer-form))
+ (let loop ((bs bindings) (er-cache #f) (r-cache
#f))
+ (if (not (null? bs))
+ (let* ((b (car bs)))
+ (if (eq? (car b) 'macro)
+ (let* ((er (cadr b))
+ (r-cache
+ (if (eq? er er-cache)
+ r-cache
+ (macros-only-env er))))
+ (set-cdr! b
+ (eval-local-transformer
+ (chi (cddr b) r-cache
empty-wrap mod)
+ mod))
+ (loop (cdr bs) er r-cache))
+ (loop (cdr bs) er-cache r-cache)))))
+ (set-cdr! r (extend-env labels bindings (cdr r)))
+ (build-letrec no-source
+ (map syntax->datum var-ids)
+ vars
+ (map (lambda (x)
+ (chi (cdr x) (car x)
empty-wrap mod))
+ vals)
+ (build-sequence no-source
+ (map (lambda (x)
+ (chi (cdr x)
(car x) empty-wrap mod))
+ (cons (cons er
(source-wrap e w s mod))
+ (cdr
body)))))))))))))))))
+
+ (define chi-local-syntax
+ (lambda (rec? e r w s mod k)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids #'(id ...)))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation #f "duplicate bound keyword" e)
+ (let ((labels (gen-labels ids)))
+ (let ((new-w (make-binding-wrap ids labels w)))
+ (k #'(e1 e2 ...)
+ (extend-env
+ labels
+ (let ((w (if rec? new-w w))
+ (trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding 'macro
+ (eval-local-transformer
+ (chi x trans-r w mod)
+ mod)))
+ #'(val ...)))
+ r)
+ new-w
+ s
+ mod))))))
+ (_ (syntax-violation #f "bad local syntax definition"
+ (source-wrap e w s mod))))))
+
+ (define eval-local-transformer
+ (lambda (expanded mod)
+ (let ((p (local-eval-hook expanded mod)))
+ (if (procedure? p)
+ p
+ (syntax-violation #f "nonprocedure transformer" p)))))
+
+ (define chi-void
+ (lambda ()
+ (build-void no-source)))
+
+ (define ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (free-id=? x #'(... ...)))))
+
+ (define lambda-formals
+ (lambda (orig-args)
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (check (reverse rreq) #f))
+ ((a . b) (id? #'a)
+ (req #'b (cons #'a rreq)))
+ (r (id? #'r)
+ (check (reverse rreq) #'r))
+ (else
+ (syntax-violation 'lambda "invalid argument list" orig-args args))))
+ (define (check req rest)
+ (cond
+ ((distinct-bound-ids? (if rest (cons rest req) req))
+ (values req #f rest #f #f))
+ (else
+ (syntax-violation 'lambda "duplicate identifier in argument list"
+ orig-args))))
+ (req orig-args '())))
+
+ (define chi-simple-lambda
+ (lambda (e r w s mod req rest docstring body)
+ (let* ((ids (if rest (append req (list rest)) req))
+ (vars (map gen-var ids))
+ (labels (gen-labels ids)))
+ (build-simple-lambda
+ s
+ (map syntax->datum req) (and rest (syntax->datum rest)) vars
+ docstring
+ (chi-body body (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
+
+ (define lambda*-formals
+ (lambda (orig-args)
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (check (reverse rreq) '() #f '() #f))
+ ((a . b) (id? #'a)
+ (req #'b (cons #'a rreq)))
+ ((a . b) (eq? (syntax->datum #'a) #:optional)
+ (opt #'b (reverse rreq) '()))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b (reverse rreq) '() '()))
+ ((a . b) (eq? (syntax->datum #'a) #:predicate)
+ (pred #'b (reverse rreq) '() '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b (reverse rreq) '() '() #f))
+ (r (id? #'r)
+ (rest #'r (reverse rreq) '() '() #f))
+ (else
+ (syntax-violation 'lambda* "invalid argument list" orig-args
args))))
+ (define (opt args req ropt)
+ (syntax-case args ()
+ (()
+ (check req (reverse ropt) #f '() #f))
+ ((a . b) (id? #'a)
+ (opt #'b req (cons #'(a #f) ropt)))
+ (((a init) . b) (id? #'a)
+ (opt #'b req (cons #'(a init) ropt)))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b req (reverse ropt) '()))
+ ((a . b) (eq? (syntax->datum #'a) #:predicate)
+ (pred #'b req (reverse ropt) '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req (reverse ropt) '() #f))
+ (r (id? #'r)
+ (rest #'r req (reverse ropt) '() #f))
+ (else
+ (syntax-violation 'lambda* "invalid optional argument list"
+ orig-args args))))
+ (define (key args req opt rkey)
+ (syntax-case args ()
+ (()
+ (check req opt #f (cons #f (reverse rkey)) #f))
+ ((a . b) (id? #'a)
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a #f) rkey))))
+ (((a init) . b) (id? #'a)
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a init) rkey))))
+ (((a init k) . b) (and (id? #'a)
+ (keyword? (syntax->datum #'k)))
+ (key #'b req opt (cons #'(k a init) rkey)))
+ ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (check req opt #f (cons #t (reverse rkey)) #f))
+ ((aok a . b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (eq? (syntax->datum #'a) #:predicate))
+ (pred #'b req opt (cons #t (reverse rkey))))
+ ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (eq? (syntax->datum #'a) #:rest))
+ (rest #'b req opt (cons #t (reverse rkey)) #f))
+ ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (id? #'r))
+ (rest #'r req opt (cons #t (reverse rkey)) #f))
+ ((a . b) (eq? (syntax->datum #'a) #:predicate)
+ (pred #'b req opt (cons #f (reverse rkey))))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req opt (cons #f (reverse rkey)) #f))
+ (r (id? #'r)
+ (rest #'r req opt (cons #f (reverse rkey)) #f))
+ (else
+ (syntax-violation 'lambda* "invalid keyword argument list"
+ orig-args args))))
+ (define (pred args req opt kw)
+ (syntax-case args ()
+ ((x) (check req opt #f kw #'x))
+ ((x a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req opt kw #f))
+ ((x . b) (id? #'b)
+ (rest #'b req opt kw #f))
+ (else
+ (syntax-violation 'lambda* "invalid argument list following
#:predicate"
+ orig-args args))))
+ (define (rest args req opt kw pred)
+ (syntax-case args ()
+ (r (id? #'r)
+ (check req opt #'r kw pred))
+ (else
+ (syntax-violation 'lambda* "invalid rest argument"
+ orig-args args))))
+ (define (check req opt rest kw pred)
+ (cond
+ ((distinct-bound-ids?
+ (append req (map car opt) (if rest (list rest) '())
+ (if (pair? kw) (map cadr (cdr kw)) '())))
+ (values req opt rest kw pred))
+ (else
+ (syntax-violation 'lambda* "duplicate identifier in argument list"
+ orig-args))))
+ (req orig-args '())))
+
+ (define chi-lambda-case
+ (lambda (e r w s mod get-formals clauses)
+ (define (expand-req req opt rest kw pred body)
+ (let ((vars (map gen-var req))
+ (labels (gen-labels req)))
+ (let ((r* (extend-var-env labels vars r))
+ (w* (make-binding-wrap req labels w)))
+ (expand-opt (map syntax->datum req)
+ opt rest kw pred body (reverse vars) r* w* '() '()))))
+ (define (expand-opt req opt rest kw pred body vars r* w* out inits)
+ (cond
+ ((pair? opt)
+ (syntax-case (car opt) ()
+ ((id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-opt req (cdr opt) rest kw pred body (cons v vars)
+ r** w** (cons (syntax->datum #'id) out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (rest
+ (let* ((v (gen-var rest))
+ (l (gen-labels (list v)))
+ (r* (extend-var-env l (list v) r*))
+ (w* (make-binding-wrap (list rest) l w*)))
+ (expand-kw req (if (pair? out) (reverse out) #f)
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ pred body (cons v vars) r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits)))
+ (else
+ (expand-kw req (if (pair? out) (reverse out) #f) #f
(if (pair? kw) (cdr kw) kw)
- pred body (cons v vars) r* w*
+ pred body vars r* w*
(if (pair? kw) (car kw) #f)
- '() inits)))
- (else
- (expand-kw req (if (pair? out) (reverse out) #f) #f
- (if (pair? kw) (cdr kw) kw)
- pred body vars r* w*
- (if (pair? kw) (car kw) #f)
- '() inits))))
- (define (expand-kw req opt rest kw pred body vars r* w* aok out inits)
- (cond
- ((pair? kw)
- (syntax-case (car kw) ()
- ((k id i)
- (let* ((v (gen-var #'id))
- (l (gen-labels (list v)))
- (r** (extend-var-env l (list v) r*))
- (w** (make-binding-wrap (list #'id) l w*)))
- (expand-kw req opt rest (cdr kw) pred body (cons v vars)
- r** w** aok
- (cons (list (syntax->datum #'k)
- (syntax->datum #'id)
- v)
- out)
- (cons (chi #'i r* w* mod) inits))))))
- (else
- (expand-pred req opt rest
- (if (or aok (pair? out)) (cons aok (reverse out)) #f)
- pred body (reverse vars) r* w* (reverse inits)))))
- (define (expand-pred req opt rest kw pred body vars r* w* inits)
- (expand-body req opt rest kw (and pred (chi pred r* w* mod))
- body vars r* w* inits))
- (define (expand-body req opt rest kw pred body vars r* w* inits)
- (syntax-case body ()
- ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
- (values (syntax->datum #'docstring) req opt rest kw inits vars pred
- (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
- r* w* mod)))
- ((e1 e2 ...)
- (values #f req opt rest kw inits vars pred
- (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
- r* w* mod)))))
-
- (syntax-case clauses ()
- (() (values #f #f))
- (((args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values (lambda () (get-formals #'args))
- (lambda (req opt rest kw pred)
- (call-with-values (lambda ()
- (expand-req req opt rest kw pred #'(e1 e2
...)))
- (lambda (docstring req opt rest kw inits vars pred body)
- (call-with-values
- (lambda ()
- (chi-lambda-case e r w s mod get-formals
- #'((args* e1* e2* ...) ...)))
- (lambda (docstring* else*)
- (values
- (or docstring docstring*)
- (build-lambda-case s req opt rest kw inits vars
- pred body else*))))))))))))
+ '() inits))))
+ (define (expand-kw req opt rest kw pred body vars r* w* aok out inits)
+ (cond
+ ((pair? kw)
+ (syntax-case (car kw) ()
+ ((k id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-kw req opt rest (cdr kw) pred body (cons v vars)
+ r** w** aok
+ (cons (list (syntax->datum #'k)
+ (syntax->datum #'id)
+ v)
+ out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (else
+ (expand-pred req opt rest
+ (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+ pred body (reverse vars) r* w* (reverse inits)))))
+ (define (expand-pred req opt rest kw pred body vars r* w* inits)
+ (expand-body req opt rest kw (and pred (chi pred r* w* mod))
+ body vars r* w* inits))
+ (define (expand-body req opt rest kw pred body vars r* w* inits)
+ (syntax-case body ()
+ ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (values (syntax->datum #'docstring) req opt rest kw inits vars pred
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))
+ ((e1 e2 ...)
+ (values #f req opt rest kw inits vars pred
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))))
+
+ (syntax-case clauses ()
+ (() (values #f #f))
+ (((args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values (lambda () (get-formals #'args))
+ (lambda (req opt rest kw pred)
+ (call-with-values (lambda ()
+ (expand-req req opt rest kw pred #'(e1 e2
...)))
+ (lambda (docstring req opt rest kw inits vars pred body)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod get-formals
+ #'((args* e1* e2* ...) ...)))
+ (lambda (docstring* else*)
+ (values
+ (or docstring docstring*)
+ (build-lambda-case s req opt rest kw inits vars
+ pred body else*))))))))))))
;;; data
@@ -1803,37 +1803,37 @@
;;; in the spine, we also check for pairs whose cars are annotated in case
;;; we've been passed the cdr of an annotated list
-(define strip
- (lambda (x w)
- (if (top-marked? w)
- x
- (let f ((x x))
- (cond
- ((syntax-object? x)
- (strip (syntax-object-expression x) (syntax-object-wrap x)))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (and-map* eq? old new) x (list->vector new)))))
- (else x))))))
+ (define strip
+ (lambda (x w)
+ (if (top-marked? w)
+ x
+ (let f ((x x))
+ (cond
+ ((syntax-object? x)
+ (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (and-map* eq? old new) x (list->vector new)))))
+ (else x))))))
;;; lexical variables
-(define gen-var
- (lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (build-lexical-var no-source id))))
+ (define gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (build-lexical-var no-source id))))
-;; appears to return a reversed list
-(define lambda-var-list
- (lambda (vars)
- (let lvl ((vars vars) (ls '()) (w empty-wrap))
- (cond
+ ;; appears to return a reversed list
+ (define lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
+ (cond
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls)
@@ -1841,541 +1841,541 @@
(lvl (syntax-object-expression vars)
ls
(join-wraps w (syntax-object-wrap vars))))
- ; include anything else to be caught by subsequent error
- ; checking
+ ; include anything else to be caught
by subsequent error
+ ; checking
(else (cons vars ls))))))
;;; core transformers
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-(global-extend 'core 'fluid-let-syntax
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? (syntax (var ...)))
- (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r mod))
- ((displaced-lexical)
- (syntax-violation 'fluid-let-syntax
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- (syntax (var ...))
- names)
- (chi-body
- (syntax (e1 e2 ...))
- (source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer (chi x trans-r w mod)
- mod)))
- (syntax (val ...))))
- r)
- w
- mod)))
- (_ (syntax-violation 'fluid-let-syntax "bad syntax"
- (source-wrap e w s mod))))))
-
-(global-extend 'core 'quote
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-violation 'quote "bad syntax"
- (source-wrap e w s mod))))))
+ (global-extend 'local-syntax 'letrec-syntax #t)
+ (global-extend 'local-syntax 'let-syntax #f)
+
+ (global-extend 'core 'fluid-let-syntax
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names (map (lambda (x) (id-var-name x w)) #'(var
...))))
+ (for-each
+ (lambda (id n)
+ (case (binding-type (lookup n r mod))
+ ((displaced-lexical)
+ (syntax-violation 'fluid-let-syntax
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
+ #'(var ...)
+ names)
+ (chi-body
+ #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env
+ names
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding 'macro
+ (eval-local-transformer (chi
x trans-r w mod)
+ mod)))
+ #'(val ...)))
+ r)
+ w
+ mod)))
+ (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+ (source-wrap e w s mod))))))
+
+ (global-extend 'core 'quote
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ e) (build-data s (strip #'e w)))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
+
+ (global-extend 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (let ((label (id-var-name e empty-wrap)))
+ (let ((b (lookup label r mod)))
+ (if (eq? (binding-type b) 'syntax)
+ (call-with-values
+ (lambda ()
+ (let ((var.lev (binding-value b)))
+ (gen-ref src (car var.lev) (cdr
var.lev) maps)))
+ (lambda (var maps) (values `(ref ,var)
maps)))
+ (if (ellipsis? e)
+ (syntax-violation 'syntax "misplaced
ellipsis" src)
+ (values `(quote ,e) maps)))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots)
+ (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ ((x dots . y)
+ ; this could be about a dozen lines of
code, except that we
+ ; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots)
+ (let f ((y #'y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'x r
+ (cons '() maps)
ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax
"extra ellipsis"
+ src)
+ (values (gen-map x (car
maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots)
+ (f #'y
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax
"extra ellipsis" src)
+ (values (gen-mappend x (car
maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps
ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y)
maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src #'x r maps
ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src #'y r maps
ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x y)
maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'(e1 e2 ...) r maps
ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e)
maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-violation 'syntax "missing ellipsis"
src)
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1)
(cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var
inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x)))
map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ; identity map equivalence:
+ ; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x)
formals)))
+ (cdr e))
+ ; eta map equivalence:
+ ; (map (lambda (x ...) (f x ...)) y
...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
-(global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis? mod)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r mod)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? (syntax dots))
- (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
- ((x dots . y)
- ; this could be about a dozen lines of code, except that we
- ; choose to handle (syntax (x ... ...)) forms
- (ellipsis? (syntax dots))
- (let f ((y (syntax y))
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax x) r
- (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
- src)
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? (syntax dots))
- (f (syntax y)
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
src)
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source
(cadr x) (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr
x) #f (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-application no-source
+ (build-primref no-source
(car x))
+ (map regen (cdr x)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ x)
(call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src (syntax y) r maps ellipsis?
mod))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ; identity map equivalence:
- ; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ; eta map equivalence:
- ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda)
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen
(caddr x)))
- (error "how did we get here" x)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ x)
- (call-with-values
- (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
-
-(global-extend 'core 'lambda
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ args docstring e1 e2 ...) (string? (syntax->datum #'docstring))
- (call-with-values (lambda () (lambda-formals #'args))
- (lambda (req opt rest kw pred)
- (chi-simple-lambda e r w s mod req rest (syntax->datum #'docstring)
- #'(e1 e2 ...)))))
- ((_ args e1 e2 ...)
- (call-with-values (lambda () (lambda-formals #'args))
- (lambda (req opt rest kw pred)
- (chi-simple-lambda e r w s mod req rest #f #'(e1 e2 ...)))))
- (_ (syntax-violation 'lambda "bad lambda" e)))))
-
-(global-extend 'core 'lambda*
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ args e1 e2 ...)
- (call-with-values
- (lambda ()
- (chi-lambda-case e r w s mod
- lambda*-formals #'((args e1 e2 ...))))
- (lambda (docstring lcase)
- (build-case-lambda s docstring lcase))))
- (_ (syntax-violation 'lambda "bad lambda*" e)))))
-
-(global-extend 'core 'case-lambda
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values
- (lambda ()
- (chi-lambda-case e r w s mod
- lambda-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
- (lambda (docstring lcase)
- (build-case-lambda s docstring lcase))))
- (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
-
-(global-extend 'core 'case-lambda*
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
- (call-with-values
- (lambda ()
- (chi-lambda-case e r w s mod
- lambda*-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
- (lambda (docstring lcase)
- (build-case-lambda s docstring lcase))))
- (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
-
-(global-extend 'core 'let
- (let ()
- (define (chi-let e r w s mod constructor ids vals exps)
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'let "duplicate bound variable" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((nw (make-binding-wrap ids labels w))
- (nr (extend-var-env labels new-vars r)))
- (constructor s
- (map syntax->datum ids)
- new-vars
- (map (lambda (x) (chi x r w mod)) vals)
- (chi-body exps (source-wrap e nw s mod)
- nr nw mod))))))
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? (syntax (id ...)))
- (chi-let e r w s mod
- build-let
- (syntax (id ...))
- (syntax (val ...))
- (syntax (e1 e2 ...))))
- ((_ f ((id val) ...) e1 e2 ...)
- (and (id? (syntax f)) (and-map id? (syntax (id ...))))
- (chi-let e r w s mod
- build-named-let
- (syntax (f id ...))
- (syntax (val ...))
- (syntax (e1 e2 ...))))
- (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
-
-
-(global-extend 'core 'letrec
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? (syntax (id ...)))
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'letrec "duplicate bound variable" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((w (make-binding-wrap ids labels w))
- (r (extend-var-env labels new-vars r)))
- (build-letrec s
- (map syntax->datum ids)
- new-vars
- (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...))
- (source-wrap e w s mod) r w mod)))))))
- (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
-
-
-(global-extend 'core 'set!
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ id val)
- (id? (syntax id))
- (let ((val (chi (syntax val) r w mod))
- (n (id-var-name (syntax id) w)))
- (let ((b (lookup n r mod)))
- (case (binding-type b)
- ((lexical)
- (build-lexical-assignment s
- (syntax->datum (syntax id))
- (binding-value b)
- val))
- ((global) (build-global-assignment s n val mod))
- ((displaced-lexical)
- (syntax-violation 'set! "identifier out of context"
- (wrap (syntax id) w mod)))
- (else (syntax-violation 'set! "bad set!"
- (source-wrap e w s mod)))))))
- ((_ (head tail ...) val)
- (call-with-values
- (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod
#t))
- (lambda (type value ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (chi (syntax val) r w mod)))
- (call-with-values (lambda () (value (syntax (head tail ...))))
- (lambda (id mod)
- (build-global-assignment s id val mod)))))
- (else
- (build-application s
- (chi (syntax (setter head)) r w mod)
- (map (lambda (e) (chi e r w mod))
- (syntax (tail ... val)))))))))
- (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
-
-(global-extend 'module-ref '@
- (lambda (e)
- (syntax-case e ()
- ((_ (mod ...) id)
- (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax->datum (syntax id))
- (syntax->datum
- (syntax (public mod ...))))))))
-
-(global-extend 'module-ref '@@
- (lambda (e)
- (syntax-case e ()
- ((_ (mod ...) id)
- (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax->datum (syntax id))
- (syntax->datum
- (syntax (private mod ...))))))))
-
-(global-extend 'core 'if
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ test then)
- (build-conditional
- s
- (chi (syntax test) r w mod)
- (chi (syntax then) r w mod)
- (build-void no-source)))
- ((_ test then else)
- (build-conditional
- s
- (chi (syntax test) r w mod)
- (chi (syntax then) r w mod)
- (chi (syntax else) r w mod))))))
-
-(global-extend 'begin 'begin '())
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'core 'syntax-case
- (let ()
- (define convert-pattern
- ; accepts pattern & keys
- ; returns $sc-dispatch pattern & ids
- (lambda (pattern keys)
- (let cvt ((p pattern) (n 0) (ids '()))
- (if (id? p)
- (if (bound-id-member? p keys)
- (values (vector 'free-id p) ids)
- (values 'any (cons (cons p n) ids)))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt (syntax x) (fx+ n 1) ids))
- (lambda (p ids)
- (values (if (eq? p 'any) 'each-any (vector 'each p))
- ids))))
- ((x . y)
- (call-with-values
- (lambda () (cvt (syntax y) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (syntax x) n ids))
- (lambda (x ids)
- (values (cons x y) ids))))))
- (() (values '() ids))
- (#(x ...)
- (call-with-values
- (lambda () (cvt (syntax (x ...)) n ids))
- (lambda (p ids) (values (vector 'vector p) ids))))
- (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
-
- (define build-dispatch-call
- (lambda (pvars exp y r mod)
- (let ((ids (map car pvars)) (levels (map cdr pvars)))
- (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-simple-lambda no-source (map syntax->datum ids) #f
new-vars #f
- (chi exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)
- mod))
- y))))))
-
- (define gen-clause
- (lambda (x keys clauses r pat fender exp mod)
- (call-with-values
- (lambda () (convert-pattern pat keys))
- (lambda (p pvars)
- (cond
- ((not (distinct-bound-ids? (map car pvars)))
- (syntax-violation 'syntax-case "duplicate pattern variable"
pat))
- ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-violation 'syntax-case "misplaced ellipsis" pat))
- (else
- (let ((y (gen-var 'tmp)))
- ; fat finger binding and references to temp variable y
- (build-application no-source
- (build-simple-lambda no-source (list 'tmp) #f (list y) #f
- (let ((y (build-lexical-reference 'value no-source
- 'tmp y)))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r mod)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r mod)
- (gen-syntax-case x keys clauses r mod))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list x))
- (build-application no-source
- (build-primref no-source '$sc-dispatch)
- (list x (build-data no-source p)))))))))))))
-
- (define gen-syntax-case
- (lambda (x keys clauses r mod)
- (if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-violation)
- (list (build-data no-source #f)
- (build-data no-source
- "source expression failed to match any
pattern")
- x))
- (syntax-case (car clauses) ()
- ((pat exp)
- (if (and (id? (syntax pat))
- (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
- (cons (syntax (... ...)) keys)))
- (let ((labels (list (gen-label)))
- (var (gen-var (syntax pat))))
- (build-application no-source
- (build-simple-lambda
- no-source (list (syntax->datum (syntax pat))) #f (list
var)
- #f
- (chi (syntax exp)
- (extend-env labels
- (list (make-binding 'syntax `(,var .
0)))
- r)
- (make-binding-wrap (syntax (pat))
- labels empty-wrap)
- mod))
- (list x)))
- (gen-clause x keys (cdr clauses) r
- (syntax pat) #t (syntax exp) mod)))
- ((pat fender exp)
- (gen-clause x keys (cdr clauses) r
- (syntax pat) (syntax fender) (syntax exp) mod))
- (_ (syntax-violation 'syntax-case "invalid clause"
- (car clauses)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ val (key ...) m ...)
- (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
- (let ((x (gen-var 'tmp)))
- ; fat finger binding and references to temp variable x
- (build-application s
- (build-simple-lambda no-source (list 'tmp) #f (list x) #f
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- (syntax (key ...)) (syntax (m ...))
- r
- mod))
- (list (chi (syntax val) r empty-wrap mod))))
- (syntax-violation 'syntax-case "invalid literals list" e))))))))
+ (lambda () (gen-syntax e #'x r '() ellipsis?
mod))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-violation 'syntax "bad `syntax' form"
e)))))))
+
+ (global-extend 'core 'lambda
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ args docstring e1 e2 ...) (string? (syntax->datum
#'docstring))
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw pred)
+ (chi-simple-lambda e r w s mod req rest
(syntax->datum #'docstring)
+ #'(e1 e2 ...)))))
+ ((_ args e1 e2 ...)
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw pred)
+ (chi-simple-lambda e r w s mod req rest #f #'(e1 e2
...)))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
+
+ (global-extend 'core 'lambda*
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ args e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda*-formals #'((args e1 e2
...))))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'lambda "bad lambda*" e)))))
+
+ (global-extend 'core 'case-lambda
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda-formals
+ #'((args e1 e2 ...) (args* e1*
e2* ...) ...)))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+
+ (global-extend 'core 'case-lambda*
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda*-formals
+ #'((args e1 e2 ...) (args* e1*
e2* ...) ...)))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'case-lambda "bad case-lambda*"
e)))))
+
+ (global-extend 'core 'let
+ (let ()
+ (define (chi-let e r w s mod constructor ids vals exps)
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'let "duplicate bound variable" e)
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-var-env labels new-vars r)))
+ (constructor s
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (chi x r w mod))
vals)
+ (chi-body exps (source-wrap e nw s
mod)
+ nr nw mod))))))
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (chi-let e r w s mod
+ build-let
+ #'(id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
+ ((_ f ((id val) ...) e1 e2 ...)
+ (and (id? #'f) (and-map id? #'(id ...)))
+ (chi-let e r w s mod
+ build-named-let
+ #'(f id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s
mod)))))))
+
+
+ (global-extend 'core 'letrec
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (let ((ids #'(id ...)))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'letrec "duplicate bound
variable" e)
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env labels new-vars r)))
+ (build-letrec s
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (chi x r w
mod)) #'(val ...))
+ (chi-body #'(e1 e2 ...)
+ (source-wrap e w s
mod) r w mod)))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e
w s mod))))))
+
+
+ (global-extend 'core 'set!
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (let ((val (chi #'val r w mod))
+ (n (id-var-name #'id w)))
+ (let ((b (lookup n r mod)))
+ (case (binding-type b)
+ ((lexical)
+ (build-lexical-assignment s
+ (syntax->datum #'id)
+ (binding-value b)
+ val))
+ ((global) (build-global-assignment s n val mod))
+ ((displaced-lexical)
+ (syntax-violation 'set! "identifier out of
context"
+ (wrap #'id w mod)))
+ (else (syntax-violation 'set! "bad set!"
+ (source-wrap e w s
mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type #'head r empty-wrap
no-source #f mod #t))
+ (lambda (type value ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (chi #'val r w mod)))
+ (call-with-values (lambda () (value #'(head
tail ...)))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
+ (else
+ (build-application s
+ (chi #'(setter head) r w mod)
+ (map (lambda (e) (chi e r w
mod))
+ #'(tail ... val))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s
mod))))))
+
+ (global-extend 'module-ref '@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ (values (syntax->datum #'id)
+ (syntax->datum
+ #'(public mod ...)))))))
+
+ (global-extend 'module-ref '@@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ (values (syntax->datum #'id)
+ (syntax->datum
+ #'(private mod ...)))))))
+
+ (global-extend 'core 'if
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional
+ s
+ (chi #'test r w mod)
+ (chi #'then r w mod)
+ (build-void no-source)))
+ ((_ test then else)
+ (build-conditional
+ s
+ (chi #'test r w mod)
+ (chi #'then r w mod)
+ (chi #'else r w mod))))))
+
+ (global-extend 'begin 'begin '())
+
+ (global-extend 'define 'define '())
+
+ (global-extend 'define-syntax 'define-syntax '())
+
+ (global-extend 'eval-when 'eval-when '())
+
+ (global-extend 'core 'syntax-case
+ (let ()
+ (define convert-pattern
+ ; accepts pattern & keys
+ ; returns $sc-dispatch pattern & ids
+ (lambda (pattern keys)
+ (let cvt ((p pattern) (n 0) (ids '()))
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? #'dots)
+ (call-with-values
+ (lambda () (cvt #'x (fx+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector
'each p))
+ ids))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt #'y n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt #'x n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt #'(x ...) n ids))
+ (lambda (p ids) (values (vector 'vector p)
ids))))
+ (x (values (vector 'atom (strip p empty-wrap))
ids)))))))
+
+ (define build-dispatch-call
+ (lambda (pvars exp y r mod)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map
gen-var ids)))
+ (build-application no-source
+ (build-primref no-source 'apply)
+ (list (build-simple-lambda
no-source (map syntax->datum ids) #f new-vars #f
+ (chi
exp
+
(extend-env
+
labels
+
(map (lambda (var level)
+
(make-binding 'syntax `(,var . ,level)))
+
new-vars
+
(map cdr pvars))
+
r)
+
(make-binding-wrap ids labels empty-wrap)
+
mod))
+ y))))))
+
+ (define gen-clause
+ (lambda (x keys clauses r pat fender exp mod)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate pattern
variable" pat))
+ ((not (and-map (lambda (x) (not (ellipsis? (car
x)))) pvars))
+ (syntax-violation 'syntax-case "misplaced
ellipsis" pat))
+ (else
+ (let ((y (gen-var 'tmp)))
+ ; fat finger binding and references to
temp variable y
+ (build-application no-source
+ (build-simple-lambda
no-source (list 'tmp) #f (list y) #f
+ (let
((y (build-lexical-reference 'value no-source
+
'tmp y)))
+
(build-conditional no-source
+
(syntax-case fender ()
+
(#t y)
+
(_ (build-conditional no-source
+
y
+
(build-dispatch-call pvars fender y r mod)
+
(build-data no-source #f))))
+
(build-dispatch-call pvars exp y r mod)
+
(gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-application
no-source
+
(build-primref no-source 'list)
+
(list x))
+ (build-application
no-source
+
(build-primref no-source '$sc-dispatch)
+
(list x (build-data no-source p)))))))))))))
+
+ (define gen-syntax-case
+ (lambda (x keys clauses r mod)
+ (if (null? clauses)
+ (build-application no-source
+ (build-primref no-source
'syntax-violation)
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source
expression failed to match any pattern")
+ x))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? #'pat)
+ (and-map (lambda (x) (not (free-id=?
#'pat x)))
+ (cons #'(... ...) keys)))
+ (let ((labels (list (gen-label)))
+ (var (gen-var #'pat)))
+ (build-application no-source
+ (build-simple-lambda
+ no-source (list
(syntax->datum #'pat)) #f (list var)
+ #f
+ (chi #'exp
+ (extend-env labels
+ (list
(make-binding 'syntax `(,var . 0)))
+ r)
+
(make-binding-wrap #'(pat)
+
labels empty-wrap)
+ mod))
+ (list x)))
+ (gen-clause x keys (cdr clauses) r
+ #'pat #t #'exp mod)))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r
+ #'pat #'fender #'exp mod))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (and-map (lambda (x) (and (id? x) (not
(ellipsis? x))))
+ #'(key ...))
+ (let ((x (gen-var 'tmp)))
+ ; fat finger binding and references to
temp variable x
+ (build-application s
+ (build-simple-lambda
no-source (list 'tmp) #f (list x) #f
+
(gen-syntax-case (build-lexical-reference 'value no-source
+
'tmp x)
+
#'(key ...) #'(m ...)
+
r
+
mod))
+ (list (chi #'val r
empty-wrap mod))))
+ (syntax-violation 'syntax-case "invalid literals
list" e))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
@@ -2386,65 +2386,65 @@
;;; syntactic definitions are evaluated immediately after they are
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
-(set! sc-expand
- (lambda (x . rest)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (let ((m (if (null? rest) 'e (car rest)))
- (esew (if (or (null? rest) (null? (cdr rest)))
- '(eval)
- (cadr rest))))
- (with-fluid* *mode* m
- (lambda ()
- (chi-top x null-env top-wrap m esew
- (cons 'hygiene (module-name
(current-module))))))))))
-
-(set! identifier?
- (lambda (x)
- (nonsymbol-id? x)))
+ (set! sc-expand
+ (lambda (x . rest)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (let ((m (if (null? rest) 'e (car rest)))
+ (esew (if (or (null? rest) (null? (cdr rest)))
+ '(eval)
+ (cadr rest))))
+ (with-fluid* *mode* m
+ (lambda ()
+ (chi-top x null-env top-wrap m esew
+ (cons 'hygiene (module-name
(current-module))))))))))
+
+ (set! identifier?
+ (lambda (x)
+ (nonsymbol-id? x)))
-(set! datum->syntax
- (lambda (id datum)
- (make-syntax-object datum (syntax-object-wrap id) #f)))
+ (set! datum->syntax
+ (lambda (id datum)
+ (make-syntax-object datum (syntax-object-wrap id) #f)))
-(set! syntax->datum
- ; accepts any object, since syntax objects may consist partially
- ; or entirely of unwrapped, nonsymbolic data
- (lambda (x)
- (strip x empty-wrap)))
-
-(set! generate-temporaries
- (lambda (ls)
- (arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
-
-(set! free-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'free-identifier=?)
- (arg-check nonsymbol-id? y 'free-identifier=?)
- (free-id=? x y)))
-
-(set! bound-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'bound-identifier=?)
- (arg-check nonsymbol-id? y 'bound-identifier=?)
- (bound-id=? x y)))
-
-(set! syntax-violation
- (lambda (who message form . subform)
- (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
- who 'syntax-violation)
- (arg-check string? message 'syntax-violation)
- (scm-error 'syntax-error 'sc-expand
- (string-append
- (if who "~a: " "")
- "~a "
- (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
- (let ((tail (cons message
- (map (lambda (x) (strip x empty-wrap))
- (append subform (list form))))))
- (if who (cons who tail) tail))
- #f)))
+ (set! syntax->datum
+ ; accepts any object, since syntax
objects may consist partially
+ ; or entirely of unwrapped,
nonsymbolic data
+ (lambda (x)
+ (strip x empty-wrap)))
+
+ (set! generate-temporaries
+ (lambda (ls)
+ (arg-check list? ls 'generate-temporaries)
+ (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
+
+ (set! free-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y)))
+
+ (set! bound-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y)))
+
+ (set! syntax-violation
+ (lambda (who message form . subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (scm-error 'syntax-error 'sc-expand
+ (string-append
+ (if who "~a: " "")
+ "~a "
+ (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+ (let ((tail (cons message
+ (map (lambda (x) (strip x empty-wrap))
+ (append subform (list form))))))
+ (if who (cons who tail) tail))
+ #f)))
;;; $sc-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each
@@ -2468,134 +2468,134 @@
;;; not, should convert to:
;;; #(vector <pattern>*) #(<pattern>*)
-(let ()
+ (let ()
-(define match-each
- (lambda (e p w mod)
- (cond
- ((pair? e)
- (let ((first (match (car e) p w '() mod)))
- (and first
- (let ((rest (match-each (cdr e) p w mod)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))
- (syntax-object-module e)))
- (else #f))))
-
-(define match-each-any
- (lambda (e w mod)
- (cond
- ((pair? e)
- (let ((l (match-each-any (cdr e) w mod)))
- (and l (cons (wrap (car e) w mod) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
+ (define match-each
+ (lambda (e p w mod)
+ (cond
+ ((pair? e)
+ (let ((first (match (car e) p w '() mod)))
+ (and first
+ (let ((rest (match-each (cdr e) p w mod)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
(join-wraps w (syntax-object-wrap e))
- mod))
- (else #f))))
+ (syntax-object-module e)))
+ (else #f))))
-(define match-empty
- (lambda (p r)
- (cond
- ((null? p) r)
- ((eq? p 'any) (cons '() r))
- ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
- ((eq? p 'each-any) (cons '() r))
- (else
- (case (vector-ref p 0)
- ((each) (match-empty (vector-ref p 1) r))
- ((free-id atom) r)
- ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define match*
- (lambda (e p w r mod)
- (cond
- ((null? p) (and (null? e) r))
- ((pair? p)
- (and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r mod)
- mod)))
- ((eq? p 'each-any)
- (let ((l (match-each-any e w mod))) (and l (cons l r))))
- (else
- (case (vector-ref p 0)
- ((each)
- (if (null? e)
- (match-empty (vector-ref p 1) r)
- (let ((l (match-each e (vector-ref p 1) w mod)))
- (and l
- (let collect ((l l))
- (if (null? (car l))
- r
- (cons (map car l) (collect (map cdr l)))))))))
- ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1))
r))
- ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
- ((vector)
- (and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r mod))))))))
-
-(define match
- (lambda (e p w r mod)
- (cond
- ((not r) #f)
- ((eq? p 'any) (cons (wrap e w mod) r))
- ((syntax-object? e)
- (match*
- (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))
- r
- (syntax-object-module e)))
- (else (match* e p w r mod)))))
-
-(set! $sc-dispatch
- (lambda (e p)
- (cond
- ((eq? p 'any) (list e))
- ((syntax-object? e)
- (match* (syntax-object-expression e)
- p (syntax-object-wrap e) '() (syntax-object-module e)))
- (else (match* e p empty-wrap '() #f)))))
+ (define match-each-any
+ (lambda (e w mod)
+ (cond
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w mod)))
+ (and l (cons (wrap (car e) w mod) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))
+ mod))
+ (else #f))))
+
+ (define match-empty
+ (lambda (p r)
+ (cond
+ ((null? p) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (case (vector-ref p 0)
+ ((each) (match-empty (vector-ref p 1) r))
+ ((free-id atom) r)
+ ((vector) (match-empty (vector-ref p 1) r)))))))
+
+ (define match*
+ (lambda (e p w r mod)
+ (cond
+ ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e) (match (car e) (car p) w
+ (match (cdr e) (cdr p) w r mod)
+ mod)))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w mod))) (and l (cons l r))))
+ (else
+ (case (vector-ref p 0)
+ ((each)
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w mod)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l))
+ r
+ (cons (map car l) (collect (map cdr l)))))))))
+ ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p
1)) r))
+ ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((vector)
+ (and (vector? e)
+ (match (vector->list e) (vector-ref p 1) w r mod))))))))
+
+ (define match
+ (lambda (e p w r mod)
+ (cond
+ ((not r) #f)
+ ((eq? p 'any) (cons (wrap e w mod) r))
+ ((syntax-object? e)
+ (match*
+ (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r
+ (syntax-object-module e)))
+ (else (match* e p w r mod)))))
+
+ (set! $sc-dispatch
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
+ ((syntax-object? e)
+ (match* (syntax-object-expression e)
+ p (syntax-object-wrap e) '() (syntax-object-module e)))
+ (else (match* e p empty-wrap '() #f)))))
-))
+ ))
)
(define-syntax with-syntax
(lambda (x)
(syntax-case x ()
((_ () e1 e2 ...)
- (syntax (begin e1 e2 ...)))
+ #'(begin e1 e2 ...))
((_ ((out in)) e1 e2 ...)
- (syntax (syntax-case in () (out (begin e1 e2 ...)))))
+ #'(syntax-case in () (out (begin e1 e2 ...))))
((_ ((out in) ...) e1 e2 ...)
- (syntax (syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...))))))))
+ #'(syntax-case (list in ...) ()
+ ((out ...) (begin e1 e2 ...)))))))
(define-syntax syntax-rules
(lambda (x)
(syntax-case x ()
((_ (k ...) ((keyword . pattern) template) ...)
- (syntax (lambda (x)
- (syntax-case x (k ...)
- ((dummy . pattern) (syntax template))
- ...)))))))
+ #'(lambda (x)
+ (syntax-case x (k ...)
+ ((dummy . pattern) #'template)
+ ...))))))
(define-syntax let*
(lambda (x)
(syntax-case x ()
((let* ((x v) ...) e1 e2 ...)
- (and-map identifier? (syntax (x ...)))
- (let f ((bindings (syntax ((x v) ...))))
+ (and-map identifier? #'(x ...))
+ (let f ((bindings #'((x v) ...)))
(if (null? bindings)
- (syntax (let () e1 e2 ...))
+ #'(let () e1 e2 ...)
(with-syntax ((body (f (cdr bindings)))
(binding (car bindings)))
- (syntax (let (binding) body)))))))))
+ #'(let (binding) body))))))))
(define-syntax do
(lambda (orig-x)
@@ -2603,85 +2603,85 @@
((_ ((var init . step) ...) (e0 e1 ...) c ...)
(with-syntax (((step ...)
(map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) (syntax e))
- (_ (syntax-violation
- 'do "bad step expression"
- orig-x s))))
- (syntax (var ...))
- (syntax (step ...)))))
- (syntax-case (syntax (e1 ...)) ()
- (() (syntax (let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...))))))
- ((e1 e2 ...)
- (syntax (let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...))))))))))))
+ (syntax-case s ()
+ (() v)
+ ((e) #'e)
+ (_ (syntax-violation
+ 'do "bad step expression"
+ orig-x s))))
+ #'(var ...)
+ #'(step ...))))
+ (syntax-case #'(e1 ...) ()
+ (() #'(let doloop ((var init) ...)
+ (if (not e0)
+ (begin c ... (doloop step ...)))))
+ ((e1 e2 ...)
+ #'(let doloop ((var init) ...)
+ (if e0
+ (begin e1 e2 ...)
+ (begin c ... (doloop step ...)))))))))))
(define-syntax quasiquote
(letrec
((quasicons
(lambda (x y)
(with-syntax ((x x) (y y))
- (syntax-case (syntax y) (quote list)
+ (syntax-case #'y (quote list)
((quote dy)
- (syntax-case (syntax x) (quote)
- ((quote dx) (syntax (quote (dx . dy))))
- (_ (if (null? (syntax dy))
- (syntax (list x))
- (syntax (cons x y))))))
- ((list . stuff) (syntax (list x . stuff)))
- (else (syntax (cons x y)))))))
+ (syntax-case #'x (quote)
+ ((quote dx) #'(quote (dx . dy)))
+ (_ (if (null? #'dy)
+ #'(list x)
+ #'(cons x y)))))
+ ((list . stuff) #'(list x . stuff))
+ (else #'(cons x y))))))
(quasiappend
(lambda (x y)
(with-syntax ((x x) (y y))
- (syntax-case (syntax y) (quote)
- ((quote ()) (syntax x))
- (_ (syntax (append x y)))))))
+ (syntax-case #'y (quote)
+ ((quote ()) #'x)
+ (_ #'(append x y))))))
(quasivector
(lambda (x)
(with-syntax ((x x))
- (syntax-case (syntax x) (quote list)
- ((quote (x ...)) (syntax (quote #(x ...))))
- ((list x ...) (syntax (vector x ...)))
- (_ (syntax (list->vector x)))))))
+ (syntax-case #'x (quote list)
+ ((quote (x ...)) #'(quote #(x ...)))
+ ((list x ...) #'(vector x ...))
+ (_ #'(list->vector x))))))
(quasi
(lambda (p lev)
(syntax-case p (unquote unquote-splicing quasiquote)
((unquote p)
(if (= lev 0)
- (syntax p)
- (quasicons (syntax (quote unquote))
- (quasi (syntax (p)) (- lev 1)))))
+ #'p
+ (quasicons #'(quote unquote)
+ (quasi #'(p) (- lev 1)))))
((unquote . args)
(= lev 0)
(syntax-violation 'unquote
"unquote takes exactly one argument"
- p (syntax (unquote . args))))
+ p #'(unquote . args)))
(((unquote-splicing p) . q)
(if (= lev 0)
- (quasiappend (syntax p) (quasi (syntax q) lev))
- (quasicons (quasicons (syntax (quote unquote-splicing))
- (quasi (syntax (p)) (- lev 1)))
- (quasi (syntax q) lev))))
+ (quasiappend #'p (quasi #'q lev))
+ (quasicons (quasicons #'(quote unquote-splicing)
+ (quasi #'(p) (- lev 1)))
+ (quasi #'q lev))))
(((unquote-splicing . args) . q)
(= lev 0)
(syntax-violation 'unquote-splicing
"unquote-splicing takes exactly one argument"
- p (syntax (unquote-splicing . args))))
+ p #'(unquote-splicing . args)))
((quasiquote p)
- (quasicons (syntax (quote quasiquote))
- (quasi (syntax (p)) (+ lev 1))))
+ (quasicons #'(quote quasiquote)
+ (quasi #'(p) (+ lev 1))))
((p . q)
- (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
- (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
- (p (syntax (quote p)))))))
+ (quasicons (quasi #'p lev) (quasi #'q lev)))
+ (#(x ...) (quasivector (quasi #'(x ...) lev)))
+ (p #'(quote p))))))
(lambda (x)
(syntax-case x ()
- ((_ e) (quasi (syntax e) 0))))))
+ ((_ e) (quasi #'e 0))))))
(define-syntax include
(lambda (x)
@@ -2695,9 +2695,20 @@
(f (read p))))))))
(syntax-case x ()
((k filename)
- (let ((fn (syntax->datum (syntax filename))))
- (with-syntax (((exp ...) (read-file fn (syntax k))))
- (syntax (begin exp ...))))))))
+ (let ((fn (syntax->datum #'filename)))
+ (with-syntax (((exp ...) (read-file fn #'k)))
+ #'(begin exp ...)))))))
+
+(define-syntax include-from-path
+ (lambda (x)
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax->datum #'filename)))
+ (with-syntax ((fn (or (%search-load-path fn)
+ (syntax-violation 'include-from-path
+ "file not found in path"
+ x #'filename))))
+ #'(include fn)))))))
(define-syntax unquote
(lambda (x)
@@ -2720,35 +2731,34 @@
(syntax-case x ()
((_ e m1 m2 ...)
(with-syntax
- ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-violation 'case "bad clause" x clause)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
+ (if (null? clauses)
(syntax-case clause (else)
+ ((else e1 e2 ...) #'(begin e1 e2 ...))
(((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...))
- (begin e1 e2 ...)
- rest)))
- (_ (syntax-violation 'case "bad clause" x
- clause))))))))
- (syntax (let ((t e)) body)))))))
+ #'(if (memv t '(k ...)) (begin e1 e2 ...)))
+ (_ (syntax-violation 'case "bad clause" x clause)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else)
+ (((k ...) e1 e2 ...)
+ #'(if (memv t '(k ...))
+ (begin e1 e2 ...)
+ rest))
+ (_ (syntax-violation 'case "bad clause" x
+ clause))))))))
+ #'(let ((t e)) body))))))
(define-syntax identifier-syntax
(lambda (x)
(syntax-case x ()
((_ e)
- (syntax
- (lambda (x)
+ #'(lambda (x)
(syntax-case x ()
(id
- (identifier? (syntax id))
- (syntax e))
+ (identifier? #'id)
+ #'e)
((_ x (... ...))
- (syntax (e x (... ...)))))))))))
+ #'(e x (... ...)))))))))
(define-syntax define*
(syntax-rules ()
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-4-106-gd89fae2,
Andy Wingo <=