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)])
|
(let ([proc ($code->closure code)])
|
||||||
(proc)))))
|
(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
|
gensym->unique-string call-with-values values make-parameter
|
||||||
dynamic-wind display write print-graph fasl-write printf format
|
dynamic-wind display write print-graph fasl-write printf format
|
||||||
print-error read-token read comment-handler error exit call/cc
|
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
|
new-cafe load system expand sc-expand current-expand expand-mode
|
||||||
environment? interaction-environment identifier?
|
environment? interaction-environment identifier?
|
||||||
free-identifier=? bound-identifier=? literal-identifier=?
|
free-identifier=? bound-identifier=? literal-identifier=?
|
||||||
|
|
@ -226,7 +226,6 @@
|
||||||
["libfasl.ss" #t "libfasl.fasl"]
|
["libfasl.ss" #t "libfasl.fasl"]
|
||||||
["libcompile.ss" #t "libcompile.fasl"]
|
["libcompile.ss" #t "libcompile.fasl"]
|
||||||
["psyntax-7.1.ss" #t "psyntax.fasl"]
|
["psyntax-7.1.ss" #t "psyntax.fasl"]
|
||||||
["libinterpret.ss" #t "libinterpret.fasl"]
|
|
||||||
["libcafe.ss" #t "libcafe.fasl"]
|
["libcafe.ss" #t "libcafe.fasl"]
|
||||||
["libtrace.ss" #t "libtrace.fasl"]
|
["libtrace.ss" #t "libtrace.fasl"]
|
||||||
["libposix.ss" #t "libposix.fasl"]
|
["libposix.ss" #t "libposix.fasl"]
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue