mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Psyntax generates new syntax objects
* module/ice-9/psyntax.scm (make-syntax-object): Change to make new-style syntax objects. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/compile-psyntax.scm (squeeze-syntax-object): Change to be functional. (squeeze-constant): Likewise. (squeeze-tree-il): Likewise. (translate-literal-syntax-objects): New pass. The compiler can embed literal syntax objects into compiled objects, but syntax can no longer be read/written; otherwise users could forge syntax objects. So for the bootstrap phase, rewrite literal constants to calls to make-syntax.
This commit is contained in:
Andy Wingo
parent
eb84c2f2da
commit
a42bfae65f
3 changed files with 950 additions and 857 deletions
|
|
@ -20,67 +20,132 @@
|
|||
(language tree-il primitives)
|
||||
(language tree-il canonicalize)
|
||||
(srfi srfi-1)
|
||||
(ice-9 control)
|
||||
(ice-9 pretty-print)
|
||||
(system syntax))
|
||||
(system syntax internal))
|
||||
|
||||
;; Minimize a syntax-object such that it can no longer be used as the
|
||||
;; first argument to 'datum->syntax', but is otherwise equivalent.
|
||||
(define (squeeze-syntax-object! syn)
|
||||
(define (squeeze-syntax-object syn)
|
||||
(define (ensure-list x) (if (vector? x) (vector->list x) x))
|
||||
(let ((x (vector-ref syn 1))
|
||||
(wrap (vector-ref syn 2))
|
||||
(mod (vector-ref syn 3)))
|
||||
(let ((x (syntax-expression syn))
|
||||
(wrap (syntax-wrap syn))
|
||||
(mod (syntax-module syn)))
|
||||
(let ((marks (car wrap))
|
||||
(subst (cdr wrap)))
|
||||
(define (set-wrap! marks subst)
|
||||
(vector-set! syn 2 (cons marks subst)))
|
||||
(define (squeeze-wrap marks subst)
|
||||
(make-syntax x (cons marks subst) mod))
|
||||
(cond
|
||||
((symbol? x)
|
||||
(let loop ((marks marks) (subst subst))
|
||||
(cond
|
||||
((null? subst) (set-wrap! marks subst) syn)
|
||||
((null? subst) (squeeze-wrap marks subst))
|
||||
((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
|
||||
((find (lambda (entry) (and (eq? x (car entry))
|
||||
(equal? marks (cadr entry))))
|
||||
(apply map list (map ensure-list
|
||||
(cdr (vector->list (car subst))))))
|
||||
=> (lambda (entry)
|
||||
(set-wrap! marks
|
||||
(squeeze-wrap marks
|
||||
(list (list->vector
|
||||
(cons 'ribcage
|
||||
(map vector entry)))))
|
||||
syn))
|
||||
(map vector entry)))))))
|
||||
(else (loop marks (cdr subst))))))
|
||||
((or (pair? x) (vector? x))
|
||||
syn)
|
||||
((or (pair? x) (vector? x)) syn)
|
||||
(else x)))))
|
||||
|
||||
(define (squeeze-constant! x)
|
||||
(define (syntax-object? x)
|
||||
(and (vector? x)
|
||||
(= 4 (vector-length x))
|
||||
(eq? 'syntax-object (vector-ref x 0))))
|
||||
(cond ((syntax-object? x)
|
||||
(squeeze-syntax-object! x))
|
||||
(define (squeeze-constant x)
|
||||
(cond ((syntax? x) (squeeze-syntax-object x))
|
||||
((pair? x)
|
||||
(set-car! x (squeeze-constant! (car x)))
|
||||
(set-cdr! x (squeeze-constant! (cdr x)))
|
||||
x)
|
||||
(cons (squeeze-constant (car x))
|
||||
(squeeze-constant (cdr x))))
|
||||
((vector? x)
|
||||
(for-each (lambda (i)
|
||||
(vector-set! x i (squeeze-constant! (vector-ref x i))))
|
||||
(iota (vector-length x)))
|
||||
x)
|
||||
(list->vector (squeeze-constant (vector->list x))))
|
||||
(else x)))
|
||||
|
||||
(define (squeeze-tree-il x)
|
||||
(post-order (lambda (x)
|
||||
(if (const? x)
|
||||
(make-const (const-src x)
|
||||
(squeeze-constant! (const-exp x)))
|
||||
(squeeze-constant (const-exp x)))
|
||||
x))
|
||||
x))
|
||||
|
||||
(define (translate-literal-syntax-objects x)
|
||||
(define (find-make-syntax-lexical-binding x)
|
||||
(let/ec return
|
||||
(pre-order (lambda (x)
|
||||
(when (let? x)
|
||||
(for-each (lambda (name sym)
|
||||
(when (eq? name 'make-syntax)
|
||||
(return sym)))
|
||||
(let-names x) (let-gensyms x)))
|
||||
x)
|
||||
x)
|
||||
#f))
|
||||
(let ((make-syntax-gensym (find-make-syntax-lexical-binding x))
|
||||
(retry-tag (make-prompt-tag)))
|
||||
(define (translate-constant x)
|
||||
(let ((src (const-src x))
|
||||
(exp (const-exp x)))
|
||||
(cond
|
||||
((list? exp)
|
||||
(let ((exp (map (lambda (x)
|
||||
(translate-constant (make-const src x)))
|
||||
exp)))
|
||||
(if (and-map const? exp)
|
||||
x
|
||||
(make-primcall src 'list exp))))
|
||||
((pair? exp)
|
||||
(let ((car (translate-constant (make-const src (car exp))))
|
||||
(cdr (translate-constant (make-const src (cdr exp)))))
|
||||
(if (and (const? car) (const? cdr))
|
||||
x
|
||||
(make-primcall src 'cons (list car cdr)))))
|
||||
((vector? exp)
|
||||
(let ((exp (map (lambda (x)
|
||||
(translate-constant (make-const src x)))
|
||||
(vector->list exp))))
|
||||
(if (and-map const? exp)
|
||||
x
|
||||
(make-primcall src 'vector exp))))
|
||||
((syntax? exp)
|
||||
(make-call src
|
||||
(if make-syntax-gensym
|
||||
(make-lexical-ref src 'make-syntax
|
||||
make-syntax-gensym)
|
||||
(abort-to-prompt retry-tag))
|
||||
(list
|
||||
(translate-constant
|
||||
(make-const src (syntax-expression exp)))
|
||||
(translate-constant
|
||||
(make-const src (syntax-wrap exp)))
|
||||
(translate-constant
|
||||
(make-const src (syntax-module exp))))))
|
||||
(else x))))
|
||||
(call-with-prompt retry-tag
|
||||
(lambda ()
|
||||
(post-order (lambda (x)
|
||||
(if (const? x)
|
||||
(translate-constant x)
|
||||
x))
|
||||
x))
|
||||
(lambda (k)
|
||||
;; OK, we have a syntax object embedded in this code, but
|
||||
;; make-syntax isn't lexically bound. This is the case for the
|
||||
;; top-level macro definitions in psyntax that follow the main
|
||||
;; let blob. Attach a lexical binding and retry.
|
||||
(unless (toplevel-define? x) (error "unexpected"))
|
||||
(translate-literal-syntax-objects
|
||||
(make-toplevel-define
|
||||
(toplevel-define-src x)
|
||||
(toplevel-define-name x)
|
||||
(make-let (toplevel-define-src x)
|
||||
(list 'make-syntax)
|
||||
(list (module-gensym))
|
||||
(list (make-toplevel-ref #f 'make-syntax))
|
||||
(toplevel-define-exp x))))))))
|
||||
|
||||
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
|
||||
;; changing session identifiers.
|
||||
(set! syntax-session-id (lambda () "*"))
|
||||
|
|
@ -99,11 +164,12 @@
|
|||
(close-port in))
|
||||
(begin
|
||||
(pretty-print (tree-il->scheme
|
||||
(translate-literal-syntax-objects
|
||||
(squeeze-tree-il
|
||||
(canonicalize
|
||||
(resolve-primitives
|
||||
(macroexpand x 'c '(compile load eval))
|
||||
(current-module))))
|
||||
(current-module)))))
|
||||
(current-module)
|
||||
(list #:avoid-lambda? #f
|
||||
#:use-case? #f
|
||||
|
|
|
|||
|
|
@ -246,7 +246,7 @@
|
|||
(eqv? (vector-ref x 0) 'syntax-object)))))
|
||||
(make-syntax-object
|
||||
(lambda (expression wrap module)
|
||||
(vector 'syntax-object expression wrap module)))
|
||||
(make-syntax expression wrap module)))
|
||||
(syntax-object-expression
|
||||
(lambda (obj)
|
||||
(if (syntax? obj) (syntax-expression obj) (vector-ref obj 1))))
|
||||
|
|
@ -792,7 +792,7 @@
|
|||
(wrap name w mod)
|
||||
(wrap e w mod)
|
||||
(decorate-source
|
||||
(cons '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'lambda '((top)) '(hygiene guile))
|
||||
(wrap (cons args (cons e1 e2)) w mod))
|
||||
s)
|
||||
'(())
|
||||
|
|
@ -806,7 +806,7 @@
|
|||
'define-form
|
||||
(wrap name w mod)
|
||||
(wrap e w mod)
|
||||
'(#(syntax-object if ((top)) (hygiene guile)) #f #f)
|
||||
(list (make-syntax 'if '((top)) '(hygiene guile)) #f #f)
|
||||
'(())
|
||||
s
|
||||
mod))
|
||||
|
|
@ -1174,7 +1174,7 @@
|
|||
(lambda (type value mod)
|
||||
(if (eq? type 'ellipsis)
|
||||
(bound-id=? e value)
|
||||
(free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))))
|
||||
(free-id=? e (make-syntax '... '((top)) '(hygiene guile)))))))))
|
||||
(lambda-formals
|
||||
(lambda (orig-args)
|
||||
(letrec*
|
||||
|
|
@ -2067,7 +2067,7 @@
|
|||
(build-call
|
||||
s
|
||||
(expand
|
||||
(list '#(syntax-object setter ((top)) (hygiene guile)) head)
|
||||
(list (make-syntax 'setter '((top)) '(hygiene guile)) head)
|
||||
r
|
||||
w
|
||||
mod)
|
||||
|
|
@ -2088,7 +2088,7 @@
|
|||
'((top))
|
||||
#f
|
||||
(syntax->datum
|
||||
(cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
|
||||
(cons (make-syntax 'public '((top)) '(hygiene guile)) mod))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -2119,7 +2119,9 @@
|
|||
(let* ((tmp e)
|
||||
(tmp-1 ($sc-dispatch
|
||||
tmp
|
||||
'(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any))))
|
||||
(list '_
|
||||
(vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile)))
|
||||
'any))))
|
||||
(if (and tmp-1
|
||||
(apply (lambda (id)
|
||||
(and (id? id)
|
||||
|
|
@ -2139,17 +2141,18 @@
|
|||
'((top))
|
||||
#f
|
||||
(syntax->datum
|
||||
(cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
|
||||
(cons (make-syntax 'private '((top)) '(hygiene guile)) mod))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch
|
||||
tmp
|
||||
'(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
|
||||
each-any
|
||||
any))))
|
||||
(list '_
|
||||
(vector 'free-id (make-syntax '@@ '((top)) '(hygiene guile)))
|
||||
'each-any
|
||||
'any))))
|
||||
(if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1))
|
||||
(apply (lambda (mod exp)
|
||||
(let ((mod (syntax->datum
|
||||
(cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
|
||||
(cons (make-syntax 'private '((top)) '(hygiene guile)) mod))))
|
||||
(values (remodulate exp mod) r w (source-annotation exp) mod)))
|
||||
tmp-1)
|
||||
(syntax-violation
|
||||
|
|
@ -2213,7 +2216,7 @@
|
|||
(cvt (lambda (p n ids)
|
||||
(if (id? p)
|
||||
(cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
|
||||
((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
|
||||
((free-id=? p (make-syntax '_ '((top)) '(hygiene guile)))
|
||||
(values '_ ids))
|
||||
(else (values 'any (cons (cons p n) ids))))
|
||||
(let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
|
||||
|
|
@ -2334,8 +2337,8 @@
|
|||
(if (and (id? pat)
|
||||
(and-map
|
||||
(lambda (x) (not (free-id=? pat x)))
|
||||
(cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
|
||||
(if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
|
||||
(cons (make-syntax '... '((top)) '(hygiene guile)) keys)))
|
||||
(if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile)))
|
||||
(expand exp r '(()) mod)
|
||||
(let ((labels (list (gen-label))) (var (gen-var pat)))
|
||||
(build-call
|
||||
|
|
@ -2644,6 +2647,7 @@
|
|||
(else (match* e p '(()) '() #f))))))))
|
||||
|
||||
(define with-syntax
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'with-syntax
|
||||
'macro
|
||||
|
|
@ -2652,35 +2656,36 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (e1 e2)
|
||||
(cons '#(syntax-object let ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'let '((top)) '(hygiene guile))
|
||||
(cons '() (cons e1 e2))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (out in e1 e2)
|
||||
(list '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
(list (make-syntax 'syntax-case '((top)) '(hygiene guile))
|
||||
in
|
||||
'()
|
||||
(list out
|
||||
(cons '#(syntax-object let ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'let '((top)) '(hygiene guile))
|
||||
(cons '() (cons e1 e2))))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (out in e1 e2)
|
||||
(list '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object list ((top)) (hygiene guile)) in)
|
||||
(list (make-syntax 'syntax-case '((top)) '(hygiene guile))
|
||||
(cons (make-syntax 'list '((top)) '(hygiene guile)) in)
|
||||
'()
|
||||
(list out
|
||||
(cons '#(syntax-object let ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'let '((top)) '(hygiene guile))
|
||||
(cons '() (cons e1 e2))))))
|
||||
tmp-1)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp)))))))))))
|
||||
tmp))))))))))))
|
||||
|
||||
(define syntax-error
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'syntax-error
|
||||
'macro
|
||||
|
|
@ -2705,24 +2710,26 @@
|
|||
(apply (lambda (message arg) (string? (syntax->datum message))) tmp)
|
||||
#f)
|
||||
(apply (lambda (message arg)
|
||||
(cons '#(syntax-object
|
||||
syntax-error
|
||||
((top)
|
||||
#(ribcage
|
||||
#(syntax-error)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object syntax-error ((top)) (hygiene guile))))))
|
||||
(hygiene guile))
|
||||
(cons (make-syntax
|
||||
'syntax-error
|
||||
(list '(top)
|
||||
(vector
|
||||
'ribcage
|
||||
'#(syntax-error)
|
||||
'#((top))
|
||||
(vector
|
||||
(cons '(hygiene guile)
|
||||
(make-syntax 'syntax-error '((top)) '(hygiene guile))))))
|
||||
'(hygiene guile))
|
||||
(cons '(#f) (cons message arg))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))))
|
||||
tmp-1))))))))))
|
||||
|
||||
(define syntax-rules
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'syntax-rules
|
||||
'macro
|
||||
|
|
@ -2733,28 +2740,28 @@
|
|||
(let ((tmp-1 clause))
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'((any . any)
|
||||
(#(free-id #(syntax-object syntax-error ((top)) (hygiene guile)))
|
||||
any
|
||||
.
|
||||
each-any)))))
|
||||
(list '(any . any)
|
||||
(cons (vector
|
||||
'free-id
|
||||
(make-syntax 'syntax-error '((top)) '(hygiene guile)))
|
||||
'(any . each-any))))))
|
||||
(if (if tmp
|
||||
(apply (lambda (keyword pattern message arg)
|
||||
(string? (syntax->datum message)))
|
||||
tmp)
|
||||
#f)
|
||||
(apply (lambda (keyword pattern message arg)
|
||||
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object syntax-error ((top)) (hygiene guile))
|
||||
(cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
|
||||
(list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile))
|
||||
(cons (make-syntax 'syntax-error '((top)) '(hygiene guile))
|
||||
(cons (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
|
||||
(cons message arg))))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
|
||||
(if tmp
|
||||
(apply (lambda (keyword pattern template)
|
||||
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile)) template)))
|
||||
(list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile)) template)))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -2768,36 +2775,36 @@
|
|||
'(each-any each-any #(each ((any . any) any)) each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (k docstring keyword pattern template clause)
|
||||
(let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
(cons '(#(syntax-object x ((top)) (hygiene guile)))
|
||||
(let ((tmp (cons (make-syntax 'lambda '((top)) '(hygiene guile))
|
||||
(cons (list (make-syntax 'x '((top)) '(hygiene guile)))
|
||||
(append
|
||||
docstring
|
||||
(list (vector
|
||||
'(#(syntax-object macro-type ((top)) (hygiene guile))
|
||||
.
|
||||
#(syntax-object
|
||||
syntax-rules
|
||||
((top)
|
||||
#(ribcage
|
||||
#(syntax-rules)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object
|
||||
syntax-rules
|
||||
((top))
|
||||
(hygiene guile))))))
|
||||
(hygiene guile)))
|
||||
(cons '#(syntax-object patterns ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'macro-type '((top)) '(hygiene guile))
|
||||
(make-syntax
|
||||
'syntax-rules
|
||||
(list '(top)
|
||||
(vector
|
||||
'ribcage
|
||||
'#(syntax-rules)
|
||||
'#((top))
|
||||
(vector
|
||||
(cons '(hygiene guile)
|
||||
(make-syntax
|
||||
'syntax-rules
|
||||
'((top))
|
||||
'(hygiene guile))))))
|
||||
'(hygiene guile)))
|
||||
(cons (make-syntax 'patterns '((top)) '(hygiene guile))
|
||||
pattern))
|
||||
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
(cons '#(syntax-object x ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'syntax-case '((top)) '(hygiene guile))
|
||||
(cons (make-syntax 'x '((top)) '(hygiene guile))
|
||||
(cons k clause)))))))))
|
||||
(let ((form tmp))
|
||||
(if dots
|
||||
(let ((tmp dots))
|
||||
(let ((dots tmp))
|
||||
(list '#(syntax-object with-ellipsis ((top)) (hygiene guile))
|
||||
(list (make-syntax 'with-ellipsis '((top)) '(hygiene guile))
|
||||
dots
|
||||
form)))
|
||||
form))))
|
||||
|
|
@ -2832,11 +2839,9 @@
|
|||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-116f
|
||||
tmp-680b775fb37a463-116e
|
||||
tmp-680b775fb37a463-116d)
|
||||
(list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e)
|
||||
tmp-680b775fb37a463-116f))
|
||||
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-116f)
|
||||
(list (cons tmp-680b775fb37a463-116f tmp-680b775fb37a463)
|
||||
tmp-680b775fb37a463-1))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2851,9 +2856,9 @@
|
|||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
tmp-680b775fb37a463-118a))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2869,11 +2874,11 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-11a7
|
||||
tmp-680b775fb37a463-11a6
|
||||
tmp-680b775fb37a463-11a5)
|
||||
(list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6)
|
||||
tmp-680b775fb37a463-11a7))
|
||||
(map (lambda (tmp-680b775fb37a463-11a9
|
||||
tmp-680b775fb37a463-11a8
|
||||
tmp-680b775fb37a463-11a7)
|
||||
(list (cons tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8)
|
||||
tmp-680b775fb37a463-11a9))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2881,9 +2886,10 @@
|
|||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp))))))))))))))
|
||||
tmp)))))))))))))))
|
||||
|
||||
(define define-syntax-rule
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'define-syntax-rule
|
||||
'macro
|
||||
|
|
@ -2892,11 +2898,11 @@
|
|||
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
|
||||
(if tmp
|
||||
(apply (lambda (name pattern template)
|
||||
(list '#(syntax-object define-syntax ((top)) (hygiene guile))
|
||||
(list (make-syntax 'define-syntax '((top)) '(hygiene guile))
|
||||
name
|
||||
(list '#(syntax-object syntax-rules ((top)) (hygiene guile))
|
||||
(list (make-syntax 'syntax-rules '((top)) '(hygiene guile))
|
||||
'()
|
||||
(list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
|
||||
(list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern)
|
||||
template))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
|
||||
|
|
@ -2906,20 +2912,21 @@
|
|||
tmp)
|
||||
#f)
|
||||
(apply (lambda (name pattern docstring template)
|
||||
(list '#(syntax-object define-syntax ((top)) (hygiene guile))
|
||||
(list (make-syntax 'define-syntax '((top)) '(hygiene guile))
|
||||
name
|
||||
(list '#(syntax-object syntax-rules ((top)) (hygiene guile))
|
||||
(list (make-syntax 'syntax-rules '((top)) '(hygiene guile))
|
||||
'()
|
||||
docstring
|
||||
(list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
|
||||
(list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern)
|
||||
template))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))))
|
||||
tmp-1))))))))))
|
||||
|
||||
(define let*
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'let*
|
||||
'macro
|
||||
|
|
@ -2932,13 +2939,13 @@
|
|||
(apply (lambda (let* x v e1 e2)
|
||||
(let f ((bindings (map list x v)))
|
||||
(if (null? bindings)
|
||||
(cons '#(syntax-object let ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'let '((top)) '(hygiene guile))
|
||||
(cons '() (cons e1 e2)))
|
||||
(let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||
(if tmp
|
||||
(apply (lambda (body binding)
|
||||
(list '#(syntax-object let ((top)) (hygiene guile))
|
||||
(list (make-syntax 'let '((top)) '(hygiene guile))
|
||||
(list binding)
|
||||
body))
|
||||
tmp)
|
||||
|
|
@ -2950,9 +2957,10 @@
|
|||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))
|
||||
tmp-1))))))))
|
||||
|
||||
(define quasiquote
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'quasiquote
|
||||
'macro
|
||||
|
|
@ -2961,43 +2969,47 @@
|
|||
(let ((tmp p))
|
||||
(let ((tmp-1 ($sc-dispatch
|
||||
tmp
|
||||
'(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
|
||||
(list (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile)))
|
||||
'any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(list "value" p)
|
||||
(quasicons
|
||||
'("quote" #(syntax-object unquote ((top)) (hygiene guile)))
|
||||
(list "quote" (make-syntax 'unquote '((top)) '(hygiene guile)))
|
||||
(quasi (list p) (- lev 1)))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch
|
||||
tmp
|
||||
'(#(free-id
|
||||
#(syntax-object
|
||||
quasiquote
|
||||
((top)
|
||||
#(ribcage
|
||||
#(quasiquote)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object quasiquote ((top)) (hygiene guile))))))
|
||||
(hygiene guile)))
|
||||
any))))
|
||||
(list (vector
|
||||
'free-id
|
||||
(make-syntax
|
||||
'quasiquote
|
||||
(list '(top)
|
||||
(vector
|
||||
'ribcage
|
||||
'#(quasiquote)
|
||||
'#((top))
|
||||
(vector
|
||||
(cons '(hygiene guile)
|
||||
(make-syntax 'quasiquote '((top)) '(hygiene guile))))))
|
||||
'(hygiene guile)))
|
||||
'any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (p)
|
||||
(quasicons
|
||||
'("quote"
|
||||
#(syntax-object
|
||||
quasiquote
|
||||
((top)
|
||||
#(ribcage
|
||||
#(quasiquote)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object quasiquote ((top)) (hygiene guile))))))
|
||||
(hygiene guile)))
|
||||
(list "quote"
|
||||
(make-syntax
|
||||
'quasiquote
|
||||
(list '(top)
|
||||
(vector
|
||||
'ribcage
|
||||
'#(quasiquote)
|
||||
'#((top))
|
||||
(vector
|
||||
(cons '(hygiene guile)
|
||||
(make-syntax 'quasiquote '((top)) '(hygiene guile))))))
|
||||
'(hygiene guile)))
|
||||
(quasi (list p) (+ lev 1))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(any . any))))
|
||||
|
|
@ -3006,29 +3018,34 @@
|
|||
(let ((tmp-1 p))
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
|
||||
.
|
||||
each-any))))
|
||||
(cons (vector
|
||||
'free-id
|
||||
(make-syntax 'unquote '((top)) '(hygiene guile)))
|
||||
'each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463-120f)
|
||||
(list "value" tmp-680b775fb37a463-120f))
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
'("quote" #(syntax-object unquote ((top)) (hygiene guile)))
|
||||
(list "quote"
|
||||
(make-syntax 'unquote '((top)) '(hygiene guile)))
|
||||
(quasi p (- lev 1)))
|
||||
(quasi q lev))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'(#(free-id
|
||||
#(syntax-object unquote-splicing ((top)) (hygiene guile)))
|
||||
.
|
||||
each-any))))
|
||||
(cons (vector
|
||||
'free-id
|
||||
(make-syntax
|
||||
'unquote-splicing
|
||||
'((top))
|
||||
'(hygiene guile)))
|
||||
'each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
|
|
@ -3039,11 +3056,11 @@
|
|||
(quasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
'("quote"
|
||||
#(syntax-object
|
||||
unquote-splicing
|
||||
((top))
|
||||
(hygiene guile)))
|
||||
(list "quote"
|
||||
(make-syntax
|
||||
'unquote-splicing
|
||||
'((top))
|
||||
'(hygiene guile)))
|
||||
(quasi p (- lev 1)))
|
||||
(quasi q lev))))
|
||||
tmp)
|
||||
|
|
@ -3062,39 +3079,40 @@
|
|||
(let ((tmp-1 p))
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
|
||||
.
|
||||
each-any))))
|
||||
(cons (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile)))
|
||||
'each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463-122a)
|
||||
(list "value" tmp-680b775fb37a463-122a))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
'("quote" #(syntax-object unquote ((top)) (hygiene guile)))
|
||||
(quasi p (- lev 1)))
|
||||
(vquasi q lev))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
|
||||
.
|
||||
each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463-122f)
|
||||
(list "value" tmp-680b775fb37a463-122f))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
'("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
|
||||
(list "quote" (make-syntax 'unquote '((top)) '(hygiene guile)))
|
||||
(quasi p (- lev 1)))
|
||||
(vquasi q lev))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
(cons (vector
|
||||
'free-id
|
||||
(make-syntax 'unquote-splicing '((top)) '(hygiene guile)))
|
||||
'each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
(quasicons
|
||||
(list "quote"
|
||||
(make-syntax 'unquote-splicing '((top)) '(hygiene guile)))
|
||||
(quasi p (- lev 1)))
|
||||
(vquasi q lev))))
|
||||
tmp)
|
||||
|
|
@ -3178,7 +3196,8 @@
|
|||
(let ((tmp-1 ls))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
|
||||
(apply (lambda (t-680b775fb37a463-127d)
|
||||
(cons "vector" t-680b775fb37a463-127d))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3205,7 +3224,7 @@
|
|||
(let ((tmp x))
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
|
||||
(apply (lambda (x) (list (make-syntax 'quote '((top)) '(hygiene guile)) x))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
|
||||
(if tmp-1
|
||||
|
|
@ -3213,9 +3232,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12a2)
|
||||
(cons '#(syntax-object list ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12a2))
|
||||
(apply (lambda (t-680b775fb37a463-12a7)
|
||||
(cons (make-syntax 'list '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12a7))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3231,10 +3250,10 @@
|
|||
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12b6 t-680b775fb37a463-12b5)
|
||||
(list '#(syntax-object cons ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12b6
|
||||
t-680b775fb37a463-12b5))
|
||||
(apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba)
|
||||
(list (make-syntax 'cons '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12bb
|
||||
t-680b775fb37a463-12ba))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3247,9 +3266,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12c2)
|
||||
(cons '#(syntax-object append ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12c2))
|
||||
(apply (lambda (t-680b775fb37a463-12c7)
|
||||
(cons (make-syntax 'append '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12c7))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3262,9 +3281,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12ce)
|
||||
(cons '#(syntax-object vector ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12ce))
|
||||
(apply (lambda (t-680b775fb37a463-12d3)
|
||||
(cons (make-syntax 'vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12d3))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3275,9 +3294,9 @@
|
|||
(if tmp-1
|
||||
(apply (lambda (x)
|
||||
(let ((tmp (emit x)))
|
||||
(let ((t-680b775fb37a463-12da tmp))
|
||||
(list '#(syntax-object list->vector ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12da))))
|
||||
(let ((t-680b775fb37a463-12df tmp))
|
||||
(list (make-syntax 'list->vector '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-12df))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
||||
(if tmp-1
|
||||
|
|
@ -3294,9 +3313,10 @@
|
|||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1))))))))
|
||||
tmp-1)))))))))
|
||||
|
||||
(define include
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'include
|
||||
'macro
|
||||
|
|
@ -3331,7 +3351,7 @@
|
|||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (exp)
|
||||
(cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
|
||||
(cons (make-syntax 'begin '((top)) '(hygiene guile)) exp))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3341,9 +3361,10 @@
|
|||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))))))
|
||||
tmp-1))))))))))))
|
||||
|
||||
(define include-from-path
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'include-from-path
|
||||
'macro
|
||||
|
|
@ -3365,12 +3386,12 @@
|
|||
x
|
||||
filename)))))))
|
||||
(let ((fn tmp))
|
||||
(list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
|
||||
(list (make-syntax 'include '((top)) '(hygiene guile)) fn)))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))
|
||||
tmp-1))))))))
|
||||
|
||||
(define unquote
|
||||
(make-syntax-transformer
|
||||
|
|
@ -3401,6 +3422,7 @@
|
|||
(error "variable transformer not a procedure" proc))))
|
||||
|
||||
(define identifier-syntax
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'identifier-syntax
|
||||
'macro
|
||||
|
|
@ -3409,76 +3431,81 @@
|
|||
(let ((tmp ($sc-dispatch tmp-1 '(_ any))))
|
||||
(if tmp
|
||||
(apply (lambda (e)
|
||||
(list '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
'(#(syntax-object x ((top)) (hygiene guile)))
|
||||
'#((#(syntax-object macro-type ((top)) (hygiene guile))
|
||||
.
|
||||
#(syntax-object
|
||||
identifier-syntax
|
||||
((top)
|
||||
#(ribcage
|
||||
#(identifier-syntax)
|
||||
#((top))
|
||||
#(((hygiene guile)
|
||||
.
|
||||
#(syntax-object identifier-syntax ((top)) (hygiene guile))))))
|
||||
(hygiene guile))))
|
||||
(list '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
'#(syntax-object x ((top)) (hygiene guile))
|
||||
(list (make-syntax 'lambda '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'x '((top)) '(hygiene guile)))
|
||||
(vector
|
||||
(cons (make-syntax 'macro-type '((top)) '(hygiene guile))
|
||||
(make-syntax
|
||||
'identifier-syntax
|
||||
(list '(top)
|
||||
(vector
|
||||
'ribcage
|
||||
'#(identifier-syntax)
|
||||
'#((top))
|
||||
(vector
|
||||
(cons '(hygiene guile)
|
||||
(make-syntax 'identifier-syntax '((top)) '(hygiene guile))))))
|
||||
'(hygiene guile))))
|
||||
(list (make-syntax 'syntax-case '((top)) '(hygiene guile))
|
||||
(make-syntax 'x '((top)) '(hygiene guile))
|
||||
'()
|
||||
(list '#(syntax-object id ((top)) (hygiene guile))
|
||||
'(#(syntax-object identifier? ((top)) (hygiene guile))
|
||||
(#(syntax-object syntax ((top)) (hygiene guile))
|
||||
#(syntax-object id ((top)) (hygiene guile))))
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile)) e))
|
||||
(list '(#(syntax-object _ ((top)) (hygiene guile))
|
||||
#(syntax-object x ((top)) (hygiene guile))
|
||||
#(syntax-object ... ((top)) (hygiene guile)))
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile))
|
||||
(list (make-syntax 'id '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'identifier? '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile))
|
||||
(make-syntax 'id '((top)) '(hygiene guile))))
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile)) e))
|
||||
(list (list (make-syntax '_ '((top)) '(hygiene guile))
|
||||
(make-syntax 'x '((top)) '(hygiene guile))
|
||||
(make-syntax '... '((top)) '(hygiene guile)))
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile))
|
||||
(cons e
|
||||
'(#(syntax-object x ((top)) (hygiene guile))
|
||||
#(syntax-object ... ((top)) (hygiene guile)))))))))
|
||||
(list (make-syntax 'x '((top)) '(hygiene guile))
|
||||
(make-syntax '... '((top)) '(hygiene guile)))))))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch
|
||||
tmp-1
|
||||
'(_ (any any)
|
||||
((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
|
||||
any)))))
|
||||
(list '_
|
||||
'(any any)
|
||||
(list (list (vector 'free-id (make-syntax 'set! '((top)) '(hygiene guile)))
|
||||
'any
|
||||
'any)
|
||||
'any)))))
|
||||
(if (if tmp
|
||||
(apply (lambda (id exp1 var val exp2)
|
||||
(if (identifier? id) (identifier? var) #f))
|
||||
tmp)
|
||||
#f)
|
||||
(apply (lambda (id exp1 var val exp2)
|
||||
(list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
|
||||
(list '#(syntax-object lambda ((top)) (hygiene guile))
|
||||
'(#(syntax-object x ((top)) (hygiene guile)))
|
||||
'#((#(syntax-object macro-type ((top)) (hygiene guile))
|
||||
.
|
||||
#(syntax-object variable-transformer ((top)) (hygiene guile))))
|
||||
(list '#(syntax-object syntax-case ((top)) (hygiene guile))
|
||||
'#(syntax-object x ((top)) (hygiene guile))
|
||||
'(#(syntax-object set! ((top)) (hygiene guile)))
|
||||
(list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
|
||||
(list (make-syntax 'make-variable-transformer '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'lambda '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'x '((top)) '(hygiene guile)))
|
||||
(vector
|
||||
(cons (make-syntax 'macro-type '((top)) '(hygiene guile))
|
||||
(make-syntax 'variable-transformer '((top)) '(hygiene guile))))
|
||||
(list (make-syntax 'syntax-case '((top)) '(hygiene guile))
|
||||
(make-syntax 'x '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'set! '((top)) '(hygiene guile)))
|
||||
(list (list (make-syntax 'set! '((top)) '(hygiene guile)) var val)
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile)) exp2))
|
||||
(list (cons id
|
||||
'(#(syntax-object x ((top)) (hygiene guile))
|
||||
#(syntax-object ... ((top)) (hygiene guile))))
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile))
|
||||
(list (make-syntax 'x '((top)) '(hygiene guile))
|
||||
(make-syntax '... '((top)) '(hygiene guile))))
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile))
|
||||
(cons exp1
|
||||
'(#(syntax-object x ((top)) (hygiene guile))
|
||||
#(syntax-object ... ((top)) (hygiene guile))))))
|
||||
(list (make-syntax 'x '((top)) '(hygiene guile))
|
||||
(make-syntax '... '((top)) '(hygiene guile))))))
|
||||
(list id
|
||||
(list '#(syntax-object identifier? ((top)) (hygiene guile))
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile)) id))
|
||||
(list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
|
||||
(list (make-syntax 'identifier? '((top)) '(hygiene guile))
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile)) id))
|
||||
(list (make-syntax 'syntax '((top)) '(hygiene guile)) exp1))))))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))))
|
||||
tmp-1))))))))))
|
||||
|
||||
(define define*
|
||||
(let ((make-syntax make-syntax))
|
||||
(make-syntax-transformer
|
||||
'define*
|
||||
'macro
|
||||
|
|
@ -3487,18 +3514,18 @@
|
|||
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
|
||||
(if tmp
|
||||
(apply (lambda (id args b0 b1)
|
||||
(list '#(syntax-object define ((top)) (hygiene guile))
|
||||
(list (make-syntax 'define '((top)) '(hygiene guile))
|
||||
id
|
||||
(cons '#(syntax-object lambda* ((top)) (hygiene guile))
|
||||
(cons (make-syntax 'lambda* '((top)) '(hygiene guile))
|
||||
(cons args (cons b0 b1)))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
|
||||
(if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
|
||||
(apply (lambda (id val)
|
||||
(list '#(syntax-object define ((top)) (hygiene guile)) id val))
|
||||
(list (make-syntax 'define '((top)) '(hygiene guile)) id val))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
"source expression failed to match any pattern"
|
||||
tmp-1)))))))))
|
||||
tmp-1))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -477,7 +477,7 @@
|
|||
(= (vector-length x) 4)
|
||||
(eqv? (vector-ref x 0) 'syntax-object))))
|
||||
(define (make-syntax-object expression wrap module)
|
||||
(vector 'syntax-object expression wrap module))
|
||||
(make-syntax expression wrap module))
|
||||
(define (syntax-object-expression obj)
|
||||
(if (syntax? obj)
|
||||
(syntax-expression obj)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue