ikarus/lib/libinterpret.ss

325 lines
12 KiB
Scheme
Raw Normal View History

2006-11-23 19:44:29 -05:00
;;; 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))))