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_car) return x->car->car;
if (fn == &scm_cdr) return x->car->cdr; if (fn == &scm_cdr) return x->car->cdr;
#if BOOT
if (fn == &scm_eval) assert (!"JA HEE!"); if (fn == &scm_eval) assert (!"JA HEE!");
#endif
if (builtin_p (fn) == &scm_t) if (builtin_p (fn) == &scm_t)
return call (fn, x); return call (fn, x);
if (eq_p (fn, &symbol_call_with_values) == &scm_t) 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); return apply_env (efn, x, a);
} }
scm *mes_eval = 0;
scm *
boot (scm *eval)
{
mes_eval = eval;
}
scm * scm *
eval (scm *e, scm *a) eval (scm *e, scm *a)
{ {
static scm s = {SYMBOL, "eval"}; #if 0
static scm s = {SYMBOL, "mes:eval"};
static scm *x = 0; static scm *x = 0;
fprintf (stderr, "c:eval e="); // fprintf (stderr, "c:eval e=");
display_ (stderr, e); // display_ (stderr, e);
fprintf (stderr, "\n"); // fprintf (stderr, "\n");
if (!x) x = make_symbol (&s); if (!x) x = make_symbol (&s);
scm *eval = assq_ref_cache (x, a); 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 apply_env (eval, cons (e, cons (a, &scm_nil)), a);
} }
return eval_ (e, 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 * scm *

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

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

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

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

6
type.c
View File

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