(lambda (source)
(make-void source)))
- (define build-application
+ (define build-call
(lambda (source fun-exp arg-exps)
- (make-application source fun-exp arg-exps)))
+ (make-call source fun-exp arg-exps)))
(define build-conditional
(lambda (source test-exp then-exp else-exp)
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
+ (define build-primcall
+ (lambda (src name args)
+ (make-primcall src name args)))
+
(define build-primref
(lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
-
+ (make-primitive-ref src name)))
+
(define (build-data src exp)
(make-const src exp))
(lambda (src exps)
(if (null? (cdr exps))
(car exps)
- (make-sequence src exps))))
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(define build-let
(lambda (src ids vars val-exps body-exp)
(make-letrec
src #f
(list f-name) (list f) (list proc)
- (build-application src (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f)
+ val-exps))))))
(define build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(define free-id=?
(lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
+ (let ((ni (id-var-name i empty-wrap))
+ (nj (id-var-name j empty-wrap)))
+ (define (id-module-binding id)
+ (let ((mod (and (syntax-object? id) (syntax-object-module id))))
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id))))
+ (if (eq? ni (id-sym-name i))
+ ;; `i' is not lexically bound. Assert that `j' is free,
+ ;; and if so, compare their bindings, that they are either
+ ;; bound to the same variable, or both unbound and have
+ ;; the same name.
+ (and (eq? nj (id-sym-name j))
+ (let ((bi (id-module-binding i)))
+ (if bi
+ (eq? bi (id-module-binding j))
+ (and (not (id-module-binding j))
+ (eq? ni nj))))
+ (eq? (id-module-binding i) (id-module-binding j)))
+ ;; Otherwise `i' is bound, so check that `j' is bound, and
+ ;; bound to the same thing.
+ (and (eq? ni nj)
+ (not (eq? nj (id-sym-name j))))))))
+
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids
;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
(build-global-definition
no-source
name
- (build-application
+ (build-primcall
no-source
- (build-primref no-source 'make-syntax-transformer)
+ 'make-syntax-transformer
(list (build-data no-source name)
(build-data no-source 'macro)
e)))))
(define chi-when-list
(lambda (e when-list w)
- ;; when-list is syntax'd version of list of situations
+ ;; `when-list' is syntax'd version of list of situations. We
+ ;; could match these keywords lexically, via free-id=?, but then
+ ;; we twingle the definition of eval-when to the bindings of
+ ;; eval, load, expand, and compile, which is totally unintended.
+ ;; So do a symbolic match instead.
(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)))))
+ (cons (let ((x (syntax->datum (car when-list))))
+ (if (memq x '(compile load eval expand))
+ x
+ (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap (car when-list) w #f))))
situations))))))
;; syntax-type returns six values: type, value, e, w, s, and mod. The
(lambda (e r w s mod)
(chi e r w mod))))
((lexical-call)
- (chi-application
+ (chi-call
(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
+ (chi-call
(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) (chi-call (chi (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))))
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
- (define chi-application
+ (define chi-call
(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 ...)))))))
+ (build-call s x
+ (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
+ (else (build-primcall no-source (car x) (map regen (cdr x)))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
(build-global-assignment s (syntax->datum #'e)
val mod)))))))
(else
- (build-application s
- (chi #'(setter head) r w mod)
- (map (lambda (e) (chi e r w mod))
- #'(tail ... val))))))))
+ (build-call s
+ (chi #'(setter head) r w mod)
+ (map (lambda (e) (chi e r w mod))
+ #'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
(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-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))
- y))))))
+ (build-primcall
+ 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))
+ y))))))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y
- (build-application no-source
- (build-simple-lambda no-source (list 'tmp) #f (list y) '()
- (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 mod)
- (build-data no-source #f))))
- (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 '$sc-dispatch)
- (list x (build-data no-source p)))))))))))))
+ (build-call no-source
+ (build-simple-lambda no-source (list 'tmp) #f (list y) '()
+ (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 mod)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-primcall no-source 'list (list x))
+ (build-primcall no-source '$sc-dispatch
+ (list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-violation)
- (list (build-data no-source #f)
- (build-data no-source
- "source expression failed to match any pattern")
- x))
+ (build-primcall no-source 'syntax-violation
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to match any pattern")
+ x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? #'pat)
(chi #'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))
- (list x))))
+ (build-call 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))
+ (list x))))
(gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod)))
((pat fender exp)
#'(key ...))
(let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x
- (build-application s
- (build-simple-lambda no-source (list 'tmp) #f (list x) '()
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- #'(key ...) #'(m ...)
- r
- mod))
- (list (chi #'val r empty-wrap mod))))
+ (build-call s
+ (build-simple-lambda no-source (list 'tmp) #f (list x) '()
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
+ #'(key ...) #'(m ...)
+ r
+ mod))
+ (list (chi #'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
HCoop / bpt / guile.git / blobdiff