325 lines
12 KiB
Scheme
325 lines
12 KiB
Scheme
|
|
;;; Changes:
|
|
;;; 6.5: handles letrec
|
|
;;; 6.1: adding case-lambda, dropping lambda
|
|
;;; 6.0: basic version working
|
|
;;;
|
|
|
|
;;; Expand : Scheme -> Core Scheme
|
|
;;;
|
|
;;; <CS> ::= (quote datum)
|
|
;;; | <gensym>
|
|
;;; | (if <CS> <CS> <CS>)
|
|
;;; | (set! <gensym> <CS>)
|
|
;;; | (begin <CS> <CS> ...)
|
|
;;; | (case-lambda (<FML> <CS>) (<FML> <CS>) ...)
|
|
;;; | (<prim> <CS> <CS> ...)
|
|
;;; | (primref <primname>)
|
|
;;; | (<CS> <CS> ...)
|
|
;;; <FML> ::= ()
|
|
;;; | <gensym>
|
|
;;; | (<gensym> . <FML>)
|
|
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
|
|
;;;
|
|
|
|
|
|
(let ()
|
|
(define syntax-error
|
|
(lambda (x)
|
|
(error 'interpret "invalid syntax ~s" x)))
|
|
;;;
|
|
(define C*->last
|
|
(lambda (a d env)
|
|
(cond
|
|
[(null? d) (C a env)]
|
|
[else
|
|
(let ([a (C a env)]
|
|
[d (C*->last (car d) (cdr d) env)])
|
|
(lambda (renv)
|
|
(a renv)
|
|
(d renv)))])))
|
|
;;;
|
|
(define C*->list
|
|
(lambda (a d env)
|
|
(cond
|
|
[(null? d)
|
|
(let ([a (C a env)])
|
|
(lambda (renv)
|
|
(list (a renv))))]
|
|
[else
|
|
(let ([a (C a env)]
|
|
[d (C*->list (car d) (cdr d) env)])
|
|
(lambda (renv)
|
|
(cons (a renv) (d renv))))])))
|
|
;;;
|
|
(define extend-env
|
|
(lambda (fml* env)
|
|
(cons fml* env)))
|
|
;;;
|
|
(define fml-length
|
|
(lambda (fml* x)
|
|
(cond
|
|
[(pair? fml*) (fxadd1 (fml-length (cdr fml*) x))]
|
|
[(null? fml*) 0]
|
|
[(symbol? fml*) 1]
|
|
[else (syntax-error x)])))
|
|
;;;
|
|
(define whack-proper
|
|
(lambda (v ls i j)
|
|
(cond
|
|
[(null? ls)
|
|
(if (fx= i j)
|
|
v
|
|
(error 'apply1 "incorrect number of arguments to procedure"))]
|
|
[(fx= i j)
|
|
(error 'apply2 "incorrect number of arguments to procedure")]
|
|
[else
|
|
(vector-set! v i (car ls))
|
|
(whack-proper v (cdr ls) (fxadd1 i) j)])))
|
|
;;;
|
|
(define whack-improper
|
|
(lambda (v ls i j)
|
|
(cond
|
|
[(fx= i j) (vector-set! v i ls) v]
|
|
[(null? ls)
|
|
(error 'apply3 "incorrect number of arguments to procedure")]
|
|
[else
|
|
(vector-set! v i (car ls))
|
|
(whack-improper v (cdr ls) (fxadd1 i) j)])))
|
|
;;;
|
|
(define lookup
|
|
(lambda (x env)
|
|
(define Lj
|
|
(lambda (x fml* j)
|
|
(cond
|
|
[(pair? fml*)
|
|
(if (eq? (car fml*) x)
|
|
j
|
|
(Lj x (cdr fml*) (fxadd1 j)))]
|
|
[(eq? x fml*) j]
|
|
[else #f])))
|
|
(define Li
|
|
(lambda (x env i)
|
|
(cond
|
|
[(null? env) #f]
|
|
[(Lj x (car env) 0) =>
|
|
(lambda (j)
|
|
(cons i j))]
|
|
[else (Li x (cdr env) (fxadd1 i))])))
|
|
(Li x env 0)))
|
|
;;;
|
|
(define C
|
|
(lambda (x env)
|
|
(cond
|
|
[(gensym? x)
|
|
(cond
|
|
[(lookup x env) =>
|
|
(lambda (b)
|
|
(let ([i (car b)] [j (cdr b)])
|
|
(lambda (renv)
|
|
(vector-ref (list-ref renv i) j))))]
|
|
[else (syntax-error x)])]
|
|
[(pair? x)
|
|
(let ([a (car x)] [d (cdr x)])
|
|
(unless (list? d) (syntax-error x))
|
|
(cond
|
|
[(eq? a 'quote)
|
|
(unless (fx= (length d) 1) (syntax-error x))
|
|
(let ([v (car d)])
|
|
(lambda (renv) v))]
|
|
[(eq? a 'if)
|
|
(unless (fx= (length d) 3) (syntax-error x))
|
|
(let ([test (C (car d) env)]
|
|
[conseq (C (cadr d) env)]
|
|
[altern (C (caddr d) env)])
|
|
(lambda (renv)
|
|
(if (test renv)
|
|
(conseq renv)
|
|
(altern renv))))]
|
|
[(eq? a 'set!)
|
|
(unless (fx= (length d) 2) (syntax-error x))
|
|
(let ([var (car d)] [val (C (cadr d) env)])
|
|
(cond
|
|
[(lookup var env) =>
|
|
(lambda (b)
|
|
(let ([i (car b)] [j (cdr b)])
|
|
(lambda (renv)
|
|
(vector-set! (list-ref renv i) j (val renv)))))]
|
|
[else (syntax-error x)]))]
|
|
[(eq? a 'begin)
|
|
(unless (fx>= (length d) 1) (syntax-error x))
|
|
(C*->last (car d) (cdr d) env)]
|
|
[(eq? a 'letrec)
|
|
(let ([bind* (car d)] [body* (cdr d)])
|
|
(if (null? bind*)
|
|
(C*->last (car body*) (cdr body*) env)
|
|
(let ([lhs* (map car bind*)] [rhs* (map cadr bind*)])
|
|
(let ([env (extend-env lhs* env)])
|
|
(let ([body* (C*->last (car body*) (cdr body*) env)]
|
|
[rhs* (C*->list (car rhs*) (cdr rhs*) env)]
|
|
[n (length lhs*)])
|
|
(lambda (renv)
|
|
(let ([v (make-vector n)])
|
|
(let ([renv (cons v renv)])
|
|
(let f ([i 0] [ls (rhs* renv)])
|
|
(if (null? ls)
|
|
(body* renv)
|
|
(begin
|
|
(vector-set! v i (car ls))
|
|
(f (fxadd1 i) (cdr ls))))))))
|
|
)))))]
|
|
[(eq? a 'case-lambda)
|
|
(unless (fx>= (length d) 1) (syntax-error x))
|
|
(let ()
|
|
(define generate
|
|
(lambda (d)
|
|
(cond
|
|
[(null? d)
|
|
(lambda (n args renv)
|
|
(error 'apply
|
|
"incorrect number of arguments ~s to procedure"
|
|
n))]
|
|
[else
|
|
(let ([k (generate (cdr d))]
|
|
[a (car d)])
|
|
(let ([fml (car a)] [body* (cdr a)])
|
|
(let ([env (extend-env fml env)]
|
|
[n (fml-length fml x)])
|
|
(let ([body*
|
|
(C*->last (car body*) (cdr body*) env)])
|
|
(if (list? fml)
|
|
(lambda (m args renv)
|
|
(if (fx= n m)
|
|
(body* (cons (list->vector args) renv))
|
|
(k m args renv)))
|
|
(let ([q (fxsub1 n)])
|
|
(lambda (m args renv)
|
|
(if (fx>= m q)
|
|
(let ([v (make-vector n)])
|
|
(let f ([i 0] [args args])
|
|
(cond
|
|
[(fx= i q)
|
|
(vector-set! v q args)]
|
|
[else
|
|
(vector-set! v i (car args))
|
|
(f (fxadd1 i) (cdr args))]))
|
|
(body* (cons v renv)))
|
|
(k m args renv)))))))))])))
|
|
(let ([dispatch (generate d)])
|
|
(lambda (renv)
|
|
(lambda args
|
|
(dispatch (length args) args renv)))))]
|
|
[(eq? a 'void)
|
|
(unless (fx= (length d) 0) (syntax-error x))
|
|
(lambda (renv) (void))]
|
|
[(eq? a 'memv)
|
|
(unless (fx= (length d) 2) (syntax-error x))
|
|
(let ([val (C (car d) env)] [list (C (cadr d) env)])
|
|
(lambda (renv)
|
|
(memq (val renv) (list renv))))]
|
|
[(eq? a 'top-level-value)
|
|
(unless (fx= (length d) 1) (syntax-error x))
|
|
(let ([qsym (car d)])
|
|
(unless (and (pair? qsym)
|
|
(fx= (length qsym) 2)
|
|
(eq? (car qsym) 'quote)
|
|
(symbol? (cadr qsym)))
|
|
(syntax-error x))
|
|
(let ([sym (cadr qsym)])
|
|
(if (top-level-bound? sym)
|
|
(lambda (renv)
|
|
(top-level-value sym))
|
|
(lambda (renv)
|
|
(if (top-level-bound? sym)
|
|
(top-level-value sym)
|
|
(error #f "~s is unbound" sym))))))]
|
|
[(memq a '(set-top-level-value!))
|
|
(unless (fx= (length d) 2) (syntax-error x))
|
|
(let ([qsym (car d)] [val (C (cadr d) env)])
|
|
(unless (and (pair? qsym)
|
|
(fx= (length qsym) 2)
|
|
(eq? (car qsym) 'quote)
|
|
(symbol? (cadr qsym)))
|
|
(syntax-error x))
|
|
(let ([sym (cadr qsym)])
|
|
(lambda (renv)
|
|
(set-top-level-value! sym (val renv)))))]
|
|
;;; [(eq? a '$pcb-set!)
|
|
;;; (unless (fx= (length d) 2) (syntax-error x))
|
|
;;; (let ([sym (car d)] [val (C (cadr d) env)])
|
|
;;; (unless (symbol? sym) (syntax-error x))
|
|
;;; (lambda (renv)
|
|
;;; (set-top-level-value! sym (val renv))))]
|
|
[(eq? a '|#primitive|)
|
|
(unless (fx= (length d) 1) (syntax-error x))
|
|
(let ([sym (car d)])
|
|
(let ([prim (primitive-ref sym)])
|
|
(if (procedure? prim)
|
|
(lambda (renv) prim)
|
|
(syntax-error x))))]
|
|
[(memq a '(foreign-call $apply))
|
|
(error 'interpret "~a form is not supported" a)]
|
|
;;; [else
|
|
;;; (let ([rator (C a env)] [n (length d)])
|
|
;;; (cond
|
|
;;; [(fx= n 0)
|
|
;;; (lambda (renv)
|
|
;;; (let ([p (rator renv)])
|
|
;;; (p)))]
|
|
;;; [(fx= n 1)
|
|
;;; (let ([arg1 (C (car d) env)])
|
|
;;; (lambda (renv)
|
|
;;; (let ([p (rator renv)])
|
|
;;; (p (arg1 renv)))))]
|
|
;;; [(fx= n 2)
|
|
;;; (let ([arg1 (C (car d) env)]
|
|
;;; [arg2 (C (cadr d) env)])
|
|
;;; (lambda (renv)
|
|
;;; (let ([p (rator renv)])
|
|
;;; (p (arg1 renv) (arg2 renv)))))]
|
|
;;; [else
|
|
;;; (let ([arg* (C*->list (car d) (cdr d) env)])
|
|
;;; (lambda (renv)
|
|
;;; (apply (rator renv) (arg* renv))))]))]
|
|
[else
|
|
(let ([rator (C a env)] [n (length d)])
|
|
(cond
|
|
[(fx= n 0)
|
|
(lambda (renv)
|
|
(apply (rator renv) '()))]
|
|
;[(fx= n 1)
|
|
; (let ([arg1 (C (car d) env)])
|
|
; (lambda (renv)
|
|
; ((rator renv) (arg1 renv))))]
|
|
;[(fx= n 2)
|
|
; (let ([arg1 (C (car d) env)]
|
|
; [arg2 (C (cadr d) env)])
|
|
; (lambda (renv)
|
|
; ((rator renv) (arg1 renv) (arg2 renv))))]
|
|
[else
|
|
(let ([arg* (C*->list (car d) (cdr d) env)])
|
|
(lambda (renv)
|
|
(apply (rator renv) (arg* renv))))]))]
|
|
|
|
))]
|
|
[else (syntax-error x)])))
|
|
;;;
|
|
(primitive-set! 'interpret
|
|
(lambda (x)
|
|
(let ([x (expand x)])
|
|
(let ([p (C x '())])
|
|
(p '())))))
|
|
;;;
|
|
(primitive-set! 'current-eval
|
|
(make-parameter
|
|
interpret
|
|
(lambda (f)
|
|
(unless (procedure? f)
|
|
(error 'current-eval "~s is not a procedure" f))
|
|
f)))
|
|
;;;
|
|
(primitive-set! 'eval
|
|
(lambda (x)
|
|
((current-eval) x))))
|
|
|