;;; Extracted from Chez Scheme Version 5.9f
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
+;;; revision control logs corresponding to this file: 2009.
+
;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
;;; to the ChangeLog distributed in the same directory as this file:
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
;;; also documented in the R4RS and draft R5RS.
;;;
;;; bound-identifier=?
-;;; datum->syntax-object
+;;; datum->syntax
;;; define-syntax
;;; fluid-let-syntax
;;; free-identifier=?
;;; letrec-syntax
;;; syntax
;;; syntax-case
-;;; syntax-object->datum
+;;; syntax->datum
;;; syntax-rules
;;; with-syntax
;;;
;;; conditionally evaluates expr ... at compile-time or run-time
;;; depending upon situations (see the Chez Scheme System Manual,
;;; Revision 3, for a complete description)
-;;; (syntax-error object message)
+;;; (syntax-violation who message form [subform])
;;; used to report errors found during expansion
-;;; (install-global-transformer symbol value)
-;;; used by expanded code to install top-level syntactic abstractions
-;;; (syntax-dispatch e p)
+;;; ($sc-dispatch e p)
;;; used by expanded code to handle syntax-case matching
;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value". This
-;;; usually works: (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 ....
-;;; The following definition works but does no error checking:
-;;;
-;;; (define andmap
-;;; (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 (cons x xr))
-;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
+;;; hooks and output constructors. They are not used by expanded code,
;;; and so need be present only at expansion time.
;;;
;;; (eval x)
;;; by eval, and eval accepts one argument, nothing special must be done
;;; to support the "noexpand" flag, since it is handled by sc-expand.
;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object. error should
-;;; signal an error with a message something like
-;;;
-;;; "error in <who>: <why> <what>"
-;;;
;;; (gensym)
;;; returns a unique symbol each time it's called
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; key is always the symbol *sc-expander*; value may be any object.
-;;; putprop should associate the given value with the given symbol in
-;;; some way that it can be retrieved later with getprop.
;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax object, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; are contained within a syntax form or produced by datum->syntax.
;;; Such objects are never copied.
;;; All identifiers that don't have macro definitions and are not bound
+(eval-when (compile)
+ (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 (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
(define-syntax define-structure
(lambda (x)
(define construct-name
(lambda (template-identifier . args)
- (datum->syntax-object
+ (datum->syntax
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
- (symbol->string (syntax-object->datum x))))
+ (symbol->string (syntax->datum x))))
args))))))
(syntax-case x ()
((_ (name id1 ...))
- (andmap identifier? (syntax (name id1 ...)))
+ (and-map identifier? (syntax (name id1 ...)))
(with-syntax
((constructor (construct-name (syntax name) "make-" (syntax name)))
(predicate (construct-name (syntax name) (syntax name) "?"))
(let ()
(define noexpand "noexpand")
+(define *mode* (make-fluid))
;;; hooks to nonportable run-time helpers
(begin
(define fx< <)
(define top-level-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x) (interaction-environment))))
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define local-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x) (interaction-environment))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define-syntax gensym-hook
(syntax-rules ()
((_) (gensym))))
(define put-global-definition-hook
- (lambda (symbol binding)
- (putprop symbol '*sc-expander* binding)))
+ (lambda (symbol type val)
+ (let ((existing (let ((v (module-variable (current-module) symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (not (syncase-macro-type val))
+ val))))))
+ (module-define! (current-module)
+ symbol
+ (if existing
+ (make-extended-syncase-macro existing type val)
+ (make-syncase-macro type val))))))
(define get-global-definition-hook
- (lambda (symbol)
- (getprop symbol '*sc-expander*)))
+ (lambda (symbol module)
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (syncase-macro-type val)
+ (cons (syncase-macro-type val)
+ (syncase-macro-binding val))))))))
+
)
;;; output constructors
-(define (build-annotated src exp)
- (if (and src (not (annotation? exp)))
- (make-annotation exp src #t)
- exp))
-
-(define-syntax build-application
- (syntax-rules ()
- ((_ source fun-exp arg-exps)
- (build-annotated source `(,fun-exp . ,arg-exps)))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ source test-exp then-exp else-exp)
- (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
-
-(define-syntax build-lexical-reference
- (syntax-rules ()
- ((_ type source var)
- (build-annotated source var))))
-
-(define-syntax build-lexical-assignment
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(set! ,var ,exp)))))
-
-(define-syntax build-global-reference
- (syntax-rules ()
- ((_ source var)
- (build-annotated source var))))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(set! ,var ,exp)))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(define ,var ,exp)))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars exp)
- (build-annotated src `(lambda ,vars ,exp)))))
-
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) (build-annotated src name))
- ((_ src level name) (build-annotated src name))))
+(define build-application
+ (lambda (source fun-exp arg-exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+ (else `(,fun-exp . ,arg-exps)))))
+
+(define build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-conditional)
+ source test-exp then-exp else-exp))
+ (else `(if ,test-exp ,then-exp ,else-exp)))))
+
+(define build-lexical-reference
+ (lambda (type source name var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else var))))
+
+(define build-lexical-assignment
+ (lambda (source name var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+ (else `(set! ,var ,exp)))))
+
+;; Before modules are booted, we can't expand into data structures from
+;; (language tree-il) -- we need to give the evaluator the
+;; s-expressions that it understands natively. Actually the real truth
+;; of the matter is that the evaluator doesn't understand tree-il
+;; structures at all. So until we fix the evaluator, if ever, the
+;; conflation that we should use tree-il iff we are compiling
+;; holds true.
+;;
+(define (analyze-variable mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod))
+ (mod (cdr mod)))
+ (case kind
+ ((public) (modref-cont mod var #t))
+ ((private) (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((bare) (bare-cont var))
+ ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))
+
+(define build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+ (else (list (if public? '@ '@@) mod var))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else var))))))
+
+(define build-global-assignment
+ (lambda (source var exp mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
+ (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else `(set! ,var ,exp)))))))
+
+(define build-global-definition
+ (lambda (source var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-define) source var exp))
+ (else `(define ,var ,exp)))))
+
+(define build-lambda
+ (lambda (src ids vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src ids vars
+ (if docstring `((documentation . ,docstring)) '())
+ exp))
+ (else `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)))))
+
+(define build-primref
+ (lambda (src name)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-primitive-ref) src name))
+ ;; hygiene guile is a hack
+ (else (build-global-reference src name '(hygiene guile))))))
(define (build-data src exp)
- (if (and (self-evaluating? exp)
- (not (vector? exp)))
- (build-annotated src exp)
- (build-annotated src (list 'quote exp))))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-const) src exp))
+ (else (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
- (build-annotated src (car exps))
- (build-annotated src `(begin ,@exps)))))
+ (car exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-sequence) src exps))
+ (else `(begin ,@exps))))))
(define build-let
- (lambda (src vars val-exps body-exp)
+ (lambda (src ids vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
+ (else `(let ,(map list vars val-exps) ,body-exp))))))
(define build-named-let
- (lambda (src vars val-exps body-exp)
- (if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(let ,(car vars)
- ,(map list (cdr vars) val-exps) ,body-exp)))))
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars))
+ (f-name (car ids))
+ (vars (cdr vars))
+ (ids (cdr ids)))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-letrec) src
+ (list f-name)
+ (list f)
+ (list (build-lambda src ids vars #f body-exp))
+ (build-application src (build-lexical-reference 'fun src f-name f)
+ val-exps)))
+ (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
(define build-letrec
- (lambda (src vars val-exps body-exp)
+ (lambda (src ids vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(letrec ,(map list vars val-exps) ,body-exp)))))
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
+ (else `(letrec ,(map list vars val-exps) ,body-exp))))))
+;; FIXME: wingo: use make-lexical ?
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+ ((_ src id) (gensym (symbol->string id)))))
-(define-structure (syntax-object expression wrap))
+(define-structure (syntax-object expression wrap module))
(define-syntax unannotate
(syntax-rules ()
(syntax-rules ()
((_ pred? e who)
(let ((x e))
- (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+ (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
;;; compile-time environments
;;; <binding> ::= (macro . <procedure>) macros
;;; (core . <procedure>) core forms
;;; (external-macro . <procedure>) external-macro
+;;; (module-ref . <procedure>) @ or @@
;;; (begin) begin
;;; (define) define
;;; (define-syntax) define-syntax
; although symbols are usually global, we check the environment first
; anyway because a temporary binding may have been established by
; fluid-let-syntax
- (lambda (x r)
+ (lambda (x r mod)
(cond
((assq x r) => cdr)
((symbol? x)
- (or (get-global-definition-hook x) (make-binding 'global)))
+ (or (get-global-definition-hook x mod) (make-binding 'global)))
(else (make-binding 'displaced-lexical)))))
(define global-extend
(lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val))))
+ (put-global-definition-hook sym type val)))
;;; Conceptually, identifiers are always syntax objects. Internally,
((annotation? id)
(let ((id (unannotate id)))
(or (first (search id (wrap-subst w) (wrap-marks w))) id)))
- (else (error-hook 'id-var-name "invalid id" id)))))
+ (else (syntax-violation 'id-var-name "invalid id" id)))))
;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
;;; wrapping expressions and identifiers
(define wrap
- (lambda (x w)
+ (lambda (x w defmod)
(cond
((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
((syntax-object? x)
(make-syntax-object
(syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))))
+ (join-wraps w (syntax-object-wrap x))
+ (syntax-object-module x)))
((null? x) x)
- (else (make-syntax-object x w)))))
+ (else (make-syntax-object x w defmod)))))
(define source-wrap
- (lambda (x w s)
- (wrap (if s (make-annotation x s #f) x) w)))
+ (lambda (x w s defmod)
+ (wrap (if s (make-annotation x s #f) x) w defmod)))
;;; expanding
(define chi-sequence
- (lambda (body r w s)
+ (lambda (body r w s mod)
(build-sequence s
- (let dobody ((body body) (r r) (w w))
+ (let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body)
'()
- (let ((first (chi (car body) r w)))
- (cons first (dobody (cdr body) r w))))))))
+ (let ((first (chi (car body) r w mod)))
+ (cons first (dobody (cdr body) r w mod))))))))
(define chi-top-sequence
- (lambda (body r w s m esew)
+ (lambda (body r w s m esew mod)
(build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew))
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
(if (null? body)
'()
- (let ((first (chi-top (car body) r w m esew)))
- (cons first (dobody (cdr body) r w m esew))))))))
+ (let ((first (chi-top (car body) r w m esew mod)))
+ (cons first (dobody (cdr body) r w m esew mod))))))))
(define chi-install-global
(lambda (name e)
- (build-application no-source
- (build-primref no-source 'install-global-transformer)
- (list (build-data no-source name) e))))
+ (build-global-definition
+ no-source
+ name
+ ;; FIXME: seems nasty to call current-module here
+ (if (let ((v (module-variable (current-module) name)))
+ ;; FIXME use primitive-macro?
+ (and v (variable-bound? v) (macro? (variable-ref v))
+ (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-extended-syncase-macro)
+ (list (build-application
+ no-source
+ (build-primref no-source 'module-ref)
+ (list (build-application no-source 'current-module '())
+ (build-data no-source name)))
+ (build-data no-source 'macro)
+ e))
+ (build-application
+ no-source
+ (build-primref no-source 'make-syncase-macro)
+ (list (build-data no-source 'macro) e))))))
(define chi-when-list
(lambda (e when-list w)
((free-id=? x (syntax compile)) 'compile)
((free-id=? x (syntax load)) 'load)
((free-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w)
- "invalid eval-when situation"))))
+ (else (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap x w #f)))))
situations))))))
-;;; syntax-type returns five values: type, value, e, w, and s. The first
-;;; two are described in the table below.
+;;; syntax-type returns six values: type, value, e, w, s, and mod. The
+;;; first two are described in the table below.
;;;
;;; type value explanation
;;; -------------------------------------------------------------------
;;; core procedure core form (including singleton)
;;; external-macro procedure external macro
+;;; module-ref procedure @ or @@ form
;;; lexical name lexical variable reference
;;; global name global variable reference
;;; begin none begin keyword
;;;
;;; For define-form and define-syntax-form, e is the rhs expression.
;;; For all others, e is the entire form. w is the wrap for e.
-;;; s is the source for the entire form.
+;;; s is the source for the entire form. mod is the module for e.
;;;
;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above. It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer.
(define syntax-type
- (lambda (e r w s rib)
+ (lambda (e r w s rib mod)
(cond
((symbol? e)
(let* ((n (id-var-name e w))
- (b (lookup n r))
+ (b (lookup n r mod))
(type (binding-type b)))
(case type
- ((lexical) (values type (binding-value b) e w s))
- ((global) (values type n e w s))
+ ((lexical) (values type (binding-value b) e w s mod))
+ ((global) (values type n e w s mod))
((macro)
- (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
- (else (values type (binding-value b) e w s)))))
+ (syntax-type (chi-macro (binding-value b) e r w rib mod)
+ r empty-wrap s rib mod))
+ (else (values type (binding-value b) e w s mod)))))
((pair? e)
(let ((first (car e)))
(if (id? first)
(let* ((n (id-var-name first w))
- (b (lookup n r))
+ (b (lookup n r (or (and (syntax-object? first)
+ (syntax-object-module first))
+ mod)))
(type (binding-type b)))
(case type
- ((lexical) (values 'lexical-call (binding-value b) e w s))
- ((global) (values 'global-call n e w s))
+ ((lexical)
+ (values 'lexical-call (binding-value b) e w s mod))
+ ((global)
+ (values 'global-call n e w s mod))
((macro)
- (syntax-type (chi-macro (binding-value b) e r w rib)
- r empty-wrap s rib))
- ((core external-macro) (values type (binding-value b) e w s))
+ (syntax-type (chi-macro (binding-value b) e r w rib mod)
+ r empty-wrap s rib mod))
+ ((core external-macro module-ref)
+ (values type (binding-value b) e w s mod))
((local-syntax)
- (values 'local-syntax-form (binding-value b) e w s))
- ((begin) (values 'begin-form #f e w s))
- ((eval-when) (values 'eval-when-form #f e w s))
+ (values 'local-syntax-form (binding-value b) e w s mod))
+ ((begin)
+ (values 'begin-form #f e w s mod))
+ ((eval-when)
+ (values 'eval-when-form #f e w s mod))
((define)
(syntax-case e ()
((_ name val)
(id? (syntax name))
- (values 'define-form (syntax name) (syntax val) w s))
+ (values 'define-form (syntax name) (syntax val) w s mod))
((_ (name . args) e1 e2 ...)
(and (id? (syntax name))
(valid-bound-ids? (lambda-var-list (syntax args))))
; need lambda here...
- (values 'define-form (wrap (syntax name) w)
- (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
- empty-wrap s))
+ (values 'define-form (wrap (syntax name) w mod)
+ (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
+ empty-wrap s mod))
((_ name)
(id? (syntax name))
- (values 'define-form (wrap (syntax name) w)
- (syntax (void))
- empty-wrap s))))
+ (values 'define-form (wrap (syntax name) w mod)
+ (syntax (if #f #f))
+ empty-wrap s mod))))
((define-syntax)
(syntax-case e ()
((_ name val)
(id? (syntax name))
(values 'define-syntax-form (syntax name)
- (syntax val) w s))))
- (else (values 'call #f e w s))))
- (values 'call #f e w s))))
+ (syntax val) w s mod))))
+ (else
+ (values 'call #f e w s mod))))
+ (values 'call #f e w s mod))))
((syntax-object? e)
;; s can't be valid source if we've unwrapped
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
- no-source rib))
+ no-source rib (or (syntax-object-module e) mod)))
((annotation? e)
- (syntax-type (annotation-expression e) r w (annotation-source e) rib))
- ((self-evaluating? e) (values 'constant #f e w s))
- (else (values 'other #f e w s)))))
+ (syntax-type (annotation-expression e) r w (annotation-source e) rib mod))
+ ((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)
+ (lambda (e r w m esew mod)
(define-syntax eval-if-c&e
(syntax-rules ()
- ((_ m e)
+ ((_ m e mod)
(let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x))
+ (if (eq? m 'c&e) (top-level-eval-hook x mod))
x))))
(call-with-values
- (lambda () (syntax-type e r w no-source #f))
- (lambda (type value e w s)
+ (lambda () (syntax-type e r w no-source #f mod))
+ (lambda (type value e w s mod)
(case type
((begin-form)
(syntax-case e ()
((_) (chi-void))
((_ e1 e2 ...)
- (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
+ (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
((local-syntax-form)
- (chi-local-syntax value e r w s
- (lambda (body r w s)
- (chi-top-sequence body r w s m esew))))
+ (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 ...)
(cond
((eq? m 'e)
(if (memq 'eval when-list)
- (chi-top-sequence body r w s 'e '(eval))
+ (chi-top-sequence body r w s 'e '(eval) mod)
(chi-void)))
((memq 'load when-list)
(if (or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load))
+ (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))
+ (chi-top-sequence body r w s 'c '(load) mod)
(chi-void))))
((or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval)))
+ (chi-top-sequence body r w s 'e '(eval) mod)
+ mod)
(chi-void))
(else (chi-void)))))))
((define-syntax-form)
(case m
((c)
(if (memq 'compile esew)
- (let ((e (chi-install-global n (chi e r w))))
- (top-level-eval-hook e)
+ (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))
+ (chi-install-global n (chi e r w mod))
(chi-void))))
((c&e)
- (let ((e (chi-install-global n (chi e r w))))
- (top-level-eval-hook 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))))
+ (chi-install-global n (chi e r w mod))
+ mod))
(chi-void)))))
((define-form)
(let* ((n (id-var-name value w))
- (type (binding-type (lookup n r))))
+ (type (binding-type (lookup n r mod))))
(case type
- ((global)
+ ((global core macro module-ref)
(eval-if-c&e m
- (build-global-definition s n (chi e r w))))
+ (build-global-definition s n (chi e r w mod))
+ mod))
((displaced-lexical)
- (syntax-error (wrap value w) "identifier out of context"))
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
(else
- (if (eq? type 'external-macro)
- (eval-if-c&e m
- (build-global-definition s n (chi e r w)))
- (syntax-error (wrap value w)
- "cannot define keyword at top level"))))))
- (else (eval-if-c&e m (chi-expr type value e r w s))))))))
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
(define chi
- (lambda (e r w)
+ (lambda (e r w mod)
(call-with-values
- (lambda () (syntax-type e r w no-source #f))
- (lambda (type value e w s)
- (chi-expr type value e r w s)))))
+ (lambda () (syntax-type e r w no-source #f mod))
+ (lambda (type value e w s mod)
+ (chi-expr type value e r w s mod)))))
(define chi-expr
- (lambda (type value e r w s)
+ (lambda (type value e r w s mod)
(case type
((lexical)
- (build-lexical-reference 'value s value))
- ((core external-macro) (value e r w s))
+ (build-lexical-reference 'value s e value))
+ ((core external-macro)
+ ;; apply transformer
+ (value e r w s mod))
+ ((module-ref)
+ (call-with-values (lambda () (value e))
+ ;; we could add a public? arg here
+ (lambda (id mod) (build-global-reference s id mod))))
((lexical-call)
(chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
- e r w s))
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
+ e r w s mod))
((global-call)
(chi-application
- (build-global-reference (source-annotation (car e)) value)
- e r w s))
- ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
- ((global) (build-global-reference s value))
- ((call) (chi-application (chi (car e) r w) e r w s))
+ (build-global-reference (source-annotation (car e)) value
+ (if (syntax-object? (car e))
+ (syntax-object-module (car e))
+ mod))
+ e r w s mod))
+ ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
+ ((global) (build-global-reference s value mod))
+ ((call) (chi-application (chi (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
+ ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
((local-syntax-form)
- (chi-local-syntax value e r w s chi-sequence))
+ (chi-local-syntax value e r w s mod chi-sequence))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e (syntax (x ...)) w)))
(if (memq 'eval when-list)
- (chi-sequence (syntax (e1 e2 ...)) r w s)
+ (chi-sequence (syntax (e1 e2 ...)) r w s mod)
(chi-void))))))
((define-form define-syntax-form)
- (syntax-error (wrap value w) "invalid context for definition of"))
+ (syntax-violation #f "definition in expression context"
+ e (wrap value w mod)))
((syntax)
- (syntax-error (source-wrap e w s)
- "reference to pattern variable outside syntax form"))
+ (syntax-violation #f "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
((displaced-lexical)
- (syntax-error (source-wrap e w s)
- "reference to identifier outside its scope"))
- (else (syntax-error (source-wrap e w s))))))
+ (syntax-violation #f "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
+ (else (syntax-violation #f "unexpected syntax"
+ (source-wrap e w s mod))))))
(define chi-application
- (lambda (x e r w s)
+ (lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
(build-application s x
- (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
+ (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
(define chi-macro
- (lambda (p e r w rib)
+ (lambda (p e r w rib mod)
(define rebuild-macro-output
(lambda (x m)
(cond ((pair? x)
((syntax-object? x)
(let ((w (syntax-object-wrap x)))
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (make-syntax-object (syntax-object-expression x)
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- (make-wrap (cdr ms)
- (if rib (cons rib (cdr s)) (cdr s)))
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s))))))))
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ ;; output is from original text
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ (syntax-object-module x))
+ ;; output introduced by macro
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s)))
+ (let ((pmod (procedure-module p)))
+ (if pmod
+ ;; hither the hygiene
+ (cons 'hygiene (module-name pmod))
+ ;; but it's possible for the proc to have
+ ;; no mod, if it was made before modules
+ ;; were booted
+ '(hygiene guile))))))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
(vector-set! v i
(rebuild-macro-output (vector-ref x i) m)))))
((symbol? x)
- (syntax-error x "encountered raw symbol in macro output"))
+ (syntax-violation #f "encountered raw symbol in macro output"
+ (source-wrap e w s mod) x))
(else x))))
- (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
+ (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
(define chi-body
;; In processing the forms of the body, we create a new, empty wrap.
;; into the body.
;;
;; outer-form is fully wrapped w/source
- (lambda (body outer-form r w)
+ (lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" . (placeholder)) r))
(ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
- (let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
(ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
(if (null? body)
- (syntax-error outer-form "no expressions in body")
+ (syntax-violation #f "no expressions in body" outer-form)
(let ((e (cdar body)) (er (caar body)))
(call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage))
- (lambda (type value e w s)
+ (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
+ (lambda (type value e w s mod)
(case type
((define-form)
- (let ((id (wrap value w)) (label (gen-label)))
+ (let ((id (wrap value w mod)) (label (gen-label)))
(let ((var (gen-var id)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
- (cons var vars) (cons (cons er (wrap e w)) vals)
+ (cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
((define-syntax-form)
- (let ((id (wrap value w)) (label (gen-label)))
+ (let ((id (wrap value w mod)) (label (gen-label)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
vars vals
- (cons (make-binding 'macro (cons er (wrap e w)))
+ (cons (make-binding 'macro (cons er (wrap e w mod)))
bindings))))
((begin-form)
(syntax-case e ()
(parse (let f ((forms (syntax (e1 ...))))
(if (null? forms)
(cdr body)
- (cons (cons er (wrap (car forms) w))
+ (cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
ids labels vars vals bindings))))
((local-syntax-form)
- (chi-local-syntax value e er w s
- (lambda (forms er w s)
+ (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))
+ (cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
ids labels 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))
- (cons (cons er (source-wrap e w s))
+ (chi (cdr x) (car x) empty-wrap mod))
+ (cons (cons er (source-wrap e w s mod))
(cdr body))))
(begin
(if (not (valid-bound-ids? ids))
- (syntax-error outer-form
- "invalid or duplicate identifier in definition"))
+ (syntax-violation
+ #f "invalid or duplicate identifier in definition"
+ outer-form))
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
(macros-only-env er))))
(set-cdr! b
(eval-local-transformer
- (chi (cddr b) r-cache empty-wrap)))
+ (chi (cddr b) r-cache empty-wrap mod)
+ mod))
(loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source
+ (map syntax->datum ids)
vars
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap))
+ (chi (cdr x) (car x) empty-wrap mod))
vals)
(build-sequence no-source
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap))
- (cons (cons er (source-wrap e w s))
+ (chi (cdr x) (car x) empty-wrap mod))
+ (cons (cons er (source-wrap e w s mod))
(cdr body)))))))))))))))))
(define chi-lambda-clause
- (lambda (e c r w k)
+ (lambda (e docstring c r w mod k)
(syntax-case c ()
+ ((args doc e1 e2 ...)
+ (and (string? (syntax->datum (syntax doc))) (not docstring))
+ (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
- (k new-vars
+ (k (map syntax->datum ids)
+ new-vars
+ docstring
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
- (make-binding-wrap ids labels w)))))))
+ (make-binding-wrap ids labels w)
+ mod))))))
((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels old-ids))
(new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+ (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
+ (if (null? ls1)
+ (syntax->datum ls2)
+ (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
+ (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
(if (null? ls1)
ls2
(f (cdr ls1) (cons (car ls1) ls2))))
+ docstring
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
- (make-binding-wrap old-ids labels w)))))))
- (_ (syntax-error e)))))
+ (make-binding-wrap old-ids labels w)
+ mod))))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
(define chi-local-syntax
- (lambda (rec? e r w s k)
+ (lambda (rec? e r w s mod k)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound keyword in")
+ (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 ...))
(trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
- (eval-local-transformer (chi x trans-r w))))
+ (eval-local-transformer
+ (chi x trans-r w mod)
+ mod)))
(syntax (val ...))))
r)
new-w
- s))))))
- (_ (syntax-error (source-wrap e w s))))))
+ s
+ mod))))))
+ (_ (syntax-violation #f "bad local syntax definition"
+ (source-wrap e w s mod))))))
(define eval-local-transformer
- (lambda (expanded)
- (let ((p (local-eval-hook expanded)))
+ (lambda (expanded mod)
+ (let ((p (local-eval-hook expanded mod)))
(if (procedure? p)
p
- (syntax-error p "nonprocedure transformer")))))
+ (syntax-violation #f "nonprocedure transformer" p)))))
(define chi-void
(lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
+ (build-application no-source (build-primref no-source 'if) '(#f #f))))
(define ellipsis?
(lambda (x)
((vector? x)
(let ((old (vector->list x)))
(let ((new (map f old)))
- (if (andmap eq? old new) x (list->vector new)))))
+ (if (and-map* eq? old new) x (list->vector new)))))
(else x))))))
;;; lexical variables
(lambda (vars)
(let lvl ((vars vars) (ls '()) (w empty-wrap))
(cond
- ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
- ((id? vars) (cons (wrap vars w) ls))
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
+ ((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls)
((syntax-object? vars)
(lvl (syntax-object-expression vars)
(global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'fluid-let-syntax
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? (syntax (var ...)))
(let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
(for-each
(lambda (id n)
- (case (binding-type (lookup n r))
+ (case (binding-type (lookup n r mod))
((displaced-lexical)
- (syntax-error (source-wrap id w s)
- "identifier out of context"))))
+ (syntax-violation 'fluid-let-syntax
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
(syntax (var ...))
names)
(chi-body
(syntax (e1 e2 ...))
- (source-wrap e w s)
+ (source-wrap e w s mod)
(extend-env
names
(let ((trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
- (eval-local-transformer (chi x trans-r w))))
+ (eval-local-transformer (chi x trans-r w mod)
+ mod)))
(syntax (val ...))))
r)
- w)))
- (_ (syntax-error (source-wrap e w s))))))
+ w
+ mod)))
+ (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w s))))))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'syntax
(let ()
(define gen-syntax
- (lambda (src e r maps ellipsis?)
+ (lambda (src e r maps ellipsis? mod)
(if (id? e)
(let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r)))
+ (let ((b (lookup label r mod)))
(if (eq? (binding-type b) 'syntax)
(call-with-values
(lambda ()
(gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
+ (syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps)))))
(syntax-case e ()
((dots e)
(ellipsis? (syntax dots))
- (gen-syntax src (syntax e) r maps (lambda (x) #f)))
+ (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
((x dots . y)
; this could be about a dozen lines of code, except that we
; choose to handle (syntax (x ... ...)) forms
(call-with-values
(lambda ()
(gen-syntax src (syntax x) r
- (cons '() maps) ellipsis?))
+ (cons '() maps) ellipsis? mod))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
(values (gen-map x (car maps))
(cdr maps))))))))
(syntax-case y ()
(lambda () (k (cons '() maps)))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis" src)
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis?))
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
(lambda (y maps)
(call-with-values
(lambda () (k maps))
(values (gen-append x y) maps)))))))))
((x . y)
(call-with-values
- (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
+ (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
(lambda (x maps)
(call-with-values
- (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
+ (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
(lambda (y maps) (values (gen-cons x y) maps))))))
(#(e1 e2 ...)
(call-with-values
(lambda ()
- (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
+ (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps))))
(_ (values `(quote ,e) maps))))))
(if (fx= level 0)
(values var maps)
(if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
+ (syntax-violation 'syntax "missing ellipsis" src)
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-maps)
; identity map equivalence:
; (map (lambda (x) x) y) == y
(car actuals))
- ((andmap
+ ((and-map
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
; eta map equivalence:
(define regen
(lambda (x)
(case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+ ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x))))
((map) (let ((ls (map regen (cdr x))))
(build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error check
+ ;; this check used to be here, not sure what for:
+ ;; (if (fx= (length ls) 2)
+ (build-primref no-source 'map)
ls)))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ x)
(call-with-values
- (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
+ (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
(lambda (e maps) (regen e))))
- (_ (syntax-error e)))))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ . c)
- (chi-lambda-clause (source-wrap e w s) (syntax c) r w
- (lambda (vars body) (build-lambda s vars body)))))))
+ (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
+ (lambda (names vars docstring body)
+ (build-lambda s names vars docstring body)))))))
(global-extend 'core 'let
(let ()
- (define (chi-let e r w s constructor ids vals exps)
+ (define (chi-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((nw (make-binding-wrap ids labels w))
(nr (extend-var-env labels new-vars r)))
(constructor s
+ (map syntax->datum ids)
new-vars
- (map (lambda (x) (chi x r w)) vals)
- (chi-body exps (source-wrap e nw s) nr nw))))))
- (lambda (e r w s)
+ (map (lambda (x) (chi x r w mod)) vals)
+ (chi-body exps (source-wrap e nw s mod)
+ nr nw mod))))))
+ (lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
- (chi-let e r w s
+ (chi-let e r w s mod
build-let
(syntax (id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
((_ f ((id val) ...) e1 e2 ...)
(id? (syntax f))
- (chi-let e r w s
+ (chi-let e r w s mod
build-named-let
(syntax (f id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
- (_ (syntax-error (source-wrap e w s)))))))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
(global-extend 'core 'letrec
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'letrec "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env labels new-vars r)))
(build-letrec s
+ (map syntax->datum ids)
new-vars
- (map (lambda (x) (chi x r w)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
- (_ (syntax-error (source-wrap e w s))))))
+ (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
+ (chi-body (syntax (e1 e2 ...))
+ (source-wrap e w s mod) r w mod)))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(global-extend 'core 'set!
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ id val)
(id? (syntax id))
- (let ((val (chi (syntax val) r w))
+ (let ((val (chi (syntax val) r w mod))
(n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
+ (let ((b (lookup n r mod)))
(case (binding-type b)
((lexical)
- (build-lexical-assignment s (binding-value b) val))
- ((global) (build-global-assignment s n val))
+ (build-lexical-assignment s
+ (syntax->datum (syntax id))
+ (binding-value b)
+ val))
+ ((global) (build-global-assignment s n val mod))
((displaced-lexical)
- (syntax-error (wrap (syntax id) w)
- "identifier out of context"))
- (else (syntax-error (source-wrap e w s)))))))
- ((_ (getter arg ...) val)
- (build-application s
- (chi (syntax (setter getter)) r w)
- (map (lambda (e) (chi e r w))
- (syntax (arg ... val)))))
- (_ (syntax-error (source-wrap e w s))))))
+ (syntax-violation 'set! "identifier out of context"
+ (wrap (syntax id) w mod)))
+ (else (syntax-violation 'set! "bad set!"
+ (source-wrap e w s mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
+ (lambda (type value ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (chi (syntax val) r w mod)))
+ (call-with-values (lambda () (value (syntax (head tail ...))))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
+ (else
+ (build-application s
+ (chi (syntax (setter head)) r w mod)
+ (map (lambda (e) (chi e r w mod))
+ (syntax (tail ... val)))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+
+(global-extend 'module-ref '@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (public mod ...))))))))
+
+(global-extend 'module-ref '@@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (private mod ...))))))))
(global-extend 'begin 'begin '())
(let ()
(define convert-pattern
; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
+ ; returns $sc-dispatch pattern & ids
(lambda (pattern keys)
(let cvt ((p pattern) (n 0) (ids '()))
(if (id? p)
(x (values (vector 'atom (strip p empty-wrap)) ids)))))))
(define build-dispatch-call
- (lambda (pvars exp y r)
+ (lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
+ (list (build-lambda no-source (map syntax->datum ids) new-vars #f
(chi exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)))
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
y))))))
(define gen-clause
- (lambda (x keys clauses r pat fender exp)
+ (lambda (x keys clauses r pat fender exp mod)
(call-with-values
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
(cond
((not (distinct-bound-ids? (map car pvars)))
- (syntax-error pat
- "duplicate pattern variable in syntax-case pattern"))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
+ ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-violation 'syntax-case "misplaced ellipsis" pat))
(else
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list y)
- (let ((y (build-lexical-reference 'value no-source y)))
+ (build-lambda no-source (list 'tmp) (list y) #f
+ (let ((y (build-lexical-reference 'value no-source
+ 'tmp y)))
(build-conditional no-source
(syntax-case fender ()
(#t y)
(_ (build-conditional no-source
y
- (build-dispatch-call pvars fender y r)
+ (build-dispatch-call pvars fender y r mod)
(build-data no-source #f))))
- (build-dispatch-call pvars exp y r)
- (gen-syntax-case x keys clauses r))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
(build-application no-source
(build-primref no-source 'list)
(list x))
(build-application no-source
- (build-primref no-source 'syntax-dispatch)
+ (build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
- (lambda (x keys clauses r)
+ (lambda (x keys clauses r mod)
(if (null? clauses)
(build-application no-source
- (build-primref no-source 'syntax-error)
- (list x))
+ (build-primref no-source 'syntax-violation)
+ (list #f "source expression failed to match any pattern" x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? (syntax pat))
- (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
- (cons (syntax (... ...)) keys)))
+ (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
+ (cons (syntax (... ...)) keys)))
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
- (build-lambda no-source (list var)
+ (build-lambda no-source
+ (list (syntax->datum (syntax pat))) (list var)
+ #f
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
r)
(make-binding-wrap (syntax (pat))
- labels empty-wrap)))
+ labels empty-wrap)
+ mod))
(list x)))
(gen-clause x keys (cdr clauses) r
- (syntax pat) #t (syntax exp))))
+ (syntax pat) #t (syntax exp) mod)))
((pat fender exp)
(gen-clause x keys (cdr clauses) r
- (syntax pat) (syntax fender) (syntax exp)))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+ (syntax pat) (syntax fender) (syntax exp) mod))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses)))))))
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ val (key ...) m ...)
- (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list x)
- (gen-syntax-case (build-lexical-reference 'value no-source x)
+ (build-lambda no-source (list 'tmp) (list x) #f
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
(syntax (key ...)) (syntax (m ...))
- r))
- (list (chi (syntax val) r empty-wrap))))
- (syntax-error e "invalid literals list in"))))))))
+ r
+ mod))
+ (list (chi (syntax val) r empty-wrap mod))))
+ (syntax-violation 'syntax-case "invalid literals list" e))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
(set! sc-expand
- (let ((m 'e) (esew '(eval)))
- (lambda (x)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x null-env top-wrap m esew)))))
-
-(set! sc-expand3
- (let ((m 'e) (esew '(eval)))
- (lambda (x . rest)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x
- null-env
- top-wrap
- (if (null? rest) m (car rest))
- (if (or (null? rest) (null? (cdr rest)))
- esew
- (cadr rest)))))))
+ (lambda (x . rest)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (let ((m (if (null? rest) 'e (car rest)))
+ (esew (if (or (null? rest) (null? (cdr rest)))
+ '(eval)
+ (cadr rest))))
+ (with-fluid* *mode* m
+ (lambda ()
+ (chi-top x null-env top-wrap m esew
+ (cons 'hygiene (module-name (current-module))))))))))
(set! identifier?
(lambda (x)
(nonsymbol-id? x)))
-(set! datum->syntax-object
+(set! datum->syntax
(lambda (id datum)
- (make-syntax-object datum (syntax-object-wrap id))))
+ (make-syntax-object datum (syntax-object-wrap id) #f)))
-(set! syntax-object->datum
+(set! syntax->datum
; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data
(lambda (x)
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
+ (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
(set! free-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-(set! install-global-transformer
- (lambda (sym v)
- (arg-check symbol? sym 'define-syntax)
- (arg-check procedure? v 'define-syntax)
- (global-extend 'macro sym v)))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
+(set! syntax-violation
+ (lambda (who message form . subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (scm-error 'syntax-error 'sc-expand
+ (string-append
+ (if who "~a: " "")
+ "~a "
+ (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+ (let ((tail (cons message
+ (map (lambda (x) (strip x empty-wrap))
+ (append subform (list form))))))
+ (if who (cons who tail) tail))
+ #f)))
+
+;;; $sc-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each
;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
;;; not work on r4rs implementations that violate the ieee requirement
(let ()
(define match-each
- (lambda (e p w)
+ (lambda (e p w mod)
(cond
((annotation? e)
- (match-each (annotation-expression e) p w))
+ (match-each (annotation-expression e) p w mod))
((pair? e)
- (let ((first (match (car e) p w '())))
+ (let ((first (match (car e) p w '() mod)))
(and first
- (let ((rest (match-each (cdr e) p w)))
+ (let ((rest (match-each (cdr e) p w mod)))
(and rest (cons first rest))))))
((null? e) '())
((syntax-object? e)
(match-each (syntax-object-expression e)
p
- (join-wraps w (syntax-object-wrap e))))
+ (join-wraps w (syntax-object-wrap e))
+ (syntax-object-module e)))
(else #f))))
(define match-each-any
- (lambda (e w)
+ (lambda (e w mod)
(cond
((annotation? e)
- (match-each-any (annotation-expression e) w))
+ (match-each-any (annotation-expression e) w mod))
((pair? e)
- (let ((l (match-each-any (cdr e) w)))
- (and l (cons (wrap (car e) w) l))))
+ (let ((l (match-each-any (cdr e) w mod)))
+ (and l (cons (wrap (car e) w mod) l))))
((null? e) '())
((syntax-object? e)
(match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
+ (join-wraps w (syntax-object-wrap e))
+ mod))
(else #f))))
(define match-empty
((vector) (match-empty (vector-ref p 1) r)))))))
(define match*
- (lambda (e p w r)
+ (lambda (e p w r mod)
(cond
((null? p) (and (null? e) r))
((pair? p)
(and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r))))
+ (match (cdr e) (cdr p) w r mod)
+ mod)))
((eq? p 'each-any)
- (let ((l (match-each-any e w))) (and l (cons l r))))
+ (let ((l (match-each-any e w mod))) (and l (cons l r))))
(else
(case (vector-ref p 0)
((each)
(if (null? e)
(match-empty (vector-ref p 1) r)
- (let ((l (match-each e (vector-ref p 1) w)))
+ (let ((l (match-each e (vector-ref p 1) w mod)))
(and l
(let collect ((l l))
(if (null? (car l))
r
(cons (map car l) (collect (map cdr l)))))))))
- ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r))
+ ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
((vector)
(and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r))))))))
+ (match (vector->list e) (vector-ref p 1) w r mod))))))))
(define match
- (lambda (e p w r)
+ (lambda (e p w r mod)
(cond
((not r) #f)
- ((eq? p 'any) (cons (wrap e w) r))
+ ((eq? p 'any) (cons (wrap e w mod) r))
((syntax-object? e)
(match*
(unannotate (syntax-object-expression e))
p
(join-wraps w (syntax-object-wrap e))
- r))
- (else (match* (unannotate e) p w r)))))
+ r
+ (syntax-object-module e)))
+ (else (match* (unannotate e) p w r mod)))))
-(set! syntax-dispatch
+(set! $sc-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
((syntax-object? e)
(match* (unannotate (syntax-object-expression e))
- p (syntax-object-wrap e) '()))
- (else (match* (unannotate e) p empty-wrap '())))))
+ p (syntax-object-wrap e) '() (syntax-object-module e)))
+ (else (match* (unannotate e) p empty-wrap '() #f)))))
-(set! sc-chi chi)
))
)
(lambda (x)
(syntax-case x ()
((let* ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
+ (and-map identifier? (syntax (x ...)))
(let f ((bindings (syntax ((x v) ...))))
(if (null? bindings)
(syntax (let () e1 e2 ...))
(syntax-case s ()
(() v)
((e) (syntax e))
- (_ (syntax-error orig-x))))
+ (_ (syntax-violation
+ 'do "bad step expression"
+ orig-x s))))
(syntax (var ...))
(syntax (step ...)))))
(syntax-case (syntax (e1 ...)) ()
(let f ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
- (cons (datum->syntax-object k x)
+ (cons (datum->syntax k x)
(f (read p))))))))
(syntax-case x ()
((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
+ (let ((fn (syntax->datum (syntax filename))))
(with-syntax (((exp ...) (read-file fn (syntax k))))
(syntax (begin exp ...))))))))
(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote
- "expression ,~s not valid outside of quasiquote"
- (syntax-object->datum (syntax e)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote
+ "expression not valid outside of quasiquote"
+ x)))))
(define-syntax unquote-splicing
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote-splicing
- "expression ,@~s not valid outside of quasiquote"
- (syntax-object->datum (syntax e)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ x)))))
(define-syntax case
(lambda (x)
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
+ (_ (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 ...))
(begin e1 e2 ...)
rest)))
- (_ (syntax-error x))))))))
+ (_ (syntax-violation 'case "bad clause" x
+ clause))))))))
(syntax (let ((t e)) body)))))))
(define-syntax identifier-syntax
(syntax e))
((_ x (... ...))
(syntax (e x (... ...)))))))))))
-
HCoop / bpt / guile.git / blobdiff