mes.c: refactor begin and closures. Fixes bugs/top.mes.
This commit is contained in:
Jan Nieuwenhuizen
parent
7662a0918d
commit
711a29f4f9
12
bugs/top.mes
12
bugs/top.mes
|
|
@ -1,12 +0,0 @@
|
|||
(begin (define *test-begin-a* '*test-begin-a*))
|
||||
|
||||
(display "defined? *test-begin-a*: ")
|
||||
(display (defined? '*test-begin-a*))
|
||||
(newline)
|
||||
(display *test-begin-a*)
|
||||
(newline)
|
||||
|
||||
(let () (define *test-let-a* '*test-let-a*) #f)
|
||||
(display "defined? *test-let-a*: ")
|
||||
(display (defined? '*test-let-a*))
|
||||
(newline)
|
||||
79
mes.c
79
mes.c
|
|
@ -81,7 +81,7 @@ scm scm_t = {SYMBOL, "#t"};
|
|||
scm scm_f = {SYMBOL, "#f"};
|
||||
scm scm_unspecified = {SYMBOL, "*unspecified*"};
|
||||
|
||||
scm symbol_closure = {SYMBOL, "*lambda*"};
|
||||
scm symbol_closure = {SYMBOL, "*closure*"};
|
||||
scm symbol_circ = {SYMBOL, "*circ*"};
|
||||
scm symbol_lambda = {SYMBOL, "lambda"};
|
||||
scm symbol_begin = {SYMBOL, "begin"};
|
||||
|
|
@ -277,13 +277,17 @@ apply_env (scm *fn, scm *x, scm *a)
|
|||
if (builtin_p (fn) == &scm_t)
|
||||
return call (fn, x);
|
||||
}
|
||||
else if (car (fn) == &symbol_lambda)
|
||||
return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a));
|
||||
else if (car (fn) == &symbol_lambda) {
|
||||
scm *p = pairlis (cadr (fn), x, a);
|
||||
return eval (cons (&symbol_begin, cddr (fn)), cons (cons (&symbol_closure, p), p));
|
||||
}
|
||||
else if (car (fn) == &symbol_closure) {
|
||||
scm *args = caddr (fn);
|
||||
scm *body = cdddr (fn);
|
||||
a = cdadr (fn);
|
||||
return eval (cons (&symbol_begin, body), pairlis (args, x, a));
|
||||
a = cdr (a);
|
||||
scm *p = pairlis (args, x, a);
|
||||
return eval (cons (&symbol_begin, body), cons (cons (&symbol_closure, p), p));
|
||||
}
|
||||
else if ((macro = lookup_macro (car (fn), a)) != &scm_f) {
|
||||
scm *r = apply_env (eval (macro, a), cdr (fn), a);
|
||||
|
|
@ -303,6 +307,8 @@ eval (scm *e, scm *a)
|
|||
#if DEBUG
|
||||
printf ("\neval e=");
|
||||
display (e);
|
||||
printf ("\na=");
|
||||
display (a);
|
||||
puts ("");
|
||||
#endif
|
||||
scm *macro;
|
||||
|
|
@ -324,37 +330,15 @@ eval (scm *e, scm *a)
|
|||
if (car (e) == &symbol_begin)
|
||||
{
|
||||
scm *body = cdr (e);
|
||||
scm *defines = &scm_nil;
|
||||
while (body != &scm_nil) {
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
if (e->type == PAIR
|
||||
&& (eq_p (car (e), &symbol_define) == &scm_t
|
||||
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) {
|
||||
defines = append2 (defines, cons (def (e), &scm_nil));
|
||||
e = &scm_unspecified;
|
||||
}
|
||||
else break;
|
||||
}
|
||||
a = append2 (defines, a);
|
||||
while (defines != &scm_nil) {
|
||||
scm *name = caar (defines);
|
||||
scm *entry = assq (name, a);
|
||||
scm *x = cdar (defines);
|
||||
set_cdr_x (entry, cdr (define (x, a)));
|
||||
// if (eq_p (car (x), &symbol_define_macro) == &scm_t)
|
||||
// set_cdr_x (last_pair (a), cons (cons (name, cdr (define (x, a))), &scm_nil));
|
||||
defines = cdr (defines);
|
||||
}
|
||||
scm *fubar = cons (&scm_dot, &scm_dot);
|
||||
scm *r = eval (e, cons (fubar, a));
|
||||
if (r->type == PAIR && macro_p (cdr (r)))
|
||||
a = cons (r, a); // macros defining macros...
|
||||
if (body == &scm_nil) return &scm_unspecified;
|
||||
e = car (body);
|
||||
body = cdr (body);
|
||||
scm *r = eval (e, a);
|
||||
if (body == &scm_nil) return r;
|
||||
return eval (cons (&symbol_begin, body), a);
|
||||
}
|
||||
if (car (e) == &symbol_lambda)
|
||||
return make_closure (cadr (e), cddr (e), a);
|
||||
return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a));
|
||||
if (car (e) == &symbol_closure)
|
||||
return e;
|
||||
if (car (e) == &symbol_unquote)
|
||||
|
|
@ -363,8 +347,8 @@ eval (scm *e, scm *a)
|
|||
return eval_quasiquote (cadr (e), add_unquoters (a));
|
||||
if (car (e) == &symbol_cond)
|
||||
return evcon (cdr (e), a);
|
||||
// if (eq_p (car (e), &symbol_define) == &scm_t)
|
||||
// return define (e, a);
|
||||
if (eq_p (car (e), &symbol_define) == &scm_t)
|
||||
return define (e, a);
|
||||
if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||
return define (e, a);
|
||||
if ((macro = lookup_macro (car (e), a)) != &scm_f)
|
||||
|
|
@ -820,6 +804,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
|
|||
printf ("(*circ* . #-1#)");
|
||||
return &scm_unspecified;
|
||||
}
|
||||
if (car (x) == &symbol_closure) {
|
||||
printf ("(*closure* . #-1#)");
|
||||
return &scm_unspecified;
|
||||
}
|
||||
if (car (x) == &scm_quote) {
|
||||
printf ("'");
|
||||
return display_helper (car (cdr (x)), cont, "", true);
|
||||
|
|
@ -1129,8 +1117,13 @@ mes_environment ()
|
|||
a = cons (cons (&symbol_begin, &symbol_begin), a);
|
||||
a = cons (cons (&symbol_quote, &scm_quote), a);
|
||||
|
||||
#if MES_FULL
|
||||
#include "environment.i"
|
||||
|
||||
#else
|
||||
a = add_environment (a, "display", &scm_display);
|
||||
a = add_environment (a, "newline", &scm_newline);
|
||||
#endif
|
||||
a = cons (cons (&symbol_closure, a), a);
|
||||
return a;
|
||||
}
|
||||
|
||||
|
|
@ -1143,15 +1136,7 @@ make_lambda (scm *args, scm *body)
|
|||
scm *
|
||||
make_closure (scm *args, scm *body, scm *a)
|
||||
{
|
||||
return cons (&symbol_closure, cons (cons (&symbol_circ, cdr (a)), cons (args, body)));
|
||||
}
|
||||
|
||||
scm *
|
||||
def (scm *x)
|
||||
{
|
||||
if (atom_p (cadr (x)) != &scm_f)
|
||||
return cons (cadr (x), x);
|
||||
return cons (caadr (x), x);
|
||||
return cons (&symbol_closure, cons (cons (&symbol_circ, a), cons (args, body)));
|
||||
}
|
||||
|
||||
scm *
|
||||
|
|
@ -1168,7 +1153,13 @@ define (scm *x, scm *a)
|
|||
}
|
||||
if (eq_p (car (x), &symbol_define_macro) == &scm_t)
|
||||
e = make_macro (e);
|
||||
return cons (name, e);
|
||||
scm *entry = cons (name, e);
|
||||
scm *aa = cons (entry, &scm_nil);
|
||||
set_cdr_x (aa, cdr (a));
|
||||
set_cdr_x (a, aa);
|
||||
scm *cl = assq (&symbol_closure, a);
|
||||
set_cdr_x (cl, aa);
|
||||
return entry;
|
||||
}
|
||||
|
||||
scm *
|
||||
|
|
|
|||
32
scm.mes
32
scm.mes
|
|
@ -21,6 +21,15 @@
|
|||
;; The Maxwell Equations of Software -- John McCarthy page 13
|
||||
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
||||
|
||||
(define-macro (if expr then . else)
|
||||
`(cond
|
||||
(,expr ,then)
|
||||
(#t (cond (,(pair? else) ((lambda () ,@else)))))))
|
||||
|
||||
(define-macro (when expr . body)
|
||||
`(if ,expr
|
||||
((lambda () ,@body))))
|
||||
|
||||
(define (list . rest) rest)
|
||||
|
||||
(define (split-params bindings params)
|
||||
|
|
@ -109,7 +118,7 @@
|
|||
(define (procedure? p)
|
||||
(cond ((builtin? p) #t)
|
||||
((and (pair? p) (eq? (car p) 'lambda)))
|
||||
((and (pair? p) (eq? (car p) '*lambda*)))
|
||||
((and (pair? p) (eq? (car p) '*closure*)))
|
||||
(#t #f)))
|
||||
|
||||
(define (assq-set! alist key val)
|
||||
|
|
@ -163,15 +172,6 @@
|
|||
(or (null? x)
|
||||
(and (pair? x) (list? (cdr x)))))
|
||||
|
||||
(define-macro (if expr then . else)
|
||||
`(cond
|
||||
(,expr ,then)
|
||||
(#t (cond (,(pair? else) ((lambda () ,@else)))))))
|
||||
|
||||
(define-macro (when expr . body)
|
||||
`(if ,expr
|
||||
((lambda () ,@body))))
|
||||
|
||||
(define (unspecified-bindings bindings params)
|
||||
(cond ((null? bindings) params)
|
||||
(#t (unspecified-bindings
|
||||
|
|
@ -189,16 +189,8 @@
|
|||
,@(letrec-setters bindings '())
|
||||
,@body))
|
||||
|
||||
;; TODO
|
||||
;; (define gensym
|
||||
;; (let ((counter 0))
|
||||
;; (lambda (. rest)
|
||||
;; (let ((value (number->string counter)))
|
||||
;; (set! counter (+ counter 1))
|
||||
;; (string->symbol (string-append "g" value))))))
|
||||
(define gensym #f)
|
||||
(let ((counter 0))
|
||||
(set! gensym
|
||||
(define gensym
|
||||
(let ((counter 0))
|
||||
(lambda (. rest)
|
||||
(let ((value (number->string counter)))
|
||||
(set! counter (+ counter 1))
|
||||
|
|
|
|||
17
test.mes
17
test.mes
|
|
@ -22,16 +22,23 @@
|
|||
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
||||
|
||||
;; haha, broken...lat0r
|
||||
(define result #f)
|
||||
(let ((pass 0)
|
||||
(fail 0)
|
||||
(xresult #f))
|
||||
(set! result
|
||||
;; (define result #f)
|
||||
;; (let ((pass 0)
|
||||
;; (fail 0))
|
||||
;; (set! result
|
||||
;; (lambda (. t)
|
||||
;; (cond ((null? t) (list pass fail))
|
||||
;; ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
|
||||
;; (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
|
||||
(define result
|
||||
(let ((pass 0)
|
||||
(fail 0))
|
||||
(lambda (. t)
|
||||
(cond ((null? t) (list pass fail))
|
||||
((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
|
||||
(#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
|
||||
|
||||
|
||||
(define guile? (defined? 'gc))
|
||||
(when guile?
|
||||
(module-define! (current-module) 'builtin? (lambda (. x) #t))
|
||||
|
|
|
|||
Loading…
Reference in a new issue