andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

boot woo

This commit is contained in:
Jan Nieuwenhuizen 2016-10-29 13:44:39 +02:00
parent f959b57825
commit 0751f51493
4 changed files with 107 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
mes.c
View File

@ -342,7 +342,9 @@ apply_env (scm *fn, scm *x, scm *a)
{
if (fn == &scm_car) return x->car->car;
if (fn == &scm_cdr) return x->car->cdr;
#if BOOT
if (fn == &scm_eval) assert (!"JA HEE!");
#endif
if (builtin_p (fn) == &scm_t)
return call (fn, x);
if (eq_p (fn, &symbol_call_with_values) == &scm_t)
@ -378,14 +380,22 @@ apply_env (scm *fn, scm *x, scm *a)
return apply_env (efn, x, a);
}
scm *mes_eval = 0;
scm *
boot (scm *eval)
{
mes_eval = eval;
}
scm *
eval (scm *e, scm *a)
{
static scm s = {SYMBOL, "eval"};
#if 0
static scm s = {SYMBOL, "mes:eval"};
static scm *x = 0;
fprintf (stderr, "c:eval e=");
display_ (stderr, e);
fprintf (stderr, "\n");
// fprintf (stderr, "c:eval e=");
// display_ (stderr, e);
// fprintf (stderr, "\n");
if (!x) x = make_symbol (&s);
scm *eval = assq_ref_cache (x, a);
@ -402,6 +412,20 @@ eval (scm *e, scm *a)
// return apply_env (eval, cons (e, cons (a, &scm_nil)), a);
}
return eval_ (e, a);
#else
//if (mes_eval) return apply_env (mes_eval, cons (e, cons (a, &scm_nil)), a);
if (mes_eval) {
fprintf (stderr, "gotta eval e=");
// display_ (stderr, mes_eval);
// fprintf (stderr, "e=");
display_ (stderr, e);
fprintf (stderr, "\n");
return apply_env (mes_eval, cons (e, cons (a, &scm_nil)), a);
//return eval_ (e, a); //cons (mes_eval, cons (e, a)), a);
}
return eval_ (e, a);
#endif
}
scm *

5
module/mes/loop-0.mes
View File

@ -40,15 +40,16 @@
(if (null? e) ;;(eval (read-file (read-env a) a) a)
((lambda (program)
(display "LOOP done eval=")
(display (cddr evlis-env))
(display (cddr mes:evlis-env))
(newline)
(display "program=")
(display program)
(newline)
(boot mes:eval)
;;(eval (read-file (read-env a) a) a)
;;(apply-env eval (read-file (read-env a) a) a)
;;(loop-1 (read-file (read-env a) a) a)
(eval-expand program a)
(eval program a)
)
(read-file (read-env a) a)
)

106
module/mes/mes-0.mes
View File

@ -76,20 +76,23 @@
(define (not x)
(if x #f #t))
(define (evlis-env m a)
(define (mes:evlis-env m a)
;; (display "mes:evlis-env m=") (display m) (newline)
(cond
((null? m) '())
((not (pair? m)) (eval-expand m a))
(#t (cons (eval-expand (car m) a) (evlis-env (cdr m) a)))))
((not (pair? m)) (mes:eval m a))
(#t (cons (mes:eval (car m) a) (mes:evlis-env (cdr m) a)))))
(define (apply-env fn x a)
(define (mes:apply-env fn x a)
(display "mes:apply fn=") (display fn) (newline)
(cond
((atom? fn)
(cond
((builtin? fn) (call fn x))
((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
((eq? fn 'call-with-values) (c:mes:apply-env 'call-with-values x a))
((eq? fn 'current-module) a)
(#t (apply-env (eval-expand fn a) x a))))
((eq? fn 'eval-expand) (eval-expand x a))
(#t (mes:apply-env (mes:eval fn a) x a))))
((eq? (car fn) 'lambda)
(let ((p (pairlis (cadr fn) x a)))
(cache-invalidate-range p (cdr a))
@ -105,16 +108,52 @@
(let ((r (eval-begin-env body (cons (cons '*closure* p) p))))
(cache-invalidate-range p (cdr a))
r))))
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
(#t (apply-env (eval-expand fn a) x a))))
;;((eq? (car fn) 'label) (mes:apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
(#t (mes:apply-env (mes:eval fn a) x a))))
(define (eval-expand e a)
(display "mes:eval-expand e=") (display e) (newline)
(cond
((internal? e) e)
((builtin? e) e)
((symbol? e) (assq-ref-cache e a))
;; ((symbol? e)
;; (display "symbol! e=") (display e) (newline)
;; (call assq-ref-cache (cons e (cons a '())))
;; ;;e
;; )
((atom? e) e)
((atom? (car e))
(cond
;; ((and (eq? (car e) 'eq?)
;; (eq? (cadr e) 'builtin?))
;; (mes:apply-env (cadr e) (cddr e) a)
;; )
;; ((and (eq? (car e) 'eq?)
;; (eq? (cadr e) 'internal?))
;; ;;(mes:apply-env (cadr e) (cddr e) a)
;; (call internal? (cddr e))
;; )
;; ((and (eq? (car e) 'eq?)
;; (eq? (cadr e) 'symbol?))
;; (mes:apply-env (cadr e) (cddr e) a)
;; )
;;((eq? (car e) 'assq-ref-cache) (mes:apply-env (car e) (cdr e) a))
;;((eq? (car e) 'internal?) (mes:apply-env (car e) (cdr e) a))
;;((eq? (car e) 'builtin?) (mes:apply-env (car e) (cdr e) a))
;;((eq? (car e) 'symbol?) (mes:apply-env (car e) (cdr e) a))
;; ((eq? (car e) 'assq-ref-cache) (call (car e) (cdr e)))
;; ((eq? (car e) 'symbol?) (call (car e) (cdr e)))
;; ((eq? (car e) 'internal?) (call (car e) (cdr e)))
;; ((eq? (car e) 'builtin?) (call (car e) (cdr e)))
;;((eq? (car e) 'assq-ref-cache) (call assq-ref-cache (cdr e)))
((eq? (car e) 'symbol?) (call symbol? (cdr e)))
((eq? (car e) 'internal?) (call internal? (cdr e)))
((eq? (car e) 'builtin?) (call builtin? (cdr e)))
((eq? (car e) 'quote) (cadr e))
((eq? (car e) 'syntax) (cadr e))
((eq? (car e) 'begin) (eval-begin-env e a))
@ -123,12 +162,13 @@
((eq? (car e) 'if) (eval-if-env (cdr e) a))
((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
((eq? (car e) 'set!) (set-env! (cadr e) (eval-expand (caddr e) a) a))
((eq? (car e) 'apply-env) (apply-env (eval-expand (cadr e) a) (evlis-env (caddr e) a) a))
((eq? (car e) 'unquote) (eval-expand (cadr e) a))
((eq? (car e) 'set!) (set-env! (cadr e) (mes:eval (caddr e) a) a))
((eq? (car e) 'mes:apply-env) (mes:apply-env (mes:eval (cadr e) a) (mes:evlis-env (caddr e) a) a))
;; ((eq? (car e) 'eval-expand) (eval-expand e a))
((eq? (car e) 'unquote) (mes:eval (cadr e) a))
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
(#t (apply-env (car e) (evlis-env (cdr e) a) a))))
(#t (mes:apply-env (car e) (mes:evlis-env (cdr e) a) a))))
(#t (mes:apply-env (car e) (mes:evlis-env (cdr e) a) a))))
(define (unquote x) (cons 'unquote x))
(define (unquote-splicing x) (cons 'quasiquote x))
@ -141,40 +181,40 @@
(define (add-unquoters a)
(cons %the-unquoters a))
(define (eval e a)
(display "mes:eval-expand e=") (display e) (newline)
(eval-expand (expand-macro-env e a) a))
(define (mes:eval e a)
;;(display "mes:mes:eval e=") (display e) (newline)
(eval-expand (mes:expand-macro-env e a) a))
(define (expand-macro-env e a)
(define (mes:expand-macro-env e a)
(if (pair? e) ((lambda (macro)
(if macro (expand-macro-env (apply-env macro (cdr e) a) a)
(if macro (mes:expand-macro-env (mes:apply-env macro (cdr e) a) a)
e))
(lookup-macro (car e) a))
e))
(define (eval-begin-env e a)
(if (null? e) *unspecified*
(if (null? (cdr e)) (eval-expand (car e) a)
(if (null? (cdr e)) (mes:eval (car e) a)
(begin
(eval-expand (car e) a)
(mes:eval (car e) a)
(eval-begin-env (cdr e) a)))))
(define (eval-if-env e a)
(if (eval-expand (car e) a) (eval-expand (cadr e) a)
(if (pair? (cddr e)) (eval-expand (caddr e) a))))
(if (mes:eval (car e) a) (mes:eval (cadr e) a)
(if (pair? (cddr e)) (mes:eval (caddr e) a))))
(define (eval-quasiquote e a)
(cond ((null? e) e)
((atom? e) e)
((eq? (car e) 'unquote) (eval-expand (cadr e) a))
((eq? (car e) 'unquote) (mes:eval (cadr e) a))
((and (pair? (car e))
(eq? (caar e) 'unquote-splicing))
(append2 (eval-expand (cadar e) a) (eval-quasiquote (cdr e) a)))
(append2 (mes:eval (cadar e) a) (eval-quasiquote (cdr e) a)))
(#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
(define (sexp:define e a)
(if (atom? (cadr e)) (cons (cadr e) (eval-expand (caddr e) a))
(cons (caadr e) (eval-expand (cons 'lambda (cons (cdadr e) (cddr e))) a))))
(if (atom? (cadr e)) (cons (cadr e) (mes:eval (caddr e) a))
(cons (caadr e) (mes:eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
(define (env:define a+ a)
(set-cdr! a+ (cdr a))
@ -195,18 +235,12 @@
begin
((lambda (program)
(display "PROGRAM done program=")
;; (display "program=")
;; (display program)
;; (newline)
;;(eval (read-file (read-env a) a) a)
;;(apply-env eval (read-file (read-env a) a) a)
;;(loop-1 (read-file (read-env a) a) a)
(eval-expand program (current-module))
)
;;(boot (current-module))
;; (boot mes:eval)
(eval program (current-module)))
(read-file (read-env (current-module)) (current-module)))
;; boot into mes-0
(cache-invalidate-range (current-module) '())
;; (cache-invalidate-range (current-module) '())
()
;;ignored
begin

6
type.c
View File

@ -56,6 +56,12 @@ string_p (scm *x)
return x->type == STRING ? &scm_t : &scm_f;
}
scm *
internal_p (scm *x)
{
return x->type == SCM ? &scm_t : &scm_f;
}
scm *
symbol_p (scm *x)
{