artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Revert "Speedup boot eval/apply."

Browse source 
This reverts commit 6326b3103156fd79cd7bebbb351194626cc8a64b.
This commit is contained in:
Jan Nieuwenhuizen 2016-10-23 14:25:37 +02:00
parent 0bd0cb2e3e
commit a00e69863e
1 changed files with 0 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

73
module/mes/mes-0.mes
View file

@ -82,11 +82,6 @@
((not (pair? m)) (eval m a))
(#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
(define (evlis-env m a)
(if (null? m) '()
(if (not (pair? m)) (eval m a)
(cons (eval (car m) a) (evlis-env (cdr m) a)))))
(define (apply-env fn x a)
(cond
((atom? fn)
@ -113,46 +108,6 @@
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
(#t (apply-env (eval fn a) x a))))
(define (apply-env fn x a)
(if (atom? fn) (if (builtin? fn) (call fn x)
(if (eq? fn 'call-with-values) (c:apply-env 'call-with-values x a)
(if (eq? fn 'current-module) a
(apply-env (eval fn a) x a))))
(if (eq? (car fn) 'lambda)
;; (let ((p (pairlis (cadr fn) x a)))
;; (cache-invalidate-range p (cdr a))
;; (let ((r (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
;; (cache-invalidate-range p (cdr a))
;; r))
((lambda (p)
(cache-invalidate-range p (cdr a))
((lambda (r)
(cache-invalidate-range p (cdr a))
r)
(eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
(pairlis (cadr fn) x a))
(if (eq? (car fn) '*closure*)
;; (let ((args (caddr fn))
;; (body (cdddr fn))
;; (a (cddr (cadr fn))))
;; (let ((p (pairlis args x a)))
;; (cache-invalidate-range p (cdr a))
;; (let ((r (eval-begin-env body (cons (cons '*closure* p) p))))
;; (cache-invalidate-range p (cdr a))
;; r)))
((lambda (a)
((lambda (p)
(cache-invalidate-range p (cdr a))
((lambda (r)
(cache-invalidate-range p (cdr a))
r)
(eval-begin-env (cdddr fn) (cons (cons '*closure* p) p))))
(pairlis (caddr fn) x a)))
(cddr (cadr fn)))
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
(apply-env (eval fn a) x a)))))
(define (eval-expand e a)
(cond
((symbol? e) (assq-ref-cache e a))
@ -174,25 +129,6 @@
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
(define (eval-expand e a)
(if (symbol? e) (assq-ref-cache e a)
(if (atom? e) e
(if (atom? (car e))
(if (eq? (car e) 'quote) (cadr e)
(if (eq? (car e) 'syntax) (cadr e)
(if (eq? (car e) 'begin) (eval-begin-env e a)
(if (eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a))
(if (eq? (car e) '*closure*) e
(if (eq? (car e) 'if) (eval-if-env (cdr e) a)
(if (eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a)
(if (eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a)
(if (eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a)
(if (eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a)
(if (eq? (car e) 'unquote) (eval (cadr e) a)
(if (eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a))
(apply-env (car e) (evlis-env (cdr e) a) a)))))))))))))
(apply-env (car e) (evlis-env (cdr e) a) a)))))
(define (unquote x) (cons 'unquote x))
(define (unquote-splicing x) (cons 'quasiquote x))
@ -234,15 +170,6 @@
(append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a)))
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
(define (eval-quasiquote e a)
(if (null? e) e
(if (atom? e) e
(if (eq? (car e) 'unquote) (eval (cadr e) a)
(if (pair? (car e)) (if (eq? (caar e) 'unquote-splicing) (append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a))
(cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))
(cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))))
(define (sexp:define e a)
(if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
(cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))