libinterpret is gone.
This commit is contained in:
Abdulaziz Ghuloum
parent
599f68aa84
commit
f729a725d2
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -4920,6 +4920,19 @@
|
|||
(let ([proc ($code->closure code)])
|
||||
(proc)))))
|
||||
|
||||
(primitive-set! 'current-eval
|
||||
(make-parameter
|
||||
compile
|
||||
(lambda (f)
|
||||
(unless (procedure? f)
|
||||
(error 'current-eval "~s is not a procedure" f))
|
||||
f)))
|
||||
;;;
|
||||
(primitive-set! 'eval
|
||||
(lambda (x)
|
||||
((current-eval) x)))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,324 +0,0 @@
|
|||
|
||||
;;; 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))))
|
||||
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
gensym->unique-string call-with-values values make-parameter
|
||||
dynamic-wind display write print-graph fasl-write printf format
|
||||
print-error read-token read comment-handler error exit call/cc
|
||||
error-handler eval current-eval interpret compile compile-file
|
||||
error-handler eval current-eval compile compile-file
|
||||
new-cafe load system expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment identifier?
|
||||
free-identifier=? bound-identifier=? literal-identifier=?
|
||||
|
|
@ -226,7 +226,6 @@
|
|||
["libfasl.ss" #t "libfasl.fasl"]
|
||||
["libcompile.ss" #t "libcompile.fasl"]
|
||||
["psyntax-7.1.ss" #t "psyntax.fasl"]
|
||||
["libinterpret.ss" #t "libinterpret.fasl"]
|
||||
["libcafe.ss" #t "libcafe.fasl"]
|
||||
["libtrace.ss" #t "libtrace.fasl"]
|
||||
["libposix.ss" #t "libposix.fasl"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue