;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(set-current-module (resolve-module '(guile))))
(let ()
- ;; Private version of and-map that handles multiple lists.
- (define and-map*
- (lambda (f first . rest)
- (or (null? first)
- (if (null? rest)
- (let andmap ((first first))
- (let ((x (car first)) (first (cdr first)))
- (if (null? first)
- (f x)
- (and (f x) (andmap first)))))
- (let andmap ((first first) (rest rest))
- (let ((x (car first))
- (xr (map car rest))
- (first (cdr first))
- (rest (map cdr rest)))
- (if (null? first)
- (apply f x xr)
- (and (apply f x xr) (andmap first rest)))))))))
-
(define-syntax define-expansion-constructors
(lambda (x)
(syntax-case x ()
;; hooks to nonportable run-time helpers
(begin
- (define fx+ +)
- (define fx- -)
- (define fx= =)
- (define fx< <)
+ (define-syntax fx+ (identifier-syntax +))
+ (define-syntax fx- (identifier-syntax -))
+ (define-syntax fx= (identifier-syntax =))
+ (define-syntax fx< (identifier-syntax <))
(define top-level-eval-hook
(lambda (x mod)
(lambda (x mod)
(primitive-eval x)))
- (define-syntax gensym-hook
- (syntax-rules ()
- ((_) (gensym))))
+ (define-syntax-rule (gensym-hook)
+ (gensym))
(define put-global-definition-hook
(lambda (symbol type val)
;; FIXME: use a faster gensym
- (define-syntax build-lexical-var
- (syntax-rules ()
- ((_ src id) (gensym (string-append (symbol->string id) " ")))))
+ (define-syntax-rule (build-lexical-var src id)
+ (gensym (string-append (symbol->string id) " ")))
(define-structure (syntax-object expression wrap module))
#f)))
(else #f))))
- (define-syntax arg-check
- (syntax-rules ()
- ((_ pred? e who)
- (let ((x e))
- (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
+ (define-syntax-rule (arg-check pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
;; compile-time environments
;; (define-syntax) define-syntax
;; (local-syntax . rec?) let-syntax/letrec-syntax
;; (eval-when) eval-when
- ;; #'. (<var> . <level>) pattern variables
+ ;; (syntax . (<var> . <level>)) pattern variables
;; (global) assumed global variable
;; (lexical . <var>) lexical variables
;; (displaced-lexical) displaced lexicals
((_ type value) (cons type value))
((_ 'type) '(type))
((_ type) (cons type '()))))
- (define binding-type car)
- (define binding-value cdr)
+ (define-syntax-rule (binding-type x)
+ (car x))
+ (define-syntax-rule (binding-value x)
+ (cdr x))
(define-syntax null-env (identifier-syntax '()))
((syntax-object? x) (symbol? (syntax-object-expression x)))
(else #f))))
- (define-syntax id-sym-name
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (if (syntax-object? x)
- (syntax-object-expression x)
- x)))))
+ (define-syntax-rule (id-sym-name e)
+ (let ((x e))
+ (if (syntax-object? x)
+ (syntax-object-expression x)
+ x)))
(define id-sym-name&marks
(lambda (x w)
;; <subs> ::= #(<old name> <label> (<mark> ...))
;; <shift> ::= positive fixnum
- (define make-wrap cons)
- (define wrap-marks car)
- (define wrap-subst cdr)
+ (define-syntax make-wrap (identifier-syntax cons))
+ (define-syntax wrap-marks (identifier-syntax car))
+ (define-syntax wrap-subst (identifier-syntax cdr))
(define-syntax subst-rename? (identifier-syntax vector?))
- (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
- (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
- (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
- (define-syntax make-rename
- (syntax-rules ()
- ((_ old new marks) (vector old new marks))))
+ (define-syntax-rule (rename-old x) (vector-ref x 0))
+ (define-syntax-rule (rename-new x) (vector-ref x 1))
+ (define-syntax-rule (rename-marks x) (vector-ref x 2))
+ (define-syntax-rule (make-rename old new marks)
+ (vector old new marks))
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define-syntax top-wrap (identifier-syntax '((top))))
- (define-syntax top-marked?
- (syntax-rules ()
- ((_ w) (memq 'top (wrap-marks w)))))
+ (define-syntax-rule (top-marked? w)
+ (memq 'top (wrap-marks w)))
;; Marks must be comparable with "eq?" and distinct from pairs and
;; the symbol top. We do not use integers so that marks will remain
(make-wrap (cons the-anti-mark (wrap-marks w))
(cons 'shift (wrap-subst w)))))
- (define-syntax new-mark
- (syntax-rules ()
- ((_) (gensym "m"))))
+ (define-syntax-rule (new-mark)
+ (gensym "m"))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally
- (define-syntax make-empty-ribcage
- (syntax-rules ()
- ((_) (make-ribcage '() '() '()))))
+ (define-syntax-rule (make-empty-ribcage)
+ (make-ribcage '() '() '()))
(define extend-ribcage!
;; must receive ids with complete wraps
(define id-var-name
(lambda (id w)
- (define-syntax first
- (syntax-rules ()
- ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
+ (define-syntax-rule (first e)
+ ;; Rely on Guile's multiple-values truncation.
+ e)
(define search
(lambda (sym subst marks)
(if (null? subst)
;; expanding
- (define chi-sequence
+ (define expand-sequence
(lambda (body r w s mod)
(build-sequence s
(let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body)
'()
- (let ((first (chi (car body) r w mod)))
+ (let ((first (expand (car body) r w mod)))
(cons first (dobody (cdr body) r w mod))))))))
- (define chi-top-sequence
+ ;; At top-level, we allow mixed definitions and expressions. Like
+ ;; expand-body we expand in two passes.
+ ;;
+ ;; First, from left to right, we expand just enough to know what
+ ;; expressions are definitions, syntax definitions, and splicing
+ ;; statements (`begin'). If we anything needs evaluating at
+ ;; expansion-time, it is expanded directly.
+ ;;
+ ;; Otherwise we collect expressions to expand, in thunks, and then
+ ;; expand them all at the end. This allows all syntax expanders
+ ;; visible in a toplevel sequence to be visible during the
+ ;; expansions of all normal definitions and expressions in the
+ ;; sequence.
+ ;;
+ (define expand-top-sequence
(lambda (body r w s m esew mod)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew)
- (mod mod) (out '()))
- (if (null? body)
- (reverse out)
- (dobody (cdr body) r w m esew mod
- (cons (chi-top (car body) r w m esew mod) out)))))))
-
- (define chi-install-global
+ (define (scan body r w s m esew mod exps)
+ (cond
+ ((null? body)
+ ;; in reversed order
+ exps)
+ (else
+ (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 e w s mod)
+ (case type
+ ((begin-form)
+ (syntax-case e ()
+ ((_) exps)
+ ((_ e1 e2 ...)
+ (scan #'(e1 e2 ...) r w s m esew mod exps))))
+ ((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))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (parse-when-list e #'(x ...)))
+ (body #'(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)
+ (if (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)
+ (if (memq m '(c c&e))
+ (scan body r w s 'c '(load) mod exps)
+ (values exps))))
+ ((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)
+ (values exps))
+ (else
+ (values exps)))))))
+ ((define-syntax-form)
+ (let ((n (id-var-name value w)) (r (macros-only-env r)))
+ (case m
+ ((c)
+ (if (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)))
+ (if (memq 'load esew)
+ (values (cons (expand-install-global n (expand e r w mod))
+ exps))
+ (values exps))))
+ ((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)))))
+ ((define-form)
+ (let* ((n (id-var-name value w))
+ ;; Lookup the name in the module of the define form.
+ (type (binding-type (lookup n r mod))))
+ (case type
+ ((global core macro module-ref)
+ ;; affect compile-time environment (once we have booted)
+ (if (and (memq m '(c c&e))
+ (not (module-local-variable (current-module) n))
+ (current-module))
+ (let ((old (module-variable (current-module) n)))
+ ;; use value of the same-named imported variable, if
+ ;; any
+ (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)))
+ ((displaced-lexical)
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
+ (else
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
+ (else
+ (values (cons
+ (if (eq? m 'c&e)
+ (let ((x (expand-expr type value e r w s mod)))
+ (top-level-eval-hook x mod)
+ x)
+ (lambda ()
+ (expand-expr type value 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)))))))))))
+
+ (define expand-install-global
(lambda (name e)
(build-global-definition
no-source
(build-data no-source 'macro)
e)))))
- (define chi-when-list
- (lambda (e when-list w)
+ (define parse-when-list
+ (lambda (e when-list)
;; when-list is syntax'd version of list of situations
- (let f ((when-list when-list) (situations '()))
- (if (null? when-list)
- situations
- (f (cdr when-list)
- (cons (let ((x (car when-list)))
- (cond
- ((free-id=? x #'compile) 'compile)
- ((free-id=? x #'load) 'load)
- ((free-id=? x #'eval) 'eval)
- ((free-id=? x #'expand) 'expand)
- (else (syntax-violation 'eval-when
- "invalid situation"
- e (wrap x w #f)))))
- situations))))))
+ (let ((result (strip when-list empty-wrap)))
+ (let lp ((l result))
+ (if (null? l)
+ result
+ (if (memq (car l) '(compile load eval expand))
+ (lp (cdr l))
+ (syntax-violation 'eval-when "invalid situation" e
+ (car l))))))))
;; syntax-type returns six values: type, value, e, w, s, and mod. The
;; first two are described in the table below.
((macro)
(if for-car?
(values type (binding-value b) e w s mod)
- (syntax-type (chi-macro (binding-value b) e r w s rib mod)
+ (syntax-type (expand-macro (binding-value b) e r w s rib mod)
r empty-wrap s rib mod #f)))
(else (values type (binding-value b) e w s mod)))))
((pair? e)
(values 'global-call (make-syntax-object fval w fmod)
e w s mod))
((macro)
- (syntax-type (chi-macro fval e r w s rib mod)
+ (syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
((module-ref)
(call-with-values (lambda () (fval e r w))
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
- (define chi-top
- (lambda (e r w m esew mod)
- (define-syntax eval-if-c&e
- (syntax-rules ()
- ((_ m e mod)
- (let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x mod))
- x))))
- (call-with-values
- (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
- (lambda (type value e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) (chi-void))
- ((_ e1 e2 ...)
- (chi-top-sequence #'(e1 e2 ...) r w s m esew mod))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (chi-top-sequence body r w s m esew mod))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e #'(x ...) w))
- (body #'(e1 e2 ...)))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (chi-top-sequence body r w s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval) mod)
- mod))
- (chi-void))))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load) mod)
- (if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load) mod)
- (chi-void))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval) mod)
- mod)
- (chi-void))
- (else (chi-void)))))))
- ((define-syntax-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) e (chi-void)))
- (if (memq 'load esew)
- (chi-install-global n (chi e r w mod))
- (chi-void))))
- ((c&e)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- e))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (chi-install-global n (chi e r w mod))
- mod))
- (chi-void)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- ;; Lookup the name in the module of the define form.
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- ;; use value of the same-named imported variable, if
- ;; any
- (module-define! (current-module) n
- (if (variable? old)
- (variable-ref old)
- #f))))
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod))
- mod))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- e (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- e (wrap value w mod))))))
- (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
-
- (define chi
+ (define expand
(lambda (e r w mod)
(call-with-values
(lambda () (syntax-type e r w (source-annotation e) #f mod #f))
(lambda (type value e w s mod)
- (chi-expr type value e r w s mod)))))
+ (expand-expr type value e r w s mod)))))
- (define chi-expr
+ (define expand-expr
(lambda (type value e r w s mod)
(case type
((lexical)
((module-ref)
(call-with-values (lambda () (value e r w))
(lambda (e r w s mod)
- (chi e r w mod))))
+ (expand e r w mod))))
((lexical-call)
- (chi-application
+ (expand-application
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
value))
e r w s mod))
((global-call)
- (chi-application
+ (expand-application
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
- ((call) (chi-application (chi (car e) r w mod) e r w s mod))
+ ((call) (expand-application (expand (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
+ ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))))
((local-syntax-form)
- (chi-local-syntax value e r w s mod chi-sequence))
+ (expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e #'(x ...) w)))
+ (let ((when-list (parse-when-list e #'(x ...))))
(if (memq 'eval when-list)
- (chi-sequence #'(e1 e2 ...) r w s mod)
- (chi-void))))))
+ (expand-sequence #'(e1 e2 ...) r w s mod)
+ (expand-void))))))
((define-form define-syntax-form)
(syntax-violation #f "definition in expression context"
e (wrap value w mod)))
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
- (define chi-application
+ (define expand-application
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
(build-application s x
- (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
+ (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
;; really nice if we could also annotate introduced expressions with the
;; locations corresponding to the macro definition, but that is not yet
;; possible.
- (define chi-macro
+ (define expand-macro
(lambda (p e r w s rib mod)
(define rebuild-macro-output
(lambda (x m)
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
(new-mark))))
- (define chi-body
+ (define expand-body
;; In processing the forms of the body, we create a new, empty wrap.
;; This wrap is augmented (destructively) each time we discover that
;; the next form is a definition. This is done:
(f (cdr forms)))))
ids labels var-ids vars vals bindings))))
((local-syntax-form)
- (chi-local-syntax value e er w s mod
- (lambda (forms er w s mod)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w mod))
- (f (cdr forms)))))
- ids labels var-ids vars vals bindings))))
+ (expand-local-syntax value e er w s mod
+ (lambda (forms er w s mod)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w mod))
+ (f (cdr forms)))))
+ ids labels var-ids vars vals bindings))))
(else ; found a non-definition
(if (null? ids)
(build-sequence no-source
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
+ (expand (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s mod))
(cdr body))))
(begin
(macros-only-env er))))
(set-cdr! b
(eval-local-transformer
- (chi (cddr b) r-cache empty-wrap mod)
+ (expand (cddr b) r-cache empty-wrap mod)
mod))
(loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache)))))
(reverse (map syntax->datum var-ids))
(reverse vars)
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
+ (expand (cdr x) (car x) empty-wrap mod))
(reverse vals))
(build-sequence no-source
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap mod))
+ (expand (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s mod))
(cdr body)))))))))))))))))
- (define chi-local-syntax
+ (define expand-local-syntax
(lambda (rec? e r w s mod k)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(map (lambda (x)
(make-binding 'macro
(eval-local-transformer
- (chi x trans-r w mod)
+ (expand x trans-r w mod)
mod)))
#'(val ...)))
r)
p
(syntax-violation #f "nonprocedure transformer" p)))))
- (define chi-void
+ (define expand-void
(lambda ()
(build-void no-source)))
orig-args))))
(req orig-args '())))
- (define chi-simple-lambda
+ (define expand-simple-lambda
(lambda (e r w s mod req rest meta body)
(let* ((ids (if rest (append req (list rest)) req))
(vars (map gen-var ids))
s
(map syntax->datum req) (and rest (syntax->datum rest)) vars
meta
- (chi-body body (source-wrap e w s mod)
- (extend-var-env labels vars r)
- (make-binding-wrap ids labels w)
- mod)))))
+ (expand-body body (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
(define lambda*-formals
(lambda (orig-args)
orig-args))))
(req orig-args '())))
- (define chi-lambda-case
+ (define expand-lambda-case
(lambda (e r w s mod get-formals clauses)
- (define (expand-req req opt rest kw body)
+ (define (parse-req req opt rest kw body)
(let ((vars (map gen-var req))
(labels (gen-labels req)))
(let ((r* (extend-var-env labels vars r))
(w* (make-binding-wrap req labels w)))
- (expand-opt (map syntax->datum req)
- opt rest kw body (reverse vars) r* w* '() '()))))
- (define (expand-opt req opt rest kw body vars r* w* out inits)
+ (parse-opt (map syntax->datum req)
+ opt rest kw body (reverse vars) r* w* '() '()))))
+ (define (parse-opt req opt rest kw body vars r* w* out inits)
(cond
((pair? opt)
(syntax-case (car opt) ()
(l (gen-labels (list v)))
(r** (extend-var-env l (list v) r*))
(w** (make-binding-wrap (list #'id) l w*)))
- (expand-opt req (cdr opt) rest kw body (cons v vars)
- r** w** (cons (syntax->datum #'id) out)
- (cons (chi #'i r* w* mod) inits))))))
+ (parse-opt req (cdr opt) rest kw body (cons v vars)
+ r** w** (cons (syntax->datum #'id) out)
+ (cons (expand #'i r* w* mod) inits))))))
(rest
(let* ((v (gen-var rest))
(l (gen-labels (list v)))
(r* (extend-var-env l (list v) r*))
(w* (make-binding-wrap (list rest) l w*)))
- (expand-kw req (if (pair? out) (reverse out) #f)
- (syntax->datum rest)
- (if (pair? kw) (cdr kw) kw)
- body (cons v vars) r* w*
- (if (pair? kw) (car kw) #f)
- '() inits)))
+ (parse-kw req (if (pair? out) (reverse out) #f)
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ body (cons v vars) r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits)))
(else
- (expand-kw req (if (pair? out) (reverse out) #f) #f
- (if (pair? kw) (cdr kw) kw)
- body vars r* w*
- (if (pair? kw) (car kw) #f)
- '() inits))))
- (define (expand-kw req opt rest kw body vars r* w* aok out inits)
+ (parse-kw req (if (pair? out) (reverse out) #f) #f
+ (if (pair? kw) (cdr kw) kw)
+ body vars r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits))))
+ (define (parse-kw req opt rest kw body vars r* w* aok out inits)
(cond
((pair? kw)
(syntax-case (car kw) ()
(l (gen-labels (list v)))
(r** (extend-var-env l (list v) r*))
(w** (make-binding-wrap (list #'id) l w*)))
- (expand-kw req opt rest (cdr kw) body (cons v vars)
- r** w** aok
- (cons (list (syntax->datum #'k)
- (syntax->datum #'id)
- v)
- out)
- (cons (chi #'i r* w* mod) inits))))))
+ (parse-kw req opt rest (cdr kw) body (cons v vars)
+ r** w** aok
+ (cons (list (syntax->datum #'k)
+ (syntax->datum #'id)
+ v)
+ out)
+ (cons (expand #'i r* w* mod) inits))))))
(else
- (expand-body req opt rest
- (if (or aok (pair? out)) (cons aok (reverse out)) #f)
- body (reverse vars) r* w* (reverse inits) '()))))
- (define (expand-body req opt rest kw body vars r* w* inits meta)
+ (parse-body req opt rest
+ (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+ body (reverse vars) r* w* (reverse inits) '()))))
+ (define (parse-body req opt rest kw body vars r* w* inits meta)
(syntax-case body ()
((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
- (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
- (append meta
- `((documentation
- . ,(syntax->datum #'docstring))))))
+ (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+ (append meta
+ `((documentation
+ . ,(syntax->datum #'docstring))))))
((#((k . v) ...) e1 e2 ...)
- (expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
- (append meta (syntax->datum #'((k . v) ...)))))
+ (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
+ (append meta (syntax->datum #'((k . v) ...)))))
((e1 e2 ...)
(values meta req opt rest kw inits vars
- (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
- r* w* mod)))))
+ (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))))
(syntax-case clauses ()
(() (values '() #f))
(call-with-values (lambda () (get-formals #'args))
(lambda (req opt rest kw)
(call-with-values (lambda ()
- (expand-req req opt rest kw #'(e1 e2 ...)))
+ (parse-req req opt rest kw #'(e1 e2 ...)))
(lambda (meta req opt rest kw inits vars body)
(call-with-values
(lambda ()
- (chi-lambda-case e r w s mod get-formals
- #'((args* e1* e2* ...) ...)))
+ (expand-lambda-case e r w s mod get-formals
+ #'((args* e1* e2* ...) ...)))
(lambda (meta* else*)
(values
(append meta meta*)
((vector? x)
(let ((old (vector->list x)))
(let ((new (map f old)))
- (if (and-map* eq? old new) x (list->vector new)))))
+ ;; inlined and-map with two args
+ (let lp ((l1 old) (l2 new))
+ (if (null? l1)
+ x
+ (if (eq? (car l1) (car l2))
+ (lp (cdr l1) (cdr l2))
+ (list->vector new)))))))
(else x))))))
;; lexical variables
(source-wrap id w s mod)))))
#'(var ...)
names)
- (chi-body
+ (expand-body
#'(e1 e2 ...)
(source-wrap e w s mod)
(extend-env
(let ((trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
- (eval-local-transformer (chi x trans-r w mod)
+ (eval-local-transformer (expand x trans-r w mod)
mod)))
#'(val ...)))
r)
((#((k . v) ...) e1 e2 ...)
(lp #'(e1 e2 ...)
(append meta (syntax->datum #'((k . v) ...)))))
- (_ (chi-simple-lambda e r w s mod req rest meta body)))))))
+ (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
(_ (syntax-violation 'lambda "bad lambda" e)))))
(global-extend 'core 'lambda*
((_ args e1 e2 ...)
(call-with-values
(lambda ()
- (chi-lambda-case e r w s mod
- lambda*-formals #'((args e1 e2 ...))))
+ (expand-lambda-case e r w s mod
+ lambda*-formals #'((args e1 e2 ...))))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'lambda "bad lambda*" e)))))
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values
(lambda ()
- (chi-lambda-case e r w s mod
- lambda-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ (expand-lambda-case e r w s mod
+ lambda-formals
+ #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values
(lambda ()
- (chi-lambda-case e r w s mod
- lambda*-formals
- #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ (expand-lambda-case e r w s mod
+ lambda*-formals
+ #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(lambda (meta lcase)
(build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
(global-extend 'core 'let
(let ()
- (define (chi-let e r w s mod constructor ids vals exps)
+ (define (expand-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids))
(syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(constructor s
(map syntax->datum ids)
new-vars
- (map (lambda (x) (chi x r w mod)) vals)
- (chi-body exps (source-wrap e nw s mod)
- nr nw mod))))))
+ (map (lambda (x) (expand x r w mod)) vals)
+ (expand-body exps (source-wrap e nw s mod)
+ nr nw mod))))))
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(and-map id? #'(id ...))
- (chi-let e r w s mod
- build-let
- #'(id ...)
- #'(val ...)
- #'(e1 e2 ...)))
+ (expand-let e r w s mod
+ build-let
+ #'(id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
((_ f ((id val) ...) e1 e2 ...)
(and (id? #'f) (and-map id? #'(id ...)))
- (chi-let e r w s mod
- build-named-let
- #'(f id ...)
- #'(val ...)
- #'(e1 e2 ...)))
+ (expand-let e r w s mod
+ build-named-let
+ #'(f id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
(build-letrec s #f
(map syntax->datum ids)
new-vars
- (map (lambda (x) (chi x r w mod)) #'(val ...))
- (chi-body #'(e1 e2 ...)
- (source-wrap e w s mod) r w mod)))))))
+ (map (lambda (x) (expand x r w mod)) #'(val ...))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(build-letrec s #t
(map syntax->datum ids)
new-vars
- (map (lambda (x) (chi x r w mod)) #'(val ...))
- (chi-body #'(e1 e2 ...)
- (source-wrap e w s mod) r w mod)))))))
+ (map (lambda (x) (expand x r w mod)) #'(val ...))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
(build-lexical-assignment s
(syntax->datum #'id)
(binding-value b)
- (chi #'val r w mod)))
+ (expand #'val r w mod)))
((global)
- (build-global-assignment s n (chi #'val r w mod) id-mod))
+ (build-global-assignment s n (expand #'val r w mod) id-mod))
((macro)
(let ((p (binding-value b)))
(if (procedure-property p 'variable-transformer)
- ;; As syntax-type does, call chi-macro with
+ ;; As syntax-type does, call expand-macro with
;; the mod of the expression. Hmm.
- (chi (chi-macro p e r w s #f mod) r empty-wrap mod)
+ (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
(syntax-violation 'set! "not a variable transformer"
(wrap e w mod)
(wrap #'id w id-mod)))))
(lambda (type value ee ww ss modmod)
(case type
((module-ref)
- (let ((val (chi #'val r w mod)))
+ (let ((val (expand #'val r w mod)))
(call-with-values (lambda () (value #'(head tail ...) r w))
(lambda (e r w s* mod)
(syntax-case e ()
val mod)))))))
(else
(build-application s
- (chi #'(setter head) r w mod)
- (map (lambda (e) (chi e r w mod))
+ (expand #'(setter head) r w mod)
+ (map (lambda (e) (expand e r w mod))
#'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
((_ test then)
(build-conditional
s
- (chi #'test r w mod)
- (chi #'then r w mod)
+ (expand #'test r w mod)
+ (expand #'then r w mod)
(build-void no-source)))
((_ test then else)
(build-conditional
s
- (chi #'test r w mod)
- (chi #'then r w mod)
- (chi #'else r w mod))))))
+ (expand #'test r w mod)
+ (expand #'then r w mod)
+ (expand #'else r w mod))))))
(global-extend 'core 'with-fluids
(lambda (e r w s mod)
((_ ((fluid val) ...) b b* ...)
(build-dynlet
s
- (map (lambda (x) (chi x r w mod)) #'(fluid ...))
- (map (lambda (x) (chi x r w mod)) #'(val ...))
- (chi-body #'(b b* ...)
- (source-wrap e w s mod) r w mod))))))
+ (map (lambda (x) (expand x r w mod)) #'(fluid ...))
+ (map (lambda (x) (expand x r w mod)) #'(val ...))
+ (expand-body #'(b b* ...)
+ (source-wrap e w s mod) r w mod))))))
(global-extend 'begin 'begin '())
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
- (if (null? p*)
- (values '() ids)
+ (if (not (pair? p*))
+ (cvt p* n ids)
(call-with-values
(lambda () (cvt* (cdr p*) n ids))
(lambda (y ids)
(lambda () (cvt (car p*) n ids))
(lambda (x ids)
(values (cons x y) ids))))))))
+
+ (define (v-reverse x)
+ (let loop ((r '()) (x x))
+ (if (not (pair? x))
+ (values r x)
+ (loop (cons (car x) r) (cdr x)))))
+
(define cvt
(lambda (p n ids)
(if (id? p)
(lambda (p ids)
(values (if (eq? p 'any) 'each-any (vector 'each p))
ids))))
- ((x dots ys ...)
+ ((x dots . ys)
(ellipsis? (syntax dots))
(call-with-values
- (lambda () (cvt* (syntax (ys ...)) n ids))
+ (lambda () (cvt* (syntax ys) n ids))
(lambda (ys ids)
(call-with-values
(lambda () (cvt (syntax x) (+ n 1) ids))
(lambda (x ids)
- (values `#(each+ ,x ,(reverse ys) ()) ids))))))
+ (call-with-values
+ (lambda () (v-reverse ys))
+ (lambda (ys e)
+ (values `#(each+ ,x ,ys ,e)
+ ids))))))))
((x . y)
(call-with-values
(lambda () (cvt (syntax y) n ids))
(build-application no-source
(build-primref no-source 'apply)
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
- (chi exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)
- mod))
+ (expand exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
y))))))
(define gen-clause
(and-map (lambda (x) (not (free-id=? #'pat x)))
(cons #'(... ...) keys)))
(if (free-id=? #'pad #'_)
- (chi #'exp r empty-wrap mod)
+ (expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
(build-application no-source
(build-simple-lambda
no-source (list (syntax->datum #'pat)) #f (list var)
'()
- (chi #'exp
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap #'(pat)
- labels empty-wrap)
- mod))
+ (expand #'exp
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap #'(pat)
+ labels empty-wrap)
+ mod))
(list x))))
(gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod)))
#'(key ...) #'(m ...)
r
mod))
- (list (chi #'val r empty-wrap mod))))
+ (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))))))))
- ;; The portable macroexpand seeds chi-top's mode m with 'e (for
+ ;; The portable macroexpand seeds expand-top's mode m with 'e (for
;; evaluating) and esew (which stands for "eval syntax expanders
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
;; if we are compiling a file, and esew is set to
;; the object file if we are compiling a file.
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
- (chi-top x null-env top-wrap m esew
- (cons 'hygiene (module-name (current-module))))))
+ (expand-top-sequence (list x) null-env top-wrap #f m esew
+ (cons 'hygiene (module-name (current-module))))))
(set! identifier?
(lambda (x)
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (map (lambda (x) (wrap (gensym-hook) top-wrap mod)) ls))))
(set! free-identifier=?
(lambda (x y)
(bound-id=? x y)))
(set! syntax-violation
- (lambda (who message form . subform)
+ (lambda* (who message form #:optional subform)
(arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
who 'syntax-violation)
(arg-check string? message 'syntax-violation)
- (scm-error 'syntax-error 'macroexpand
- (string-append
- (if who "~a: " "")
- "~a "
- (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
- (let ((tail (cons message
- (map (lambda (x) (strip x empty-wrap))
- (append subform (list form))))))
- (if who (cons who tail) tail))
- #f)))
+ (throw 'syntax-error who message
+ (source-annotation (or form subform))
+ (strip form empty-wrap)
+ (and subform (strip subform empty-wrap)))))
;; $sc-dispatch expects an expression and a pattern. If the expression
;; matches the pattern a list of the matching expressions for each
(lambda (x)
(syntax-case x ()
((_ () e1 e2 ...)
- #'(begin e1 e2 ...))
+ #'(let () e1 e2 ...))
((_ ((out in)) e1 e2 ...)
- #'(syntax-case in () (out (begin e1 e2 ...))))
+ #'(syntax-case in ()
+ (out (let () e1 e2 ...))))
((_ ((out in) ...) e1 e2 ...)
#'(syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...)))))))
+ ((out ...) (let () e1 e2 ...)))))))
(define-syntax syntax-rules
(lambda (x)
((dummy . pattern) #'template)
...))))))
+(define-syntax define-syntax-rule
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name . pattern) template)
+ #'(define-syntax name
+ (syntax-rules ()
+ ((_ . pattern) template))))
+ ((_ (name . pattern) docstring template)
+ (string? (syntax->datum #'docstring))
+ #'(define-syntax name
+ (syntax-rules ()
+ docstring
+ ((_ . pattern) template)))))))
+
(define-syntax let*
(lambda (x)
(syntax-case x ()
(begin c ... (doloop step ...)))))))))))
(define-syntax quasiquote
- (letrec
- ((quasicons
- (lambda (x y)
- (with-syntax ((x x) (y y))
- (syntax-case #'y (quote list)
- ((quote dy)
- (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 #'y (quote)
- ((quote ()) #'x)
- (_ #'(append x y))))))
- (quasivector
- (lambda (x)
- (with-syntax ((x 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)
- #'p
- (quasicons #'(quote unquote)
- (quasi #'(p) (- lev 1)))))
- ((unquote . args)
- (= lev 0)
- (syntax-violation 'unquote
- "unquote takes exactly one argument"
- p #'(unquote . args)))
- (((unquote-splicing p) . q)
- (if (= lev 0)
- (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 #'(unquote-splicing . args)))
- ((quasiquote p)
- (quasicons #'(quote quasiquote)
- (quasi #'(p) (+ lev 1))))
- ((p . q)
- (quasicons (quasi #'p lev) (quasi #'q lev)))
- (#(x ...) (quasivector (quasi #'(x ...) lev)))
- (p #'(quote p))))))
+ (let ()
+ (define (quasi p lev)
+ (syntax-case p (unquote quasiquote)
+ ((unquote p)
+ (if (= lev 0)
+ #'("value" p)
+ (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
+ ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
+ ((p . q)
+ (syntax-case #'p (unquote unquote-splicing)
+ ((unquote p ...)
+ (if (= lev 0)
+ (quasilist* #'(("value" p) ...) (quasi #'q lev))
+ (quasicons
+ (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
+ (quasi #'q lev))))
+ ((unquote-splicing p ...)
+ (if (= lev 0)
+ (quasiappend #'(("value" p) ...) (quasi #'q lev))
+ (quasicons
+ (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
+ (quasi #'q lev))))
+ (_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
+ (#(x ...) (quasivector (vquasi #'(x ...) lev)))
+ (p #'("quote" p))))
+ (define (vquasi p lev)
+ (syntax-case p ()
+ ((p . q)
+ (syntax-case #'p (unquote unquote-splicing)
+ ((unquote p ...)
+ (if (= lev 0)
+ (quasilist* #'(("value" p) ...) (vquasi #'q lev))
+ (quasicons
+ (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
+ (vquasi #'q lev))))
+ ((unquote-splicing p ...)
+ (if (= lev 0)
+ (quasiappend #'(("value" p) ...) (vquasi #'q lev))
+ (quasicons
+ (quasicons
+ #'("quote" unquote-splicing)
+ (quasi #'(p ...) (- lev 1)))
+ (vquasi #'q lev))))
+ (_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
+ (() #'("quote" ()))))
+ (define (quasicons x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case #'y ()
+ (("quote" dy)
+ (syntax-case #'x ()
+ (("quote" dx) #'("quote" (dx . dy)))
+ (_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
+ (("list" . stuff) #'("list" x . stuff))
+ (("list*" . stuff) #'("list*" x . stuff))
+ (_ #'("list*" x y)))))
+ (define (quasiappend x y)
+ (syntax-case y ()
+ (("quote" ())
+ (cond
+ ((null? x) #'("quote" ()))
+ ((null? (cdr x)) (car x))
+ (else (with-syntax (((p ...) x)) #'("append" p ...)))))
+ (_
+ (cond
+ ((null? x) y)
+ (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
+ (define (quasilist* x y)
+ (let f ((x x))
+ (if (null? x)
+ y
+ (quasicons (car x) (f (cdr x))))))
+ (define (quasivector x)
+ (syntax-case x ()
+ (("quote" (x ...)) #'("quote" #(x ...)))
+ (_
+ (let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
+ (syntax-case y ()
+ (("quote" (y ...)) (k #'(("quote" y) ...)))
+ (("list" y ...) (k #'(y ...)))
+ (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
+ (else #`("list->vector" #,x)))))))
+ (define (emit x)
+ (syntax-case x ()
+ (("quote" x) #''x)
+ (("list" x ...) #`(list #,@(map emit #'(x ...))))
+ ;; could emit list* for 3+ arguments if implementation supports
+ ;; list*
+ (("list*" x ... y)
+ (let f ((x* #'(x ...)))
+ (if (null? x*)
+ (emit #'y)
+ #`(cons #,(emit (car x*)) #,(f (cdr x*))))))
+ (("append" x ...) #`(append #,@(map emit #'(x ...))))
+ (("vector" x ...) #`(vector #,@(map emit #'(x ...))))
+ (("list->vector" x) #`(list->vector #,(emit #'x)))
+ (("value" x) #'x)))
(lambda (x)
- (syntax-case x ()
- ((_ e) (quasi #'e 0))))))
+ (syntax-case x ()
+ ;; convert to intermediate language, combining introduced (but
+ ;; not unquoted source) quote expressions where possible and
+ ;; choosing optimal construction code otherwise, then emit
+ ;; Scheme code corresponding to the intermediate language forms.
+ ((_ e) (emit (quasi #'e 0)))))))
(define-syntax include
(lambda (x)
(define-syntax unquote
(lambda (x)
- (syntax-case x ()
- ((_ e)
- (syntax-violation 'unquote
- "expression not valid outside of quasiquote"
- x)))))
+ (syntax-violation 'unquote
+ "expression not valid outside of quasiquote"
+ x)))
(define-syntax unquote-splicing
(lambda (x)
- (syntax-case x ()
- ((_ e)
- (syntax-violation 'unquote-splicing
- "expression not valid outside of quasiquote"
- x)))))
+ (syntax-violation 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ x)))
(define-syntax case
(lambda (x)
HCoop / bpt / guile.git / blobdiff