summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r--module/ice-9/psyntax.scm215
1 files changed, 116 insertions, 99 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7173ba763..85ef13814 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -304,7 +304,7 @@
(primitive-eval
`(,noexpand
,(case (fluid-ref *mode*)
- ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
(else x))))))
(define local-eval-hook
@@ -312,7 +312,7 @@
(primitive-eval
`(,noexpand
,(case (fluid-ref *mode*)
- ((c) ((@ (ice-9 expand-support) strip-expansion-structures) x))
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
(else x))))))
(define-syntax gensym-hook
@@ -351,132 +351,150 @@
;;; 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 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)
- (build-annotated
- source
- (case (fluid-ref *mode*)
- ((c) ((@ (ice-9 expand-support) make-lexical) source name var))
- (else 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)
- (build-annotated
- source
- `(set! ,(build-lexical-reference 'set no-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
-;; (ice-9 expand-support) -- we need to give the evaluator the
+;; (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 expand-support
;; structures at all. So until we fix the evaluator, if ever, the
-;; conflation that we should use expand-support iff we are compiling
+;; 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)
- (build-annotated
- source
- (if (not mod)
- var
- (let ((make-module-ref
- (case (fluid-ref *mode*)
- ((c) (@ (ice-9 expand-support) make-module-ref))
- (else (lambda (source mod var public?)
- (list (if public? '@ '@@) mod var)))))
- (kind (car mod))
- (mod (cdr mod)))
- (case kind
- ((public) (make-module-ref #f mod var #t))
- ((private) (if (not (equal? mod (module-name (current-module))))
- (make-module-ref #f mod var #f)
- var))
- ((bare) var)
- ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
- (module-variable (resolve-module mod) var))
- (make-module-ref #f mod var #f)
- var))
- (else (syntax-violation #f "bad module kind" 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)
- (let ((ref (build-global-reference source var mod)))
- (build-annotated
- source
- `(set! ,ref ,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 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))))
+ (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 vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src 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)
(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 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)))))
+ (let ((f (car vars))
+ (vars (cdr vars)))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-letrec) src
+ (list f) (list (build-lambda src vars #f body-exp))
+ (build-application src (build-lexical-reference 'fun src f f)
+ val-exps)))
+ (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
(define build-letrec
(lambda (src 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 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))
@@ -1729,13 +1747,12 @@
((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) #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))
@@ -1913,7 +1930,7 @@
(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 new-vars #f
(chi exp
(extend-env
labels
@@ -1940,7 +1957,7 @@
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list y)
+ (build-lambda no-source (list y) #f
(let ((y (build-lexical-reference 'value no-source
'tmp y)))
(build-conditional no-source
@@ -1974,7 +1991,7 @@
(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 var) #f
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
@@ -2000,7 +2017,7 @@
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list x)
+ (build-lambda no-source (list x) #f
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)
(syntax (key ...)) (syntax (m ...))