1100 lines
39 KiB
Scheme
1100 lines
39 KiB
Scheme
|
|
;;; 6.2: internal define-record (not yet working)
|
|
;;; 6.1: case-lambda
|
|
|
|
;;; Extended: cond case
|
|
|
|
;;;
|
|
;;;
|
|
;;; Expand : Scheme -> Core Scheme
|
|
;;;
|
|
;;; <CS> ::= (quote datum)
|
|
;;; | <gensym>
|
|
;;; | (if <CS> <CS> <CS>)
|
|
;;; | (set! <gensym> <CS>)
|
|
;;; | (begin <CS> <CS> ...)
|
|
;;; | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
|
|
;;; | (lambda <FMLS> <CS> <CS> ...)
|
|
;;; | (<prim> <CS> <CS> ...)
|
|
;;; | (#primitive| <primname>)
|
|
;;; | (<CS> <CS> ...)
|
|
;;; <FML> ::= ()
|
|
;;; | <gensym>
|
|
;;; | (<gensym> . <FML>)
|
|
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
|
|
;;; | primitive-set! '| foreign-call | $apply
|
|
;;;
|
|
;;;
|
|
;;; Handled keywords:
|
|
;;; Core: case-lambda lambda set! if quote begin define
|
|
;;; Extended: let let* letrec letrec* when unless or and cond case
|
|
;;; define-record record-case
|
|
|
|
|
|
(let ()
|
|
(define *interaction-environment* (gensym "*interaction-environment*"))
|
|
(define *scheme-environment* (gensym "*scheme-environment*"))
|
|
(define build-void
|
|
(lambda ()
|
|
(build-application (build-primref 'void) '())))
|
|
(define build-primref
|
|
(lambda (x)
|
|
(list '|#primitive| x)))
|
|
(define build-global-assignment
|
|
(lambda (x val)
|
|
(list 'set-top-level-value!
|
|
(build-constant x) val)))
|
|
(define build-foreign-call
|
|
(lambda (name rand*)
|
|
(cons 'foreign-call
|
|
(cons name rand*))))
|
|
(define build-apply
|
|
(lambda (proc rand*)
|
|
(cons '$apply
|
|
(cons proc rand*))))
|
|
(define build-global-reference
|
|
(lambda (x)
|
|
(list 'top-level-value (build-constant x))))
|
|
(define build-memv
|
|
(lambda (x ls)
|
|
(list 'memv x ls)))
|
|
(define build-application
|
|
(lambda (fun arg*)
|
|
(cons fun arg*)))
|
|
(define build-sequence
|
|
(lambda (a b)
|
|
(let ([a*
|
|
(if (and (pair? a) (eq? (car a) 'begin))
|
|
(cdr a)
|
|
(list a))]
|
|
[b*
|
|
(if (and (pair? b) (eq? (car b) 'begin))
|
|
(cdr b)
|
|
(list b))])
|
|
(cons 'begin (append a* b*)))))
|
|
(define sequence
|
|
(lambda args
|
|
(if (null? args)
|
|
(build-void)
|
|
(let f ([a (car args)] [args (cdr args)])
|
|
(cond
|
|
[(null? args) a]
|
|
[else
|
|
(build-sequence a (f (car args) (cdr args)))])))))
|
|
(define build-constant
|
|
(lambda (x) (list 'quote x)))
|
|
(define build-lexical-reference
|
|
(lambda (x) x))
|
|
(define build-lexical-assignment
|
|
(lambda (lhs rhs)
|
|
(list 'set! lhs rhs)))
|
|
(define build-conditional
|
|
(lambda (test conseq altern)
|
|
(list 'if test conseq altern)))
|
|
(define build-function
|
|
(lambda (fml* body)
|
|
(build-case-lambda (list (list fml* body)))))
|
|
(define build-case-lambda
|
|
(lambda (cases)
|
|
(cons 'case-lambda cases)))
|
|
(define build-assignments
|
|
(lambda (lhs* rhs* body)
|
|
(cond
|
|
[(null? lhs*) body]
|
|
[else
|
|
(build-sequence
|
|
(build-lexical-assignment (car lhs*) (car rhs*))
|
|
(build-assignments (cdr lhs*) (cdr rhs*) body))])))
|
|
(define build-letrec
|
|
(lambda (lhs* rhs* body)
|
|
(if (null? lhs*)
|
|
body
|
|
(let ([g* (map (lambda (x) (gensym)) lhs*)])
|
|
(build-let lhs* (map (lambda (x) (build-void)) lhs*)
|
|
(build-let g* rhs*
|
|
(build-assignments lhs* g* body)))))))
|
|
(define build-letrec*
|
|
(lambda (lhs* rhs* body)
|
|
(if (null? lhs*)
|
|
body
|
|
(build-let lhs* (map (lambda (x) (build-void)) lhs*)
|
|
(build-assignments lhs* rhs* body)))))
|
|
(define build-let
|
|
(lambda (lhs* rhs* body)
|
|
(build-application
|
|
(build-function lhs* body)
|
|
rhs*)))
|
|
(define build-let*
|
|
(lambda (lhs* rhs* body)
|
|
(cond
|
|
[(null? lhs*) body]
|
|
[else
|
|
(build-let (list (car lhs*)) (list (car rhs*))
|
|
(build-let* (cdr lhs*) (cdr rhs*) body))])))
|
|
;;; builds
|
|
(define keyword?
|
|
(lambda (x) (getprop x *interaction-environment*)))
|
|
(define self-evaluating?
|
|
(lambda (x)
|
|
(or (immediate? x) (string? x))))
|
|
(define syntax-error
|
|
(lambda (x)
|
|
(error 'expand "invalid syntax ~s" x)))
|
|
(define empty-env '())
|
|
(define E*
|
|
(lambda (x* env)
|
|
(cond
|
|
[(null? x*) '()]
|
|
[else
|
|
(cons (E (car x*) env) (E* (cdr x*) env))])))
|
|
(define lookup
|
|
(lambda (x env)
|
|
(cond
|
|
[(assq x env) =>
|
|
(lambda (x)
|
|
(let ([d (cdr x)])
|
|
(cond
|
|
[(symbol? d) (cons 'lexical d)]
|
|
[(and (pair? d) (eq? (car d) *interaction-environment*))
|
|
(cons 'macro (cdr d))]
|
|
[else (error 'expand "BUG in lookup ~s" x)])))]
|
|
[(keyword? x) => (lambda (x) (cons 'macro x))]
|
|
[else (cons 'global x)])))
|
|
(define bug
|
|
(lambda (str . args)
|
|
(error 'bug "~a ~a" str args)))
|
|
;;;
|
|
(define E-quote
|
|
(lambda (d env x)
|
|
(unless (fx= (length d) 1)
|
|
(syntax-error x))
|
|
(build-constant (car d))))
|
|
;;;
|
|
(define E-if
|
|
(lambda (d env x)
|
|
(let ([n (length d)])
|
|
(cond
|
|
[(fx= n 2)
|
|
(build-conditional
|
|
(E (car d) env)
|
|
(E (cadr d) env)
|
|
(build-void))]
|
|
[(fx= n 3)
|
|
(build-conditional
|
|
(E (car d) env)
|
|
(E (cadr d) env)
|
|
(E (caddr d) env))]
|
|
[else (syntax-error x)]))))
|
|
;;;
|
|
(define E-set!
|
|
(lambda (d env x)
|
|
(unless (fx= (length d) 2) (syntax-error x))
|
|
(let ([lhs (car d)] [rhs (cadr d)])
|
|
(unless (symbol? lhs) (syntax-error x))
|
|
(let ([b (lookup lhs env)])
|
|
(case (car b)
|
|
[(lexical)
|
|
(build-lexical-assignment (cdr b) (E rhs env))]
|
|
[(global)
|
|
(build-global-assignment (cdr b) (E rhs env))]
|
|
[else (syntax-error x)])))))
|
|
;;;
|
|
(define E-begin
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 1)
|
|
(syntax-error x))
|
|
(E-begin^ (car d) (cdr d) env)))
|
|
(define E-begin^
|
|
(lambda (a d env)
|
|
(cond
|
|
[(null? d) (E a env)]
|
|
[else
|
|
(build-sequence
|
|
(E a env)
|
|
(E-begin^ (car d) (cdr d) env))])))
|
|
;;;
|
|
(define E-named-let
|
|
(lambda (name d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(verify-bindings bindings x)
|
|
(let ([lhs* (map car bindings)]
|
|
[rhs* (map cadr bindings)])
|
|
(verify-fml* lhs* x)
|
|
(let ([rator
|
|
(let ([gname (gensym)]
|
|
[nlhs* (map (lambda (x) (gensym)) lhs*)])
|
|
(let ([env
|
|
(extend-env-fml* lhs* nlhs*
|
|
(cons (cons name gname) env))])
|
|
(let ([body (E-internal body* env x)])
|
|
(let ([fun (build-function nlhs* body)])
|
|
(build-letrec
|
|
(list gname)
|
|
(list fun)
|
|
(build-lexical-reference gname))))))]
|
|
[rand* (map (lambda (x) (E x env)) rhs*)])
|
|
(build-application rator rand*))))))
|
|
;;;
|
|
(define E-let
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(cond
|
|
[(symbol? bindings)
|
|
(E-named-let bindings body* env x)]
|
|
[else
|
|
(verify-bindings bindings x)
|
|
(let ([lhs* (map car bindings)]
|
|
[rhs* (map cadr bindings)])
|
|
(verify-fml* lhs* x)
|
|
(let ([nlhs* (map (lambda (x) (gensym)) lhs*)])
|
|
(let ([nrhs* (map (lambda (x) (E x env)) rhs*)])
|
|
(let ([env (extend-env-fml* lhs* nlhs* env)])
|
|
(build-let nlhs* nrhs* (E-internal body* env x))))))]))))
|
|
(define verify-bindings
|
|
(lambda (b* x)
|
|
(unless (list? b*) (syntax-error x))
|
|
(for-each
|
|
(lambda (b)
|
|
(unless (and (list? b)
|
|
(fx= (length b) 2)
|
|
(symbol? (car b)))
|
|
(syntax-error x)))
|
|
b*)))
|
|
;;;
|
|
(define E-let*
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(verify-bindings bindings x)
|
|
(let ([lhs* (map car bindings)]
|
|
[rhs* (map cadr bindings)])
|
|
(let ([nlhs* (map (lambda (x) (gensym)) lhs*)])
|
|
(let f ([lhs* lhs*] [nlhs* nlhs*] [rhs* rhs*] [env env])
|
|
(cond
|
|
[(null? lhs*) (E-internal body* env x)]
|
|
[else
|
|
(build-let (list (car nlhs*))
|
|
(list (E (car rhs*) env))
|
|
(f (cdr lhs*) (cdr nlhs*) (cdr rhs*)
|
|
(cons (cons (car lhs*) (car nlhs*)) env)))])))))))
|
|
;;;
|
|
(define E-letrec
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(verify-bindings bindings x)
|
|
(let ([lhs* (map car bindings)]
|
|
[rhs* (map cadr bindings)])
|
|
(verify-fml* lhs* x)
|
|
(let ([nlhs* (map (lambda (x) (gensym)) lhs*)])
|
|
(let ([env (extend-env-fml* lhs* nlhs* env)])
|
|
(let ([nrhs* (map (lambda (x) (E x env)) rhs*)])
|
|
(build-letrec nlhs* nrhs* (E-internal body* env x)))))))))
|
|
;;;
|
|
(define E-letrec*
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(verify-bindings bindings x)
|
|
(let ([lhs* (map car bindings)]
|
|
[rhs* (map cadr bindings)])
|
|
(verify-fml* lhs* x)
|
|
(let ([nlhs* (map (lambda (x) (gensym)) lhs*)])
|
|
(let ([env (extend-env-fml* lhs* nlhs* env)])
|
|
(let ([nrhs* (map (lambda (x) (E x env)) rhs*)])
|
|
(build-letrec* nlhs* nrhs* (E-internal body* env x)))))))))
|
|
;;;
|
|
(define E-let-values
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(unless (list? bindings) (syntax-error x))
|
|
(let f ([bindings bindings] [nenv env])
|
|
(cond
|
|
[(null? bindings) (E-internal body* nenv x)]
|
|
[else
|
|
(let ([b (car bindings)])
|
|
(unless (and (list? b) (fx= (length b) 2))
|
|
(syntax-error x))
|
|
(let ([fml* (car b)] [rhs (cadr b)])
|
|
(verify-fml* fml* x)
|
|
(let ([nfml* (gen-fml* fml*)])
|
|
(let ([nenv (extend-env-fml* fml* nfml* nenv)])
|
|
(build-application
|
|
(build-primref 'call-with-values)
|
|
(list (build-function '()
|
|
(E rhs env))
|
|
(build-function nfml*
|
|
(f (cdr bindings) nenv))))))))])))))
|
|
;;;
|
|
(define E-parameterize
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([bindings (car d)] [body* (cdr d)])
|
|
(cond
|
|
[(null? bindings)
|
|
(E-internal body* env x)]
|
|
[else
|
|
(unless (and (list? bindings)
|
|
(andmap (lambda (b)
|
|
(and (list? b) (fx= (length b) 2)))
|
|
bindings))
|
|
(syntax-error x))
|
|
(let ([lhs* (map car bindings)] [rhs* (map cadr bindings)])
|
|
(let ([nlhs* (map (lambda (x) (gensym)) lhs*)]
|
|
[nrhs* (map (lambda (x) (gensym)) lhs*)]
|
|
[swap (gensym)]
|
|
[t* (map (lambda (x) (gensym)) lhs*)])
|
|
(build-let
|
|
(append nlhs* nrhs*)
|
|
(map (lambda (x) (E x env))
|
|
(append lhs* rhs*))
|
|
(build-let
|
|
(list swap)
|
|
(list
|
|
(build-function '()
|
|
(apply sequence
|
|
(map (lambda (t lhs/rhs)
|
|
;;; FIXME: vararg map
|
|
(define nlhs (car lhs/rhs))
|
|
(define nrhs (cdr lhs/rhs))
|
|
(build-let
|
|
(list t)
|
|
(list (build-application
|
|
(build-lexical-reference nlhs)
|
|
'()))
|
|
(build-sequence
|
|
(build-application
|
|
(build-lexical-reference nlhs)
|
|
(list (build-lexical-reference nrhs)))
|
|
(build-lexical-assignment
|
|
nrhs
|
|
(build-lexical-reference t)))))
|
|
t* (map cons nlhs* nrhs*)))))
|
|
(build-application
|
|
(build-primref 'dynamic-wind)
|
|
(list
|
|
(build-lexical-reference swap)
|
|
(build-function
|
|
'()
|
|
(E-internal body* env x))
|
|
(build-lexical-reference swap)))))))]))))
|
|
;;;
|
|
(define E-lambda
|
|
(lambda (d env x)
|
|
(build-case-lambda
|
|
(list ((lambda-clause env x) d)))))
|
|
(define (lambda-clause env x)
|
|
(lambda (d)
|
|
(unless (and (list? d) (fx>= (length d) 2)) (syntax-error x))
|
|
(let ([fml* (car d)] [body* (cdr d)])
|
|
(verify-fml* fml* x)
|
|
(let ([nfml* (gen-fml* fml*)])
|
|
(let ([env (extend-env-fml* fml* nfml* env)])
|
|
(list nfml* (E-internal body* env x)))))))
|
|
(define E-case-lambda
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 1) (syntax-error x))
|
|
(build-case-lambda
|
|
(map (lambda-clause env x) d))))
|
|
(define verify-fml*
|
|
(lambda (fml* x)
|
|
(let ([g (gensym)])
|
|
(let f ([fml* fml*])
|
|
(cond
|
|
[(pair? fml*)
|
|
(let ([a (car fml*)])
|
|
(unless (symbol? a) (syntax-error x))
|
|
(when (getprop a g) (syntax-error x))
|
|
(putprop a g a)
|
|
(f (cdr fml*))
|
|
(remprop a g))]
|
|
[(symbol? fml*)
|
|
(when (getprop fml* g) (syntax-error x))]
|
|
[(null? fml*) (void)]
|
|
[else (syntax-error x)])))))
|
|
(define gen-fml*
|
|
(lambda (fml*)
|
|
(cond
|
|
[(pair? fml*)
|
|
(cons (gensym) (gen-fml* (cdr fml*)))]
|
|
[(symbol? fml*) (gensym)]
|
|
[else '()])))
|
|
(define extend-env-fml*
|
|
(lambda (fml* nfml* env)
|
|
(cond
|
|
[(pair? fml*)
|
|
(cons (cons (car fml*) (car nfml*))
|
|
(extend-env-fml* (cdr fml*) (cdr nfml*) env))]
|
|
[(symbol? fml*)
|
|
(cons (cons fml* nfml*) env)]
|
|
[else env])))
|
|
;;;
|
|
(define E-internal
|
|
(lambda (body* env x)
|
|
(let f ([a (car body*)] [body* (cdr body*)] [lhs* '()] [rhs* '()])
|
|
(cond
|
|
[(and (pair? a) (symbol? (car a)))
|
|
(let ([fst (car a)])
|
|
(if (memq fst lhs*)
|
|
(E-internal-done a body* lhs* rhs* env)
|
|
(let ([b (lookup fst env)])
|
|
(case (car b)
|
|
[(lexical global)
|
|
(E-internal-done a body* lhs* rhs* env)]
|
|
[(macro)
|
|
(case fst
|
|
[(begin)
|
|
(let ([d (cdr a)])
|
|
(unless (list? d) (syntax-error x))
|
|
(let ([body* (append d body*)])
|
|
(if (null? body*)
|
|
(syntax-error x)
|
|
(f (car body*) (cdr body*) lhs* rhs*))))]
|
|
[(define)
|
|
(let ([def (parse-define (cdr a) env fst)])
|
|
(f (car body*) (cdr body*)
|
|
(cons (car def) lhs*)
|
|
(cons (cdr def) rhs*)))]
|
|
[else
|
|
(E-internal-done a body* lhs* rhs* env)])]
|
|
[else (syntax-error x)]))))]
|
|
[else (E-internal-done a body* lhs* rhs* env)]))))
|
|
(define parse-define
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([fst (car d)] [rest (cdr d)])
|
|
(cond
|
|
[(symbol? fst)
|
|
(unless (fx= (length rest) 1) (syntax-error x))
|
|
(list fst 'expr (car rest))]
|
|
[(pair? fst)
|
|
(unless (symbol? (car fst)) (syntax-error x))
|
|
(verify-fml* (cdr fst) x)
|
|
(list (car fst) 'defun (cdr fst) rest)]
|
|
[else (syntax-error x)]))))
|
|
(define E-def
|
|
(lambda (x env)
|
|
(let ([type (car x)])
|
|
(cond
|
|
[(eq? type 'expr) (E (cadr x) env)]
|
|
[(eq? type 'defun)
|
|
(let ([fml* (cadr x)] [body* (caddr x)])
|
|
(let ([nfml* (gen-fml* fml*)])
|
|
(let ([env (extend-env-fml* fml* nfml* env)])
|
|
(build-function nfml*
|
|
(E-internal body* env x)))))]
|
|
[else (bug "invalid type" x)]))))
|
|
(define E-internal-done
|
|
(lambda (a d lhs* rhs* env)
|
|
(if (null? lhs*)
|
|
(E-begin^ a d env)
|
|
(let ([nlhs* (map (lambda (x) (gensym)) lhs*)])
|
|
(let ([env (append (map cons lhs* nlhs*) env)])
|
|
(let ([nrhs* (map (lambda (x) (E-def x env)) rhs*)])
|
|
(build-letrec* nlhs* nrhs* (E-begin^ a d env))))))))
|
|
;;;
|
|
(define E-when
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([test (car d)] [body* (cdr d)])
|
|
(build-conditional
|
|
(E test env)
|
|
(E-begin^ (car body*) (cdr body*) env)
|
|
(build-void)))))
|
|
;;;
|
|
(define E-unless
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([test (car d)] [body* (cdr d)])
|
|
(build-conditional
|
|
(E test env)
|
|
(build-void)
|
|
(E-begin^ (car body*) (cdr body*) env)))))
|
|
;;;
|
|
(define E-or
|
|
(lambda (d env x)
|
|
(cond
|
|
[(null? d) (build-constant #f)]
|
|
[(null? (cdr d)) (E (car d) env)]
|
|
[else
|
|
(let ([t (gensym)])
|
|
(build-let (list t) (list (E (car d) env))
|
|
(build-conditional
|
|
(build-lexical-reference t)
|
|
(build-lexical-reference t)
|
|
(E-or (cdr d) env x))))])))
|
|
;;;
|
|
(define E-and
|
|
(lambda (d env x)
|
|
(cond
|
|
[(null? d) (build-constant #t)]
|
|
[(null? (cdr d)) (E (car d) env)]
|
|
[else
|
|
(build-conditional
|
|
(E (car d) env)
|
|
(E-and (cdr d) env x)
|
|
(build-constant #f))])))
|
|
;;;
|
|
(define E-case
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([val (car d)] [cls* (cdr d)])
|
|
(let ([g (gensym)])
|
|
(build-let (list g)
|
|
(list (E val env))
|
|
(E-case-cls* g (car cls*) (cdr cls*) env x))))))
|
|
(define E-case-cls*
|
|
(lambda (g cls cls* env x)
|
|
(cond
|
|
[(null? cls*) (E-case-cls-last g cls env x)]
|
|
[else
|
|
(unless (and (list? cls) (fx>= (length cls) 2))
|
|
(syntax-error x))
|
|
(let ([ls (car cls)] [b* (cdr cls)])
|
|
(unless (list? ls) (syntax-error x))
|
|
(build-conditional
|
|
(build-memv (build-lexical-reference g)
|
|
(build-constant ls))
|
|
(E-begin^ (car b*) (cdr b*) env)
|
|
(E-case-cls* g (car cls*) (cdr cls*) env x)))])))
|
|
(define E-case-cls-last
|
|
(lambda (g cls env x)
|
|
(unless (and (list? cls) (fx>= (length cls) 2))
|
|
(syntax-error x))
|
|
(let ([fst (car cls)] [b* (cdr cls)])
|
|
(cond
|
|
[(and (eq? fst 'else)
|
|
(eq? (car (lookup 'else env)) 'global))
|
|
(E-begin^ (car b*) (cdr b*) env)]
|
|
[(list? fst)
|
|
(build-conditional
|
|
(build-memv (build-lexical-reference g)
|
|
(build-constant fst))
|
|
(E-begin^ (car b*) (cdr b*) env)
|
|
(build-void))]
|
|
[else (syntax-error x)]))))
|
|
;;;
|
|
(define E-cond
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 1) (syntax-error x))
|
|
(E-cond-cls* (car d) (cdr d) env x)))
|
|
(define E-cond-cls*
|
|
(lambda (cls cls* env x)
|
|
(cond
|
|
[(null? cls*) (E-cond-cls-last cls env x)]
|
|
[else
|
|
(E-cond-cls cls env x
|
|
(E-cond-cls* (car cls*) (cdr cls*) env x))])))
|
|
(define E-cond-cls
|
|
(lambda (cls env x k)
|
|
(unless (list? cls) (syntax-error x))
|
|
(let ([n (length cls)])
|
|
(unless (fx>= n 1) (syntax-error x))
|
|
(cond
|
|
[(fx= n 1)
|
|
(let ([g (gensym)])
|
|
(build-let (list g)
|
|
(list (E (car cls) env))
|
|
(build-conditional
|
|
(build-lexical-reference g)
|
|
(build-lexical-reference g)
|
|
k)))]
|
|
[(and (fx= n 3)
|
|
(eq? (cadr cls) '=>)
|
|
(eq? (car (lookup '=> env)) 'global))
|
|
(let ([g (gensym)])
|
|
(build-let (list g)
|
|
(list (E (car cls) env))
|
|
(build-conditional
|
|
(build-lexical-reference g)
|
|
(build-application
|
|
(E (caddr cls) env)
|
|
(list (build-lexical-reference g)))
|
|
k)))]
|
|
[else
|
|
(let ([test (car cls)] [body* (cdr cls)])
|
|
(build-conditional
|
|
(E test env)
|
|
(E-begin^ (car body*) (cdr body*) env)
|
|
k))]))))
|
|
(define E-cond-cls-last
|
|
(lambda (cls env x)
|
|
(unless (list? cls) (syntax-error x))
|
|
(cond
|
|
[(and (fx>= (length cls) 2)
|
|
(eq? (car cls) 'else)
|
|
(eq? (car (lookup 'else env)) 'global))
|
|
(let ([body* (cdr cls)])
|
|
(E-begin^ (car body*) (cdr body*) env))]
|
|
[else (E-cond-cls cls env x (build-void))])))
|
|
;;;
|
|
(define E-quasiquote
|
|
(lambda (d env x)
|
|
(unless (fx= (length d) 1) (syntax-error x))
|
|
(let ([expr (car d)])
|
|
(Eqq expr 0 env x
|
|
(lambda (what expr^)
|
|
(case what
|
|
[(splice) (syntax-error x)]
|
|
[(unquot) expr^]
|
|
[(quoted) expr^]
|
|
[else (error 'quasiquote "what ~s" what)]))))))
|
|
(define qqmacro?
|
|
(lambda (sym expr env)
|
|
(and (pair? expr)
|
|
(eq? (car expr) sym)
|
|
(let ([d (cdr expr)])
|
|
(and (pair? d) (null? (cdr d))))
|
|
(memq (car (lookup sym env)) '(global macro)))))
|
|
(define Eqq
|
|
(lambda (x depth env orig k)
|
|
(cond
|
|
[(qqmacro? 'unquote x env)
|
|
(if (fx= depth 0)
|
|
(k 'unquot (E (cadr x) env))
|
|
(Eqq (cadr x) (fx- depth 1) env orig
|
|
(lambda (what v)
|
|
(case what
|
|
[(splice)
|
|
(k 'unquot (qqbuild 'cons (build-constant 'unquote) v))]
|
|
[(unquot)
|
|
(k 'unquot (qqbuild 'list (build-constant 'unquote) v))]
|
|
[(quoted)
|
|
(k 'quoted (build-constant x))]
|
|
[else (error 'quasiquote "what ~s" what)]))))]
|
|
[(qqmacro? 'unquote-splicing x env)
|
|
(if (fx= depth 0)
|
|
(k 'splice (E (cadr x) env))
|
|
(Eqq (cadr x) (fx- depth 1) env orig
|
|
(lambda (what v)
|
|
(case what
|
|
[(splice)
|
|
(k 'splice
|
|
(qqbuild 'cons (build-constant 'unquote-splicing) v))]
|
|
[(unquot)
|
|
(k 'splice
|
|
(qqbuild 'list (build-constant 'unquote-splicing) v))]
|
|
[(quoted)
|
|
(k 'quoted (build-constant x))]
|
|
[else (error 'quasiquote "what ~s" what)]))))]
|
|
[(qqmacro? 'quasiquote x env)
|
|
(Eqq (cadr x) (fx+ depth 1) env orig
|
|
(lambda (what v)
|
|
(case what
|
|
[(splice)
|
|
(k 'unquot
|
|
(qqbuild 'cons (build-constant 'quasiquote) v))]
|
|
[(unquot)
|
|
(k 'unquot
|
|
(qqbuild 'list (build-constant 'quasiquote) v))]
|
|
[(quoted)
|
|
(k 'quoted (build-constant x))]
|
|
[else (error 'quasiquote "what ~s" what)])))]
|
|
[(pair? x)
|
|
(Eqq (car x) depth env orig
|
|
(lambda (what-a v-a)
|
|
(Eqq (cdr x) depth env orig
|
|
(lambda (what-d v-d)
|
|
(case what-a
|
|
[(splice)
|
|
(case what-d
|
|
[(splice) (syntax-error x)]
|
|
[(unquot)
|
|
(k 'unquot (qqbuild 'append v-a v-d))]
|
|
[(quoted)
|
|
(k 'unquot (qqbuild 'append v-a v-d))]
|
|
[else (error 'quasiquote "what ~s" what-d)])]
|
|
[(unquot)
|
|
(case what-d
|
|
[(splice) (syntax-error x)]
|
|
[(unquot)
|
|
(k 'unquot (qqbuild 'cons v-a v-d))]
|
|
[(quoted)
|
|
(k 'unquot (qqbuild 'cons v-a v-d))]
|
|
[else (error 'quasiquote "what ~s" what-d)])]
|
|
[(quoted)
|
|
(case what-d
|
|
[(splice) (syntax-error x)]
|
|
[(unquot)
|
|
(k 'unquot (qqbuild 'cons v-a v-d))]
|
|
[(quoted)
|
|
(k 'quoted (build-constant x))]
|
|
[else (error 'quasiquote "what ~s" what-d)])]
|
|
[else (error 'quasiquote "what ~s" what-a)])))))]
|
|
[(vector? x)
|
|
(let ()
|
|
(define vmap-list
|
|
(lambda (i ac)
|
|
(cond
|
|
[(fx= i -1)
|
|
(k 'unquot (qqbuild 'list->vector ac))]
|
|
[else
|
|
(Eqq (vector-ref x i) depth env orig
|
|
(lambda (what vi)
|
|
(case what
|
|
[(splice)
|
|
(vmap-list (fx- i 1)
|
|
(qqbuild 'append vi ac))]
|
|
[(unquot)
|
|
(vmap-list (fx- i 1) (qqbuild 'cons vi ac))]
|
|
[(quoted)
|
|
(vmap-list (fx- i 1) (qqbuild 'cons vi ac))]
|
|
[else (error 'quasiquote "what ~s" what)])))])))
|
|
(define vmap-vec
|
|
(lambda (i ac)
|
|
(cond
|
|
[(fx= i -1)
|
|
(k 'unquot
|
|
(build-application
|
|
(build-primref 'vector)
|
|
ac))]
|
|
[else
|
|
(Eqq (vector-ref x i) depth env orig
|
|
(lambda (what vi)
|
|
(case what
|
|
[(splice)
|
|
(vmap-list (fx- i 1)
|
|
(qqbuild 'append vi
|
|
(build-application
|
|
(build-primref 'list)
|
|
ac)))]
|
|
[(unquot)
|
|
(vmap-vec (fx- i 1) (cons vi ac))]
|
|
[(quoted)
|
|
(vmap-vec (fx- i 1) (cons vi ac))]
|
|
[else (error 'quasiquote "what ~s" what)])))])))
|
|
(define vmap-const
|
|
(lambda (i ac)
|
|
(cond
|
|
[(fx= i -1) (k 'quoted (build-constant x))]
|
|
[else
|
|
(Eqq (vector-ref x i) depth env orig
|
|
(lambda (what vi)
|
|
(case what
|
|
[(splice)
|
|
(if (null? ac)
|
|
(vmap-list (fx- i 1) vi)
|
|
(vmap-list (fx- i 1)
|
|
(qqbuild 'append vi (build-constant ac))))]
|
|
[(unquot)
|
|
(vmap-vec (fx- i 1)
|
|
(cons vi (map build-constant ac)))]
|
|
[(quoted)
|
|
(vmap-const (fx- i 1)
|
|
(cons (vector-ref x i) ac))]
|
|
[else (error 'quasiquote "what ~s" what)])))])))
|
|
(vmap-const (fx- (vector-length x) 1) '()))]
|
|
[else (k 'quoted (build-constant x))])))
|
|
(define qqbuild
|
|
(lambda (prim . args)
|
|
(build-application
|
|
(build-primref prim)
|
|
args)))
|
|
;;;
|
|
(define E-record-case
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 2) (syntax-error x))
|
|
(let ([val (car d)] [cls* (cdr d)])
|
|
(let ([g (gensym)])
|
|
(build-let
|
|
(list g)
|
|
(list (E val env))
|
|
(E-record-case-cls* (car cls*) (cdr cls*) g env x))))))
|
|
(define E-record-case-cls*
|
|
(lambda (cls cls* v env x)
|
|
(cond
|
|
[(null? cls*) (E-record-case-last-cls cls v env x)]
|
|
[else
|
|
(E-record-case-cls cls v env x
|
|
(E-record-case-cls* (car cls*) (cdr cls*) v env x))])))
|
|
(define E-record-case-cls
|
|
(lambda (cls v env x k)
|
|
(unless (and (list? cls) (fx>= (length cls) 2))
|
|
(syntax-error x))
|
|
(let ([pat (car cls)] [body* (cdr cls)])
|
|
(unless (and (list? pat) (andmap symbol? pat) (fx>= (length pat) 1))
|
|
(syntax-error x))
|
|
(let ([rtd-name (car pat)] [vars (cdr pat)])
|
|
(let ([b (lookup rtd-name env)])
|
|
(case (car b)
|
|
[(macro)
|
|
(unless (and (pair? (cdr b)) (eq? '$rtd (cadr b)))
|
|
(syntax-error x))
|
|
(let ([rtd (cddr b)]
|
|
[lhs* (map (lambda (x) (gensym)) vars)])
|
|
(build-conditional
|
|
(build-application
|
|
(build-application
|
|
(build-primref 'record-predicate)
|
|
(list (build-constant rtd)))
|
|
(list (build-lexical-reference v)))
|
|
(build-let
|
|
lhs*
|
|
(map (lambda (i)
|
|
(build-application
|
|
(build-application
|
|
(build-primref 'record-field-accessor)
|
|
(list (build-constant rtd)
|
|
(build-constant i)))
|
|
(list (build-lexical-reference v))))
|
|
(enumerate lhs*))
|
|
(E-begin^ (car body*) (cdr body*)
|
|
(extend-env-fml* vars lhs* env)))
|
|
k))]
|
|
[else (syntax-error x)]))))))
|
|
(define E-record-case-last-cls
|
|
(lambda (cls v env x)
|
|
(unless (and (list? cls) (fx>= (length cls) 2))
|
|
(syntax-error x))
|
|
(let ([pat (car cls)] [body* (cdr cls)])
|
|
(cond
|
|
[(and (eq? pat 'else)
|
|
(eq? (car (lookup 'else env)) 'global))
|
|
(E-begin^ (car body*) (cdr body*) env)]
|
|
[else
|
|
(E-record-case-cls cls v env x
|
|
(build-application
|
|
(build-primref 'error)
|
|
(list
|
|
(build-constant 'record-case)
|
|
(build-constant "unmatched ~s in ~s")
|
|
(build-lexical-reference v)
|
|
(build-constant x))))]))))
|
|
;;;
|
|
(define E-foreign-call
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 1) (syntax-error x))
|
|
(build-foreign-call
|
|
(E (car d) env)
|
|
(map (lambda (x) (E x env)) (cdr d)))))
|
|
;;;
|
|
(define E-primref
|
|
(lambda (d env x)
|
|
(unless (fx= (length d) 1) (syntax-error x))
|
|
(let ([sym (car d)])
|
|
(unless (symbol? sym) (syntax-error x))
|
|
(cond
|
|
[(primitive? sym) (build-primref sym)]
|
|
[else (syntax-error x)]))))
|
|
;;;
|
|
(define E-apply
|
|
(lambda (d env x)
|
|
(unless (fx>= (length d) 1) (syntax-error x))
|
|
(build-apply
|
|
(E (car d) env)
|
|
(map (lambda (x) (E x env)) (cdr d)))))
|
|
;;;
|
|
(define E-define-record
|
|
(lambda (d env x)
|
|
(error 'E-define-record "not yet")))
|
|
|
|
(define E-macro-call
|
|
(lambda (a d env x)
|
|
(case a
|
|
[(quote) (E-quote d env x)]
|
|
[(if) (E-if d env x)]
|
|
[(set!) (E-set! d env x)]
|
|
[(begin) (E-begin d env x)]
|
|
[(lambda) (E-lambda d env x)]
|
|
[(case-lambda) (E-case-lambda d env x)]
|
|
[(let) (E-let d env x)]
|
|
[(letrec) (E-letrec d env x)]
|
|
[(let*) (E-let* d env x)]
|
|
[(letrec*) (E-letrec* d env x)]
|
|
[(when) (E-when d env x)]
|
|
[(unless) (E-unless d env x)]
|
|
[(or) (E-or d env x)]
|
|
[(and) (E-and d env x)]
|
|
[(case) (E-case d env x)]
|
|
[(cond) (E-cond d env x)]
|
|
[(let-values) (E-let-values d env x)]
|
|
[(quasiquote) (E-quasiquote d env x)]
|
|
[(parameterize) (E-parameterize d env x)]
|
|
[(define-record) (E-define-record d env x)]
|
|
[(record-case) (E-record-case d env x)]
|
|
[(foreign-call) (E-foreign-call d env x)]
|
|
[(|#primitive|) (E-primref d env x)]
|
|
[($apply) (E-apply d env x)]
|
|
[else (syntax-error x)])))
|
|
;;;
|
|
(define E
|
|
(lambda (x env)
|
|
(cond
|
|
[(self-evaluating? x) (build-constant x)]
|
|
[(symbol? x)
|
|
(let ([b (lookup x env)])
|
|
(case (car b)
|
|
[(lexical)
|
|
(build-lexical-reference (cdr b))]
|
|
[(global)
|
|
(build-global-reference (cdr b))]
|
|
[else (syntax-error x)]))]
|
|
[(pair? x)
|
|
(let ([a (car x)] [d (cdr x)])
|
|
(unless (list? d) (syntax-error x))
|
|
(cond
|
|
[(symbol? a)
|
|
(let ([b (lookup a env)])
|
|
(case (car b)
|
|
[(lexical)
|
|
(build-application
|
|
(build-lexical-reference (cdr b))
|
|
(E* d env))]
|
|
[(global)
|
|
(build-application
|
|
(build-global-reference (cdr b))
|
|
(E* d env))]
|
|
[(macro)
|
|
(E-macro-call a d env x)]
|
|
[else (syntax-error x)]))]
|
|
[else
|
|
(build-application
|
|
(E a env)
|
|
(E* d env))]))]
|
|
[else (syntax-error x)])))
|
|
;;;
|
|
(define E*-top
|
|
(lambda (x x*)
|
|
(cond
|
|
[(null? x*) (E-top x)]
|
|
[else
|
|
(let ([x (E-top x)])
|
|
(build-sequence x (E*-top (car x*) (cdr x*))))])))
|
|
;;;
|
|
(define E-top-level-define
|
|
(lambda (d ctxt)
|
|
(let ([def (parse-define d empty-env ctxt)])
|
|
(let ([lhs (car def)] [rhs (cdr def)])
|
|
(remprop lhs *interaction-environment*)
|
|
(build-global-assignment lhs
|
|
(E-def rhs empty-env))))))
|
|
;;;
|
|
(define enumerate
|
|
(lambda (ls)
|
|
(let f ([ls ls] [i 0])
|
|
(cond
|
|
[(null? ls) '()]
|
|
[else (cons i (f (cdr ls) (fxadd1 i)))]))))
|
|
(define E-top-level-define-record
|
|
(lambda (d x)
|
|
(unless (fx= (length d) 2) (syntax-error x))
|
|
(let ([name (car d)] [fields (cadr d)])
|
|
(unless (symbol? name) (syntax-error x))
|
|
(unless (and (list? fields)
|
|
(andmap symbol? fields))
|
|
(syntax-error x))
|
|
(let ([str (symbol->string name)])
|
|
(let ([rtd (make-record-type str fields)])
|
|
(let ([constructor
|
|
(string->symbol (string-append "make-" str))]
|
|
[predicate
|
|
(string->symbol (string-append str "?"))]
|
|
[accessors
|
|
(map (lambda (field)
|
|
(string->symbol
|
|
(string-append str "-" (symbol->string field))))
|
|
fields)]
|
|
[mutators
|
|
(map (lambda (field)
|
|
(string->symbol
|
|
(string-append "set-" str "-"
|
|
(symbol->string field)
|
|
"!")))
|
|
fields)])
|
|
(for-each
|
|
(lambda (x) (remprop x *interaction-environment*))
|
|
(cons constructor
|
|
(cons predicate
|
|
(append accessors mutators))))
|
|
(putprop name *interaction-environment* (cons '$rtd rtd))
|
|
(sequence
|
|
(build-global-assignment
|
|
constructor
|
|
(build-application
|
|
(build-primref 'record-constructor)
|
|
(list (build-constant rtd))))
|
|
(build-global-assignment
|
|
predicate
|
|
(build-application
|
|
(build-primref 'record-predicate)
|
|
(list (build-constant rtd))))
|
|
(apply sequence
|
|
(map (lambda (accessor i)
|
|
(build-global-assignment
|
|
accessor
|
|
(build-application
|
|
(build-primref 'record-field-accessor)
|
|
(list (build-constant rtd)
|
|
(build-constant i)))))
|
|
accessors
|
|
(enumerate fields)))
|
|
(apply sequence
|
|
(map (lambda (mutator i)
|
|
(build-global-assignment
|
|
mutator
|
|
(build-application
|
|
(build-primref 'record-field-mutator)
|
|
(list (build-constant rtd)
|
|
(build-constant i)))))
|
|
mutators
|
|
(enumerate fields)))
|
|
)))))))
|
|
;;;
|
|
(define E-top
|
|
(lambda (x)
|
|
(cond
|
|
[(self-evaluating? x)
|
|
(build-constant x)]
|
|
[(symbol? x)
|
|
(when (keyword? x) (syntax-error x))
|
|
(build-global-reference x)]
|
|
[(pair? x)
|
|
(let ([a (car x)] [d (cdr x)])
|
|
(unless (list? d) (syntax-error x))
|
|
(cond
|
|
[(and (symbol? a) (keyword? a))
|
|
(cond
|
|
[(eq? a 'begin)
|
|
(if (null? d)
|
|
(build-void)
|
|
(E*-top (car d) (cdr d)))]
|
|
[(eq? a 'define)
|
|
(E-top-level-define d x)]
|
|
[(eq? a 'define-record)
|
|
(E-top-level-define-record d x)]
|
|
[else (E x empty-env)])]
|
|
[else
|
|
(build-application
|
|
(E a empty-env)
|
|
(E* d empty-env))]))]
|
|
[else (syntax-error x)])))
|
|
;;;
|
|
(primitive-set! 'core-expand E-top)
|
|
;;;
|
|
(primitive-set! 'current-expand
|
|
(make-parameter
|
|
core-expand
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
(error 'current-expand "~s is not a procedure" x))
|
|
x)))
|
|
;;;
|
|
(primitive-set! 'expand
|
|
(lambda (x)
|
|
((current-expand) x)))
|
|
;;;
|
|
(for-each
|
|
(lambda (x)
|
|
(putprop x *interaction-environment* x))
|
|
'(lambda set! let let* letrec letrec* if quote when unless set! begin
|
|
case-lambda define or and cond case foreign-call $apply |#primitive|
|
|
define-record record-case
|
|
quasiquote unquote unquote-splicing let-values parameterize
|
|
)))
|
|
|
|
|
|
|