test
consequent
alternate)))
- (make-application
+ (make-call
(lambda (src proc args)
(make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
- (make-sequence
- (lambda (src exps)
- (make-struct (vector-ref %expanded-vtables 12) 0 src exps)))
+ (make-primcall
+ (lambda (src name args)
+ (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
+ (make-seq
+ (lambda (src head tail)
+ (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
(make-lambda
(lambda (src meta body)
- (make-struct (vector-ref %expanded-vtables 13) 0 src meta body)))
+ (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
(make-lambda-case
(lambda (src req opt rest kw inits gensyms body alternate)
(make-struct
- (vector-ref %expanded-vtables 14)
+ (vector-ref %expanded-vtables 15)
0
src
req
(make-let
(lambda (src names gensyms vals body)
(make-struct
- (vector-ref %expanded-vtables 15)
+ (vector-ref %expanded-vtables 16)
0
src
names
(make-letrec
(lambda (src in-order? names gensyms vals body)
(make-struct
- (vector-ref %expanded-vtables 16)
+ (vector-ref %expanded-vtables 17)
0
src
in-order?
gensyms
vals
body)))
- (make-dynlet
- (lambda (src fluids vals body)
- (make-struct
- (vector-ref %expanded-vtables 17)
- 0
- src
- fluids
- vals
- body)))
(lambda?
(lambda (x)
(and (struct? x)
- (eq? (struct-vtable x) (vector-ref %expanded-vtables 13)))))
+ (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
(lambda-meta (lambda (x) (struct-ref x 1)))
(set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
(top-level-eval-hook (lambda (x mod) (primitive-eval x)))
(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)
- (macro-type val)
- (cons (macro-type val) (macro-binding val))))))))
+ (and (not (equal? module '(primitive)))
+ (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)
+ (macro-type val)
+ (cons (macro-type val) (macro-binding val)))))))))
(decorate-source
(lambda (e s)
(if (and s (supports-source-properties? e))
(if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta)))))))
(build-void (lambda (source) (make-void source)))
- (build-application
+ (build-call
(lambda (source fun-exp arg-exps)
- (make-application source fun-exp arg-exps)))
+ (make-call source fun-exp arg-exps)))
(build-conditional
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
- (build-dynlet
- (lambda (source fluids vals body)
- (make-dynlet source fluids vals body)))
(build-lexical-reference
(lambda (type source name var) (make-lexical-ref source name var)))
(build-lexical-assignment
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
+ ((memv key '(primitive))
+ (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))))
(build-global-reference
(lambda (source var mod)
(build-lambda-case
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
- (build-primref
- (lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
+ (build-primcall
+ (lambda (src name args) (make-primcall src name args)))
+ (build-primref (lambda (src name) (make-primitive-ref src name)))
(build-data (lambda (src exp) (make-const src exp)))
(build-sequence
(lambda (src exps)
- (if (null? (cdr exps)) (car exps) (make-sequence src exps))))
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(build-let
(lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps)
(list f-name)
(list f)
(list proc)
- (build-application
- src
- (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
(build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars)
(if (null? r)
'()
(let ((a (car r)))
- (if (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
- (lookup
- (lambda (x r mod)
- (let ((t (assq x r)))
- (cond (t (cdr t))
- ((symbol? x) (or (get-global-definition-hook x mod) '(global)))
- (else '(displaced-lexical))))))
(global-extend
(lambda (type sym val) (put-global-definition-hook sym type val)))
(nonsymbol-id?
(eq? (car x) (car y))
(same-marks? (cdr x) (cdr y))))))
(id-var-name
- (lambda (id w)
+ (lambda (id w mod)
(letrec*
((search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
- (cond ((null? symnames) (search sym (cdr subst) marks))
+ (cond ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (+ i 1)))))))
(search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
- (cond ((= i n) (search sym (cdr subst) marks))
+ (cond ((= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
+ (values n marks))))
(else (f (+ i 1)))))))))
- (cond ((symbol? id) (or (search id (cdr w) (car w)) id))
+ (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
((syntax-object? id)
- (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id)))
+ (let ((id (syntax-object-expression id))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (car w) (car w1))))
(call-with-values
- (lambda () (search id (cdr w) marks))
- (lambda (new-id marks) (or new-id (search id (cdr w1) marks) id))))))
+ (lambda () (search id (cdr w) marks mod))
+ (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id))))))
(else (syntax-violation 'id-var-name "invalid id" id))))))
(locally-bound-identifiers
(lambda (w mod)
results))))))))
(scan (cdr w) '()))))
(resolve-identifier
- (lambda (id w r mod)
+ (lambda (id w r mod resolve-syntax-parameters?)
(letrec*
- ((resolve-global
+ ((resolve-syntax-parameters
+ (lambda (b)
+ (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
+ (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
+ b)))
+ (resolve-global
(lambda (var mod)
- (let ((b (or (get-global-definition-hook var mod) '(global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod) '(global)))))
(if (eq? (car b) 'global)
(values 'global var mod)
(values (car b) (cdr b) mod)))))
(resolve-lexical
(lambda (label mod)
- (let ((b (or (assq-ref r label) '(displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label) '(displaced-lexical)))))
(values (car b) (cdr b) mod)))))
- (let ((n (id-var-name id w)))
- (cond ((symbol? n)
+ (let ((n (id-var-name id w mod)))
+ (cond ((syntax-object? n)
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
+ ((symbol? n)
(resolve-global
n
(if (syntax-object? id) (syntax-object-module id) mod)))
(lambda (k) ((fluid-ref transformer-environment) k)))
(free-id=?
(lambda (i j)
- (and (eq? (let ((x i)) (if (syntax-object? x) (syntax-object-expression x) x))
- (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
- (eq? (id-var-name i '(())) (id-var-name j '(()))))))
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i '(()) mi))
+ (nj (id-var-name j '(()) mj)))
+ (letrec*
+ ((id-module-binding
+ (lambda (id mod)
+ (module-variable
+ (if mod (resolve-module (cdr mod)) (current-module))
+ (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
+ (cond ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ (and (eq? nj
+ (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj)) (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else (equal? ni nj)))))))
(bound-id=?
(lambda (i j)
(if (and (syntax-object? i) (syntax-object? j))
(cons first (dobody (cdr body) r w mod))))))))
(expand-top-sequence
(lambda (body r w s m esew mod)
- (letrec*
- ((scan (lambda (body r w s m esew mod exps)
- (if (null? body)
- exps
- (call-with-values
- (lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value form e w s mod)
- (let ((key type))
- (cond ((memv key '(begin-form))
- (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_))))
- (if tmp-1
- (apply (lambda () exps) tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
- (if tmp-1
- (apply (lambda (e1 e2) (scan (cons e1 e2) r w s m esew mod exps))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp))))))
- ((memv key '(local-syntax-form))
- (expand-local-syntax
- value
- e
- r
- w
- s
- mod
- (lambda (body r w s mod) (scan body r w s m esew mod exps))))
- ((memv key '(eval-when-form))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
- (if tmp
- (apply (lambda (x e1 e2)
- (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
- (cond ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body
- r
- w
- s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod
- exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (cond ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps))
- ((memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps))
- (else (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
+ (let* ((r (cons '("placeholder" placeholder) r))
+ (ribcage (make-ribcage '() '() '()))
+ (w (cons (car w) (cons ribcage (cdr w)))))
+ (letrec*
+ ((record-definition!
+ (lambda (id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (extend-ribcage!
+ ribcage
+ id
+ (cons (syntax-object-module id) (wrap var '((top)) mod))))))
+ (macro-introduced-identifier?
+ (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
+ (fresh-derived-name
+ (lambda (id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16)))))
+ (parse (lambda (body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
+ (parse1
+ (lambda (x r w s m esew mod)
+ (call-with-values
+ (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (call-with-values
+ (lambda () (resolve-identifier id '(()) r mod #t))
+ (lambda (type* value* mod*)
+ (if (eq? type* 'macro)
+ (top-level-eval-hook
+ (build-global-definition s var (build-void s))
+ mod))
+ (lambda () (build-global-definition s var (expand e r w mod)))))))))
+ ((memv key '(define-syntax-form define-syntax-parameter-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (let ((key m))
+ (cond ((memv key '(c))
+ (cond ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) (list (lambda () e)) '())))
+ ((memq 'load esew)
+ (list (lambda () (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((memv key '(c&e))
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '())))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ r
+ w
+ s
+ mod
+ (lambda (forms r w s mod) (parse forms r w s m esew mod))))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
+ (letrec*
+ ((recurse (lambda (m esew) (parse body r w s m esew mod))))
+ (cond ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
+ (begin
+ (if (memq 'expand when-list)
(top-level-eval-hook
(expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else (values exps)))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (let ((key m))
- (cond ((memv key '(c))
- (cond ((memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) (values (cons e exps)) (values exps))))
- ((memq 'load esew)
- (values
- (cons (expand-install-global n (expand e r w mod)) exps)))
- (else (values exps))))
- ((memv key '(c&e))
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps))))))
- ((memv key '(define-form))
- (let* ((n (id-var-name value w)) (type (car (lookup n r mod))) (key type))
- (cond ((memv key '(global core macro module-ref))
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- (if (and (variable? old) (variable-bound? old))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda () (build-global-definition s n (expand e r w mod))))
- exps)))
- ((memv key '(displaced-lexical))
- (syntax-violation
- #f
- "identifier out of context"
- (source-wrap form w s mod)
- (wrap value w mod)))
- (else
- (syntax-violation
- #f
- "cannot define keyword at top level"
- (source-wrap form w s mod)
- (wrap value w mod))))))
- (else
- (values
- (cons (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda () (expand-expr type value form e r w s mod)))
- exps))))))))
- (lambda (exps) (scan (cdr body) r w s m esew mod exps)))))))
- (call-with-values
- (lambda () (scan body r w s m esew mod '()))
- (lambda (exps)
- (if (null? exps)
- (build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in)
- out
- (let ((e (car in)))
- (lp (cdr in) (cons (if (procedure? e) (e) e) out))))))))))))
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (cond ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load)))
+ ((memq m '(c c&e)) (recurse 'c '(load)))
+ (else '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else '())))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (else
+ (list (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda () (expand-expr type value form e r w s mod))))))))))))
+ (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
+ (if (null? exps) (build-void s) (build-sequence s exps)))))))
(expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
#f
name
- (build-application
+ (build-primcall
#f
- (build-primref #f 'make-syntax-transformer)
- (list (build-data #f name) (build-data #f 'macro) e)))))
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data #f name)
+ (build-data #f 'syntax-parameter)
+ (build-primcall #f 'list (list e)))
+ (list (build-data #f name) (build-data #f 'macro) e))))))
(parse-when-list
(lambda (e when-list)
(let ((result (strip when-list '(()))))
(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 (car b))
- (key type))
- (cond ((memv key '(lexical)) (values type (cdr b) e e w s mod))
- ((memv key '(global)) (values type n e e w s mod))
- ((memv key '(macro))
- (if for-car?
- (values type (cdr b) e e w s mod)
- (syntax-type
- (expand-macro (cdr b) e r w s rib mod)
- r
- '(())
- s
- rib
- mod
- #f)))
- (else (values type (cdr b) e e w s mod)))))
+ (call-with-values
+ (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (let ((key type))
+ (cond ((memv key '(macro))
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type
+ (expand-macro value e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ #f)))
+ ((memv key '(global)) (values type value e value w s mod*))
+ (else (values type value e e w s mod)))))))
((pair? e)
(let ((first (car e)))
(call-with-values
(let ((key ftype))
(cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
((memv key '(global))
- (values 'global-call (make-syntax-object fval w fmod) e e w s mod))
+ (if (equal? fmod '(primitive))
+ (values 'primitive-call fval e e w s mod)
+ (values 'global-call (make-syntax-object fval w fmod) e e w s mod)))
((memv key '(macro))
(syntax-type
(expand-macro fval e r w s rib mod)
for-car?))
((memv key '(module-ref))
(call-with-values
- (lambda () (fval e r w))
+ (lambda () (fval e r w mod))
(lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
((memv key '(core)) (values 'core-form fval e e w s mod))
((memv key '(local-syntax))
((memv key '(core core-form)) (value e r w s mod))
((memv key '(module-ref))
(call-with-values
- (lambda () (value e r w))
+ (lambda () (value e r w mod))
(lambda (e r w s mod) (expand e r w mod))))
((memv key '(lexical-call))
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference
'fun
s
mod))
((memv key '(global-call))
- (expand-application
+ (expand-call
(build-global-reference
(source-annotation (car e))
(if (syntax-object? value) (syntax-object-expression value) value)
w
s
mod))
+ ((memv key '(primitive-call))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e)
+ (build-primcall s value (map (lambda (e) (expand e r w mod)) e)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
((memv key '(constant))
(build-data s (strip (source-wrap e w s mod) '(()))))
((memv key '(global)) (build-global-reference s value mod))
((memv key '(call))
- (expand-application (expand (car e) r w mod) e r w s mod))
+ (expand-call (expand (car e) r w mod) e r w s mod))
((memv key '(begin-form))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
(if tmp-1
(let ((tmp-1 ($sc-dispatch tmp '(_))))
(if tmp-1
(apply (lambda ()
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation
- #f
- "sequence of zero expressions"
- (source-wrap e w s mod))))
+ (syntax-violation
+ #f
+ "sequence of zero expressions"
+ (source-wrap e w s mod)))
tmp-1)
(syntax-violation
#f
(source-wrap e w s mod)))
(else
(syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
- (expand-application
+ (expand-call
(lambda (x e r w s mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
(if tmp
(apply (lambda (e0 e1)
- (build-application s x (map (lambda (e) (expand e r w mod)) e1)))
+ (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
tmp)
(syntax-violation
#f
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (with-fluids
- ((transformer-environment (lambda (k) (k e r w s rib mod))))
- (rebuild-macro-output
- (p (source-wrap e (anti-mark w) s mod))
- (gensym (string-append "m-" (session-id) "-")))))))
+ (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
+ (with-fluid*
+ t-1
+ t
+ (lambda ()
+ (rebuild-macro-output
+ (p (source-wrap e (anti-mark w) s mod))
+ (gensym (string-append "m-" (session-id) "-")))))))))
(expand-body
(lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r))
(cons var vars)
(cons (cons er (wrap e w mod)) vals)
(cons (cons 'lexical var) bindings)))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
+ ((memv key '(define-syntax-form))
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
(list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
(cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+ ((memv key '(define-syntax-parameter-form))
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr!
+ r
+ (extend-env
+ (list label)
+ (list (cons 'syntax-parameter
+ (list (eval-local-transformer (expand e trans-r w mod) mod))))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((memv key '(begin-form))
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
(if tmp
(syntax-violation #f "nonprocedure transformer" p)))))
(expand-void (lambda () (build-void #f)))
(ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
+ (lambda (e r mod)
+ (and (nonsymbol-id? e)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier
+ (make-syntax-object
+ '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ '(())
+ r
+ mod
+ #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))))
(lambda-formals
(lambda (orig-args)
(letrec*
(tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
(if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
(apply (lambda (var val e1 e2)
- (let ((names (map (lambda (x) (id-var-name x w)) var)))
- (for-each
- (lambda (id n)
- (let ((key (car (lookup n r mod))))
- (if (memv key '(displaced-lexical))
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- var
- names)
+ (let ((names (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(displaced-lexical))
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((memv key '(syntax-parameter)) value)
+ (else
+ (syntax-violation
+ 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod))))))))
+ var))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+ val))))
(expand-body
(cons e1 e2)
(source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
- val))
- r)
+ (extend-env names bindings r)
w
mod)))
tmp)
((gen-syntax
(lambda (src e r maps ellipsis? mod)
(if (id? e)
- (let* ((label (id-var-name e '(()))) (b (lookup label r mod)))
- (cond ((eq? (car b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (cdr b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values (list 'ref var) maps))))
- ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
- (else (values (list 'quote e) maps))))
+ (call-with-values
+ (lambda () (resolve-identifier e '(()) r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(syntax))
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps) (values (list 'ref var) maps))))
+ ((ellipsis? e r mod)
+ (syntax-violation 'syntax "misplaced ellipsis" src))
+ (else (values (list 'quote e) maps))))))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
- (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
- (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
+ (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1))
+ (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
- (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
+ (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1))
(apply (lambda (x dots y)
(let f ((y y)
(k (lambda (maps)
(syntax-violation 'syntax "extra ellipsis" src)
(values (gen-map x (car maps)) (cdr maps))))))))
(let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
- (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
+ (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
(apply (lambda (dots y)
(f y
(lambda (maps)
(if (list? (cadr x))
(build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
- (else
- (build-application #f (build-primref #f (car x)) (map regen (cdr x)))))))))
+ (else (build-primcall #f (car x) (map regen (cdr x)))))))))
(lambda (e r w s mod)
(let* ((e (source-wrap e w s mod))
(tmp e)
args)))
tmp)
(syntax-violation 'case-lambda "bad case-lambda*" e))))))))
+ (global-extend
+ 'core
+ 'with-ellipsis
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+ (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
+ (apply (lambda (dots e1 e2)
+ (let ((id (if (symbol? dots)
+ '#{ $sc-ellipsis }#
+ (make-syntax-object
+ '#{ $sc-ellipsis }#
+ (syntax-object-wrap dots)
+ (syntax-object-module dots)))))
+ (let ((ids (list id))
+ (labels (list (gen-label)))
+ (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-env labels bindings r)))
+ (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod)))))
+ tmp)
+ (syntax-violation
+ 'with-ellipsis
+ "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend
'core
'let
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
(if (and tmp (apply (lambda (id val) (id? id)) tmp))
(apply (lambda (id val)
- (let ((n (id-var-name id w))
- (id-mod (if (syntax-object? id) (syntax-object-module id) mod)))
- (let* ((b (lookup n r id-mod)) (key (car b)))
- (cond ((memv key '(lexical))
- (build-lexical-assignment
- s
- (syntax->datum id)
- (cdr b)
- (expand val r w mod)))
- ((memv key '(global))
- (build-global-assignment s n (expand val r w mod) id-mod))
- ((memv key '(macro))
- (let ((p (cdr b)))
- (if (procedure-property p 'variable-transformer)
- (expand (expand-macro p e r w s #f mod) r '(()) mod)
+ (call-with-values
+ (lambda () (resolve-identifier id w r mod #t))
+ (lambda (type value id-mod)
+ (let ((key type))
+ (cond ((memv key '(lexical))
+ (build-lexical-assignment
+ s
+ (syntax->datum id)
+ value
+ (expand val r w mod)))
+ ((memv key '(global))
+ (build-global-assignment s value (expand val r w mod) id-mod))
+ ((memv key '(macro))
+ (if (procedure-property value 'variable-transformer)
+ (expand (expand-macro value e r w s #f mod) r '(()) mod)
(syntax-violation
'set!
"not a variable transformer"
(wrap e w mod)
- (wrap id w id-mod)))))
- ((memv key '(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)))))))
+ (wrap id w id-mod))))
+ ((memv key '(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))))))))
tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
(if tmp
(apply (lambda (head tail val)
(call-with-values
(lambda () (syntax-type head r '(()) #f #f mod #t))
- (lambda (type value formform ee ww ss modmod)
+ (lambda (type value ee* ee ww ss modmod)
(let ((key type))
(if (memv key '(module-ref))
(let ((val (expand val r w mod)))
(call-with-values
- (lambda () (value (cons head tail) r w))
+ (lambda () (value (cons head tail) r w mod))
(lambda (e r w s* mod)
(let* ((tmp-1 e) (tmp (list tmp-1)))
(if (and tmp (apply (lambda (e) (id? e)) tmp))
#f
"source expression failed to match any pattern"
tmp-1))))))
- (build-application
+ (build-call
s
(expand
(list '#(syntax-object setter ((top)) (hygiene guile)) head)
(global-extend
'module-ref
'@
- (lambda (e r w)
+ (lambda (e r w mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
(if (and tmp
(apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
(global-extend
'module-ref
'@@
- (lambda (e r w)
+ (lambda (e r w mod)
(letrec*
((remodulate
(lambda (x mod)
(vector-set! v i (remodulate (vector-ref x i) mod))
(loop (+ i 1)))))))
(else x)))))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
- (if (and tmp
- (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
- (apply (lambda (mod id)
- (values
- (syntax->datum id)
- r
- '((top))
- #f
- (syntax->datum
- (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
- tmp)
- (let ((tmp ($sc-dispatch
- tmp-1
- '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
- each-any
- any))))
- (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
- (apply (lambda (mod exp)
- (let ((mod (syntax->datum
- (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
- (values (remodulate exp mod) r w (source-annotation exp) mod)))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))))
+ (let* ((tmp e)
+ (tmp-1 ($sc-dispatch
+ tmp
+ '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any))))
+ (if (and tmp-1
+ (apply (lambda (id)
+ (and (id? id)
+ (equal?
+ (cdr (if (syntax-object? id) (syntax-object-module id) mod))
+ '(guile))))
+ tmp-1))
+ (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
+ (if (and tmp-1
+ (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ '((top))
+ #f
+ (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '(_ #(free-id #(syntax-object @@ ((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))))
+ (values (remodulate exp mod) r w (source-annotation exp) mod)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))
(global-extend
'core
'if
#f
"source expression failed to match any pattern"
tmp)))))))
- (global-extend
- 'core
- 'with-fluids
- (lambda (e r w s mod)
- (let* ((tmp-1 e)
- (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
- (if tmp
- (apply (lambda (fluid val b b*)
- (build-dynlet
- s
- (map (lambda (x) (expand x r w mod)) fluid)
- (map (lambda (x) (expand x r w mod)) val)
- (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(global-extend 'define-syntax 'define-syntax '())
'syntax-case
(letrec*
((convert-pattern
- (lambda (pattern keys)
+ (lambda (pattern keys ellipsis?)
(letrec*
((cvt* (lambda (p* n ids)
(let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
(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
+ (build-primcall
#f
- (build-primref #f 'apply)
+ 'apply
(list (build-simple-lambda
#f
(map syntax->datum ids)
(gen-clause
(lambda (x keys clauses r pat fender exp mod)
(call-with-values
- (lambda () (convert-pattern pat keys))
+ (lambda ()
+ (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
(lambda (p pvars)
- (cond ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
- (build-application
+ (build-call
#f
(build-simple-lambda
#f
(build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
- (build-application #f (build-primref #f 'list) (list x))
- (build-application
- #f
- (build-primref #f '$sc-dispatch)
- (list x (build-data #f p)))))))))))))
+ (build-primcall #f 'list (list x))
+ (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
(gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
- (build-application
+ (build-primcall
#f
- (build-primref #f 'syntax-violation)
+ 'syntax-violation
(list (build-data #f #f)
(build-data #f "source expression failed to match any pattern")
x))
(if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
(expand exp r '(()) mod)
(let ((labels (list (gen-label))) (var (gen-var pat)))
- (build-application
+ (build-call
#f
(build-simple-lambda
#f
(tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
(if tmp
(apply (lambda (val key m)
- (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key)
(let ((x (gen-var 'tmp)))
- (build-application
+ (build-call
s
(build-simple-lambda
#f
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-module "invalid argument" x)))
- (cdr (syntax-object-module id))))
+ (let ((mod (syntax-object-module id)))
+ (and (not (equal? mod '(primitive))) (cdr mod)))))
(syntax-local-binding
- (lambda (id)
+ (lambda* (id
+ #:key
+ (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-local-binding "invalid argument" x)))
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ resolve-syntax-parameters?))
(lambda (type value mod)
(let ((key type))
(cond ((memv key '(lexical)) (values 'lexical value))
((memv key '(macro)) (values 'macro value))
+ ((memv key '(syntax-parameter))
+ (values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable value))
((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
- ((memv key '(global)) (values 'global (cons value (cdr mod))))
+ ((memv key '(global))
+ (if (equal? mod '(primitive))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
+ ((memv key '(ellipsis))
+ (values
+ 'ellipsis
+ (make-syntax-object
+ (syntax-object-expression value)
+ (anti-mark (syntax-object-wrap value))
+ (syntax-object-module value))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
"source expression failed to match any pattern"
tmp)))))))))))
-(define syntax-rules
+(define syntax-error
(make-syntax-transformer
- 'syntax-rules
+ 'syntax-error
'macro
- (lambda (xx)
- (let ((tmp-1 xx))
- (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
- (if tmp
- (apply (lambda (k keyword pattern template)
- (list '#(syntax-object lambda ((top)) (hygiene guile))
- '(#(syntax-object x ((top)) (hygiene guile)))
- (vector
- '(#(syntax-object macro-type ((top)) (hygiene guile))
- .
- #(syntax-object syntax-rules ((top)) (hygiene guile)))
- (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
- (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
- (cons '#(syntax-object x ((top)) (hygiene guile))
- (cons k
- (map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp)
- (list '#(syntax-object syntax ((top)) (hygiene guile))
- tmp-1)))
- template
- pattern))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if (if tmp
+ (apply (lambda (keyword operands message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword operands message arg)
+ (syntax-violation
+ (syntax->datum keyword)
+ (string-join
+ (cons (syntax->datum message)
+ (map (lambda (x) (object->string (syntax->datum x))) arg)))
+ (if (syntax->datum keyword) (cons keyword operands) #f)))
tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
(if (if tmp
- (apply (lambda (k docstring keyword pattern template)
- (string? (syntax->datum docstring)))
- tmp)
+ (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
#f)
- (apply (lambda (k docstring keyword pattern template)
- (list '#(syntax-object lambda ((top)) (hygiene guile))
- '(#(syntax-object x ((top)) (hygiene guile)))
- docstring
- (vector
- '(#(syntax-object macro-type ((top)) (hygiene guile))
- .
- #(syntax-object syntax-rules ((top)) (hygiene guile)))
- (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
- (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
- (cons '#(syntax-object x ((top)) (hygiene guile))
- (cons k
- (map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp)
- (list '#(syntax-object syntax ((top)) (hygiene guile))
- tmp-1)))
- template
- pattern))))))
+ (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 '(#f) (cons message arg))))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))))))
+(define syntax-rules
+ (make-syntax-transformer
+ 'syntax-rules
+ 'macro
+ (lambda (xx)
+ (letrec*
+ ((expand-clause
+ (lambda (clause)
+ (let ((tmp-1 clause))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '((any . any)
+ (#(free-id #(syntax-object 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)
+ (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)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
+ (expand-syntax-rules
+ (lambda (dots keys docstrings clauses)
+ (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(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)))
+ (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))
+ pattern))
+ (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
+ (cons '#(syntax-object 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))
+ dots
+ form)))
+ form))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ (let ((tmp xx))
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
+ (if tmp-1
+ (apply (lambda (k keyword pattern template)
+ (expand-syntax-rules
+ #f
+ k
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (k docstring keyword pattern template)
+ (string? (syntax->datum docstring)))
+ tmp-1)
+ #f)
+ (apply (lambda (k docstring keyword pattern template)
+ (expand-syntax-rules
+ #f
+ k
+ (list docstring)
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (dots k keyword pattern template) (identifier? dots))
+ tmp-1)
+ #f)
+ (apply (lambda (dots k keyword pattern template)
+ (expand-syntax-rules
+ dots
+ k
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (dots k docstring keyword pattern template)
+ (if (identifier? dots) (string? (syntax->datum docstring)) #f))
+ tmp-1)
+ #f)
+ (apply (lambda (dots k docstring keyword pattern template)
+ (expand-syntax-rules
+ dots
+ k
+ (list docstring)
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))))))
+
(define define-syntax-rule
(make-syntax-transformer
'define-syntax-rule
tmp-1)
(let ((tmp-1 ($sc-dispatch
tmp
- '(#(free-id #(syntax-object quasiquote ((top)) (hygiene guile))) any))))
+ '(#(free-id
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
+ any))))
(if tmp-1
(apply (lambda (p)
(quasicons
- '("quote" #(syntax-object quasiquote ((top)) (hygiene guile)))
+ '("quote"
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
(quasi (list p) (+ lev 1))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any . any))))
'(#(syntax-object x ((top)) (hygiene guile)))
'#((#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object identifier-syntax ((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))
'()
HCoop / bpt / guile.git / blobdiff