(let ()
(define noexpand "noexpand")
+(define *mode* (make-fluid))
;;; hooks to nonportable run-time helpers
(begin
(define top-level-eval-hook
(lambda (x mod)
- (primitive-eval `(,noexpand ,x))))
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define local-eval-hook
(lambda (x mod)
- (primitive-eval `(,noexpand ,x))))
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define-syntax gensym-hook
(syntax-rules ()
;;; 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 mod)
- (build-annotated
- source
- (if mod
- (make-module-ref (cdr mod) var (car mod))
- (make-module-ref mod var 'bare))))))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp mod)
- (build-annotated source
- `(set! ,(if mod
- (make-module-ref (cdr mod) var (car mod))
- (make-module-ref mod var 'bare))
- ,exp)))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp mod)
- (build-annotated source `(define ,var ,exp)))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars docstring exp)
- (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)))
- ((_ src vars exp)
- (build-annotated src `(lambda ,vars ,exp)))))
-
-;; FIXME: wingo: add modules here somehow?
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) (build-annotated src name))
- ((_ src level name) (build-annotated src name))))
+(define build-void
+ (lambda (source)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-void) source))
+ (else '(if #f #f)))))
+
+(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)
+ (if (equal? (module-name (current-module)) '(guile))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) src name))
+ (else name))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+ (else `(@@ (guile) ,name))))))
(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
+;; 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 module))
(let ((first (chi-top (car body) r w m esew mod)))
(cons first (dobody (cdr body) r w m esew mod))))))))
-;; FIXME: module?
(define chi-install-global
(lambda (name e)
- (build-application no-source
- (build-primref no-source 'define)
- (list
- 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)))))))
+ (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
+ (build-primref 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)
(case type
((global core macro module-ref)
(eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
+ (build-global-definition s n (chi e r w mod))
mod))
((displaced-lexical)
(syntax-violation #f "identifier out of context"
(lambda (type value e r w s mod)
(case type
((lexical)
- (build-lexical-reference 'value s value))
+ (build-lexical-reference 'value s e value))
((core external-macro)
;; apply transformer
(value e r w s mod))
(lambda (id mod) (build-global-reference s id mod))))
((lexical-call)
(chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
e r w s mod))
((global-call)
(chi-application
(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 mod))
(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
(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))))
(define chi-void
(lambda ()
- (build-application no-source (build-primref no-source 'if) '(#f #f))))
+ (build-void no-source)))
(define ellipsis?
(lambda (x)
(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))
(syntax-case e ()
((_ . c)
(chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
- (lambda (vars docstring body) (build-lambda s vars docstring body)))))))
+ (lambda (names vars docstring body)
+ (build-lambda s names vars docstring body)))))))
(global-extend 'core 'let
(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 mod)) vals)
(chi-body exps (source-wrap e nw s mod)
(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 mod)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...))
(let ((b (lookup n r mod)))
(case (binding-type b)
((lexical)
- (build-lexical-assignment s (binding-value b) val))
+ (build-lexical-assignment s
+ (syntax->datum (syntax id))
+ (binding-value b)
+ val))
((global) (build-global-assignment s n val mod))
((displaced-lexical)
(syntax-violation 'set! "identifier out of context"
(syntax->datum
(syntax (private mod ...))))))))
+(global-extend 'core 'if
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional
+ s
+ (chi (syntax test) r w mod)
+ (chi (syntax then) r w mod)
+ (build-void no-source)))
+ ((_ test then else)
+ (build-conditional
+ s
+ (chi (syntax test) r w mod)
+ (chi (syntax then) r w mod)
+ (chi (syntax else) r w mod))))))
+
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(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
(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)
(if (null? clauses)
(build-application no-source
(build-primref no-source 'syntax-violation)
- (list #f "source expression failed to match any pattern" x))
+ (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? (syntax pat))
(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)))
(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
mod))
;;; 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 . 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))
- (cons 'hygiene (module-name (current-module))))))))
+ (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)
HCoop / bpt / guile.git / blobdiff