mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 19:50:24 +02:00
psyntax.scm uses #' shorthand for (syntax ...)
* module/ice-9/psyntax.scm: Convert to use #'.
This commit is contained in:
Andy Wingo
parent
ee2a69f565
commit
c3ae0ed441
1 changed files with 2043 additions and 2044 deletions
|
|
@ -239,25 +239,25 @@
|
|||
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) "?"))
|
||||
((constructor (construct-name #'name "make-" #'name))
|
||||
(predicate (construct-name #'name #'name "?"))
|
||||
((access ...)
|
||||
(map (lambda (x) (construct-name x (syntax name) "-" x))
|
||||
(syntax (id1 ...))))
|
||||
(map (lambda (x) (construct-name x #'name "-" x))
|
||||
#'(id1 ...)))
|
||||
((assign ...)
|
||||
(map (lambda (x)
|
||||
(construct-name x "set-" (syntax name) "-" x "!"))
|
||||
(syntax (id1 ...))))
|
||||
(construct-name x "set-" #'name "-" x "!"))
|
||||
#'(id1 ...)))
|
||||
(structure-length
|
||||
(+ (length (syntax (id1 ...))) 1))
|
||||
(+ (length #'(id1 ...)) 1))
|
||||
((index ...)
|
||||
(let f ((i 1) (ids (syntax (id1 ...))))
|
||||
(let f ((i 1) (ids #'(id1 ...)))
|
||||
(if (null? ids)
|
||||
'()
|
||||
(cons i (f (+ i 1) (cdr ids)))))))
|
||||
(syntax (begin
|
||||
#'(begin
|
||||
(define constructor
|
||||
(lambda (id1 ...)
|
||||
(vector 'name id1 ... )))
|
||||
|
|
@ -273,7 +273,7 @@
|
|||
(define assign
|
||||
(lambda (x update)
|
||||
(vector-set! x index update)))
|
||||
...)))))))
|
||||
...))))))
|
||||
|
||||
(let ()
|
||||
(define noexpand "noexpand")
|
||||
|
|
@ -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
|
||||
|
|
@ -1072,9 +1072,9 @@
|
|||
(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)
|
||||
((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)))))
|
||||
|
|
@ -1164,28 +1164,28 @@
|
|||
((define)
|
||||
(syntax-case e ()
|
||||
((_ name val)
|
||||
(id? (syntax name))
|
||||
(values 'define-form (syntax name) (syntax val) w s mod))
|
||||
(id? #'name)
|
||||
(values 'define-form #'name #'val w s mod))
|
||||
((_ (name . args) e1 e2 ...)
|
||||
(and (id? (syntax name))
|
||||
(valid-bound-ids? (lambda-var-list (syntax args))))
|
||||
(and (id? #'name)
|
||||
(valid-bound-ids? (lambda-var-list #'args)))
|
||||
; need lambda here...
|
||||
(values 'define-form (wrap (syntax name) w mod)
|
||||
(values 'define-form (wrap #'name w mod)
|
||||
(decorate-source
|
||||
(cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
|
||||
(cons #'lambda (wrap #'(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))
|
||||
(id? #'name)
|
||||
(values 'define-form (wrap #'name w mod)
|
||||
#'(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))))
|
||||
(id? #'name)
|
||||
(values 'define-syntax-form #'name
|
||||
#'val w s mod))))
|
||||
(else
|
||||
(values 'call #f e w s mod)))))))
|
||||
((syntax-object? e)
|
||||
|
|
@ -1212,7 +1212,7 @@
|
|||
(syntax-case e ()
|
||||
((_) (chi-void))
|
||||
((_ e1 e2 ...)
|
||||
(chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
|
||||
(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)
|
||||
|
|
@ -1220,8 +1220,8 @@
|
|||
((eval-when-form)
|
||||
(syntax-case e ()
|
||||
((_ (x ...) e1 e2 ...)
|
||||
(let ((when-list (chi-when-list e (syntax (x ...)) w))
|
||||
(body (syntax (e1 e2 ...))))
|
||||
(let ((when-list (chi-when-list e #'(x ...) w))
|
||||
(body #'(e1 e2 ...)))
|
||||
(cond
|
||||
((eq? m 'e)
|
||||
(if (memq 'eval when-list)
|
||||
|
|
@ -1327,15 +1327,15 @@
|
|||
((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))))
|
||||
((_ 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 (syntax (x ...)) w)))
|
||||
(let ((when-list (chi-when-list e #'(x ...) w)))
|
||||
(if (memq 'eval when-list)
|
||||
(chi-sequence (syntax (e1 e2 ...)) r w s mod)
|
||||
(chi-sequence #'(e1 e2 ...) r w s mod)
|
||||
(chi-void))))))
|
||||
((define-form define-syntax-form)
|
||||
(syntax-violation #f "definition in expression context"
|
||||
|
|
@ -1354,7 +1354,7 @@
|
|||
(syntax-case e ()
|
||||
((e0 e1 ...)
|
||||
(build-application s x
|
||||
(map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
|
||||
(map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
|
||||
|
||||
(define chi-macro
|
||||
(lambda (p e r w rib mod)
|
||||
|
|
@ -1472,7 +1472,7 @@
|
|||
((begin-form)
|
||||
(syntax-case e ()
|
||||
((_ e1 ...)
|
||||
(parse (let f ((forms (syntax (e1 ...))))
|
||||
(parse (let f ((forms #'(e1 ...)))
|
||||
(if (null? forms)
|
||||
(cdr body)
|
||||
(cons (cons er (wrap (car forms) w mod))
|
||||
|
|
@ -1531,12 +1531,12 @@
|
|||
(lambda (rec? e r w s mod k)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(let ((ids (syntax (id ...))))
|
||||
(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 (syntax (e1 e2 ...))
|
||||
(k #'(e1 e2 ...)
|
||||
(extend-env
|
||||
labels
|
||||
(let ((w (if rec? new-w w))
|
||||
|
|
@ -1546,7 +1546,7 @@
|
|||
(eval-local-transformer
|
||||
(chi x trans-r w mod)
|
||||
mod)))
|
||||
(syntax (val ...))))
|
||||
#'(val ...)))
|
||||
r)
|
||||
new-w
|
||||
s
|
||||
|
|
@ -1568,7 +1568,7 @@
|
|||
(define ellipsis?
|
||||
(lambda (x)
|
||||
(and (nonsymbol-id? x)
|
||||
(free-id=? x (syntax (... ...))))))
|
||||
(free-id=? x #'(... ...)))))
|
||||
|
||||
(define lambda-formals
|
||||
(lambda (orig-args)
|
||||
|
|
@ -1854,8 +1854,8 @@
|
|||
(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 ...)))))
|
||||
(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))
|
||||
|
|
@ -1864,10 +1864,10 @@
|
|||
"identifier out of context"
|
||||
e
|
||||
(source-wrap id w s mod)))))
|
||||
(syntax (var ...))
|
||||
#'(var ...)
|
||||
names)
|
||||
(chi-body
|
||||
(syntax (e1 e2 ...))
|
||||
#'(e1 e2 ...)
|
||||
(source-wrap e w s mod)
|
||||
(extend-env
|
||||
names
|
||||
|
|
@ -1876,7 +1876,7 @@
|
|||
(make-binding 'macro
|
||||
(eval-local-transformer (chi x trans-r w mod)
|
||||
mod)))
|
||||
(syntax (val ...))))
|
||||
#'(val ...)))
|
||||
r)
|
||||
w
|
||||
mod)))
|
||||
|
|
@ -1886,7 +1886,7 @@
|
|||
(global-extend 'core 'quote
|
||||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ e) (build-data s (strip (syntax e) w)))
|
||||
((_ e) (build-data s (strip #'e w)))
|
||||
(_ (syntax-violation 'quote "bad syntax"
|
||||
(source-wrap e w s mod))))))
|
||||
|
||||
|
|
@ -1908,17 +1908,17 @@
|
|||
(values `(quote ,e) maps)))))
|
||||
(syntax-case e ()
|
||||
((dots e)
|
||||
(ellipsis? (syntax dots))
|
||||
(gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
|
||||
(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 (syntax (x ... ...)) forms
|
||||
(ellipsis? (syntax dots))
|
||||
(let f ((y (syntax y))
|
||||
; choose to handle #'(x ... ...) forms
|
||||
(ellipsis? #'dots)
|
||||
(let f ((y #'y)
|
||||
(k (lambda (maps)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(gen-syntax src (syntax x) r
|
||||
(gen-syntax src #'x r
|
||||
(cons '() maps) ellipsis? mod))
|
||||
(lambda (x maps)
|
||||
(if (null? (car maps))
|
||||
|
|
@ -1928,8 +1928,8 @@
|
|||
(cdr maps))))))))
|
||||
(syntax-case y ()
|
||||
((dots . y)
|
||||
(ellipsis? (syntax dots))
|
||||
(f (syntax y)
|
||||
(ellipsis? #'dots)
|
||||
(f #'y
|
||||
(lambda (maps)
|
||||
(call-with-values
|
||||
(lambda () (k (cons '() maps)))
|
||||
|
|
@ -1947,15 +1947,15 @@
|
|||
(values (gen-append x y) maps)))))))))
|
||||
((x . y)
|
||||
(call-with-values
|
||||
(lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
|
||||
(lambda () (gen-syntax src #'x r maps ellipsis? mod))
|
||||
(lambda (x maps)
|
||||
(call-with-values
|
||||
(lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
|
||||
(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 (syntax (e1 e2 ...)) r maps ellipsis? mod))
|
||||
(gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
|
||||
(lambda (e maps) (values (gen-vector e) maps))))
|
||||
(_ (values `(quote ,e) maps))))))
|
||||
|
||||
|
|
@ -2046,7 +2046,7 @@
|
|||
(syntax-case e ()
|
||||
((_ x)
|
||||
(call-with-values
|
||||
(lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
|
||||
(lambda () (gen-syntax e #'x r '() ellipsis? mod))
|
||||
(lambda (e maps) (regen e))))
|
||||
(_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
|
||||
|
||||
|
|
@ -2120,19 +2120,19 @@
|
|||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(and-map id? (syntax (id ...)))
|
||||
(and-map id? #'(id ...))
|
||||
(chi-let e r w s mod
|
||||
build-let
|
||||
(syntax (id ...))
|
||||
(syntax (val ...))
|
||||
(syntax (e1 e2 ...))))
|
||||
#'(id ...)
|
||||
#'(val ...)
|
||||
#'(e1 e2 ...)))
|
||||
((_ f ((id val) ...) e1 e2 ...)
|
||||
(and (id? (syntax f)) (and-map id? (syntax (id ...))))
|
||||
(and (id? #'f) (and-map id? #'(id ...)))
|
||||
(chi-let e r w s mod
|
||||
build-named-let
|
||||
(syntax (f id ...))
|
||||
(syntax (val ...))
|
||||
(syntax (e1 e2 ...))))
|
||||
#'(f id ...)
|
||||
#'(val ...)
|
||||
#'(e1 e2 ...)))
|
||||
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
|
||||
|
||||
|
||||
|
|
@ -2140,8 +2140,8 @@
|
|||
(lambda (e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(and-map id? (syntax (id ...)))
|
||||
(let ((ids (syntax (id ...))))
|
||||
(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))
|
||||
|
|
@ -2151,8 +2151,8 @@
|
|||
(build-letrec s
|
||||
(map syntax->datum ids)
|
||||
new-vars
|
||||
(map (lambda (x) (chi x r w mod)) (syntax (val ...)))
|
||||
(chi-body (syntax (e1 e2 ...))
|
||||
(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))))))
|
||||
|
||||
|
|
@ -2161,56 +2161,56 @@
|
|||
(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)))
|
||||
(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 (syntax id))
|
||||
(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 (syntax id) w mod)))
|
||||
(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 (syntax head) r empty-wrap no-source #f mod #t))
|
||||
(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 (syntax val) r w mod)))
|
||||
(call-with-values (lambda () (value (syntax (head tail ...))))
|
||||
(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 (syntax (setter head)) r w mod)
|
||||
(chi #'(setter head) r w mod)
|
||||
(map (lambda (e) (chi e r w mod))
|
||||
(syntax (tail ... val)))))))))
|
||||
#'(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))
|
||||
(and (and-map id? #'(mod ...)) (id? #'id))
|
||||
(values (syntax->datum #'id)
|
||||
(syntax->datum
|
||||
(syntax (public mod ...))))))))
|
||||
#'(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))
|
||||
(and (and-map id? #'(mod ...)) (id? #'id))
|
||||
(values (syntax->datum #'id)
|
||||
(syntax->datum
|
||||
(syntax (private mod ...))))))))
|
||||
#'(private mod ...)))))))
|
||||
|
||||
(global-extend 'core 'if
|
||||
(lambda (e r w s mod)
|
||||
|
|
@ -2218,15 +2218,15 @@
|
|||
((_ test then)
|
||||
(build-conditional
|
||||
s
|
||||
(chi (syntax test) r w mod)
|
||||
(chi (syntax then) r w mod)
|
||||
(chi #'test r w mod)
|
||||
(chi #'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))))))
|
||||
(chi #'test r w mod)
|
||||
(chi #'then r w mod)
|
||||
(chi #'else r w mod))))))
|
||||
|
||||
(global-extend 'begin 'begin '())
|
||||
|
||||
|
|
@ -2249,24 +2249,24 @@
|
|||
(values 'any (cons (cons p n) ids)))
|
||||
(syntax-case p ()
|
||||
((x dots)
|
||||
(ellipsis? (syntax dots))
|
||||
(ellipsis? #'dots)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax x) (fx+ n 1) ids))
|
||||
(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 (syntax y) n ids))
|
||||
(lambda () (cvt #'y n ids))
|
||||
(lambda (y ids)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax x) n ids))
|
||||
(lambda () (cvt #'x n ids))
|
||||
(lambda (x ids)
|
||||
(values (cons x y) ids))))))
|
||||
(() (values '() ids))
|
||||
(#(x ...)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax (x ...)) n ids))
|
||||
(lambda () (cvt #'(x ...) n ids))
|
||||
(lambda (p ids) (values (vector 'vector p) ids))))
|
||||
(x (values (vector 'atom (strip p empty-wrap)) ids)))))))
|
||||
|
||||
|
|
@ -2334,28 +2334,28 @@
|
|||
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)))
|
||||
(if (and (id? #'pat)
|
||||
(and-map (lambda (x) (not (free-id=? #'pat x)))
|
||||
(cons #'(... ...) keys)))
|
||||
(let ((labels (list (gen-label)))
|
||||
(var (gen-var (syntax pat))))
|
||||
(var (gen-var #'pat)))
|
||||
(build-application no-source
|
||||
(build-simple-lambda
|
||||
no-source (list (syntax->datum (syntax pat))) #f (list var)
|
||||
no-source (list (syntax->datum #'pat)) #f (list var)
|
||||
#f
|
||||
(chi (syntax exp)
|
||||
(chi #'exp
|
||||
(extend-env labels
|
||||
(list (make-binding 'syntax `(,var . 0)))
|
||||
r)
|
||||
(make-binding-wrap (syntax (pat))
|
||||
(make-binding-wrap #'(pat)
|
||||
labels empty-wrap)
|
||||
mod))
|
||||
(list x)))
|
||||
(gen-clause x keys (cdr clauses) r
|
||||
(syntax pat) #t (syntax exp) mod)))
|
||||
#'pat #t #'exp mod)))
|
||||
((pat fender exp)
|
||||
(gen-clause x keys (cdr clauses) r
|
||||
(syntax pat) (syntax fender) (syntax exp) mod))
|
||||
#'pat #'fender #'exp mod))
|
||||
(_ (syntax-violation 'syntax-case "invalid clause"
|
||||
(car clauses)))))))
|
||||
|
||||
|
|
@ -2364,17 +2364,17 @@
|
|||
(syntax-case e ()
|
||||
((_ val (key ...) m ...)
|
||||
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
|
||||
(syntax (key ...)))
|
||||
#'(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 ...))
|
||||
#'(key ...) #'(m ...)
|
||||
r
|
||||
mod))
|
||||
(list (chi (syntax val) r empty-wrap 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
|
||||
|
|
@ -2569,33 +2569,33 @@
|
|||
(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)
|
||||
#'(lambda (x)
|
||||
(syntax-case x (k ...)
|
||||
((dummy . pattern) (syntax template))
|
||||
...)))))))
|
||||
((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)
|
||||
|
|
@ -2605,83 +2605,83 @@
|
|||
(map (lambda (v s)
|
||||
(syntax-case s ()
|
||||
(() v)
|
||||
((e) (syntax e))
|
||||
((e) #'e)
|
||||
(_ (syntax-violation
|
||||
'do "bad step expression"
|
||||
orig-x s))))
|
||||
(syntax (var ...))
|
||||
(syntax (step ...)))))
|
||||
(syntax-case (syntax (e1 ...)) ()
|
||||
(() (syntax (let doloop ((var init) ...)
|
||||
#'(var ...)
|
||||
#'(step ...))))
|
||||
(syntax-case #'(e1 ...) ()
|
||||
(() #'(let doloop ((var init) ...)
|
||||
(if (not e0)
|
||||
(begin c ... (doloop step ...))))))
|
||||
(begin c ... (doloop step ...)))))
|
||||
((e1 e2 ...)
|
||||
(syntax (let doloop ((var init) ...)
|
||||
#'(let doloop ((var init) ...)
|
||||
(if e0
|
||||
(begin e1 e2 ...)
|
||||
(begin c ... (doloop step ...))))))))))))
|
||||
(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,9 @@
|
|||
(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 unquote
|
||||
(lambda (x)
|
||||
|
|
@ -2720,35 +2720,34 @@
|
|||
(syntax-case x ()
|
||||
((_ e m1 m2 ...)
|
||||
(with-syntax
|
||||
((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
|
||||
((body (let f ((clause #'m1) (clauses #'(m2 ...)))
|
||||
(if (null? clauses)
|
||||
(syntax-case clause (else)
|
||||
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
|
||||
((else e1 e2 ...) #'(begin e1 e2 ...))
|
||||
(((k ...) e1 e2 ...)
|
||||
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
|
||||
#'(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 ...)
|
||||
(syntax (if (memv t '(k ...))
|
||||
#'(if (memv t '(k ...))
|
||||
(begin e1 e2 ...)
|
||||
rest)))
|
||||
rest))
|
||||
(_ (syntax-violation 'case "bad clause" x
|
||||
clause))))))))
|
||||
(syntax (let ((t e)) body)))))))
|
||||
#'(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 ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue