mes.c: store enviroment depth in closures. Fixes c1, c3 and more.
This commit is contained in:
parent
61bbbdffbf
commit
24be64787b
5
TODO
5
TODO
|
@ -3,9 +3,12 @@
|
||||||
** syntax.mes
|
** syntax.mes
|
||||||
** or psyntax.pp
|
** or psyntax.pp
|
||||||
** bugs
|
** bugs
|
||||||
|
*** c2.mes
|
||||||
|
*** c4.mes
|
||||||
*** v c0.mes
|
*** v c0.mes
|
||||||
*** v closure.mes
|
*** v closure.mes
|
||||||
*** c1.mes
|
*** v c1.mes
|
||||||
|
*** v c3.mes
|
||||||
*** v using (let () ...) in macro.mes/syntax.mes
|
*** v using (let () ...) in macro.mes/syntax.mes
|
||||||
*** syntax.mes: closuring name? etc in syntax.mes
|
*** syntax.mes: closuring name? etc in syntax.mes
|
||||||
*** syntax.mes: closuring: indicators: eval: no such symbol: ---
|
*** syntax.mes: closuring: indicators: eval: no such symbol: ---
|
||||||
|
|
35
c1.mes
35
c1.mes
|
@ -1,13 +1,42 @@
|
||||||
|
|
||||||
;; guile: 00
|
;; guile: 10
|
||||||
;; mes: 01
|
;; (0 0)
|
||||||
|
;; mes: 10
|
||||||
|
;; (0 2)
|
||||||
|
|
||||||
(define (x)
|
(define (x)
|
||||||
(define b 1)
|
(define b 1)
|
||||||
(define (y) b)
|
(define (y) b)
|
||||||
|
|
||||||
|
(display b)
|
||||||
(set! b 0)
|
(set! b 0)
|
||||||
|
(display b)
|
||||||
|
(newline)
|
||||||
|
|
||||||
(list b
|
(list b
|
||||||
(let ((b 2))
|
(let ((b 2)) ;; b shadows previous b in mes
|
||||||
|
(y)))) ;; guile: y captures shadowed b, mes: y runs in context new b
|
||||||
|
|
||||||
|
(display (x))
|
||||||
|
(newline)
|
||||||
|
""
|
||||||
|
|
||||||
|
;; guile: 10
|
||||||
|
;; (0 3)
|
||||||
|
;; mes: 10
|
||||||
|
;; (0 3)
|
||||||
|
(define (x)
|
||||||
|
(define b 1)
|
||||||
|
(define (y) b) ;; var b is captured
|
||||||
|
|
||||||
|
(display b)
|
||||||
|
(set! b 0)
|
||||||
|
(display b)
|
||||||
|
(newline)
|
||||||
|
|
||||||
|
(list b
|
||||||
|
(let ((d 4))
|
||||||
|
(set! b 3) ;; value b is changed
|
||||||
(y))))
|
(y))))
|
||||||
|
|
||||||
(display (x))
|
(display (x))
|
||||||
|
|
|
@ -0,0 +1,32 @@
|
||||||
|
;; guile
|
||||||
|
#!
|
||||||
|
;;; compiling /home/janneke/src/mes/c2.mes
|
||||||
|
joepie-complie
|
||||||
|
;;; compiled /home/janneke/.cache/guile/ccache/2.2-LE-8-3.7/home/janneke/src/mes/c2.mes.go
|
||||||
|
joepie
|
||||||
|
jippie
|
||||||
|
!#
|
||||||
|
|
||||||
|
;;mes
|
||||||
|
|
||||||
|
|
||||||
|
(define-macro (bla naam de-lambda)
|
||||||
|
`(define-macro (,naam . rest)
|
||||||
|
(,de-lambda)))
|
||||||
|
|
||||||
|
(bla joepie
|
||||||
|
(let ()
|
||||||
|
(lambda ()
|
||||||
|
(list 'begin
|
||||||
|
(list 'display "joepie")
|
||||||
|
(list 'newline)
|
||||||
|
(and
|
||||||
|
(display "joepie-complie")
|
||||||
|
(newline)
|
||||||
|
"jippie")))))
|
||||||
|
|
||||||
|
(display "compiled")
|
||||||
|
(newline)
|
||||||
|
(display (joepie 'x))
|
||||||
|
(newline)
|
||||||
|
|
|
@ -0,0 +1,13 @@
|
||||||
|
;; guile: 01
|
||||||
|
;; mes: 00
|
||||||
|
(define free 0)
|
||||||
|
|
||||||
|
(define bla #f)
|
||||||
|
(let ()
|
||||||
|
(set! bla (lambda () free))
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(display (bla))
|
||||||
|
(set! free 1)
|
||||||
|
(display (bla))
|
||||||
|
(newline)
|
|
@ -0,0 +1,11 @@
|
||||||
|
;; guile: g0
|
||||||
|
;; mes: crash
|
||||||
|
(define gensym
|
||||||
|
(let ((counter 0))
|
||||||
|
(lambda (. rest)
|
||||||
|
(let ((value (number->string counter)))
|
||||||
|
(set! counter (+ counter 1))
|
||||||
|
(string->symbol (string-append "g" value))))))
|
||||||
|
|
||||||
|
(display (gensym))
|
||||||
|
(newline)
|
22
macro.mes
22
macro.mes
|
@ -11,16 +11,16 @@
|
||||||
;; (display (run 4))
|
;; (display (run 4))
|
||||||
;; (newline)
|
;; (newline)
|
||||||
|
|
||||||
;; (define (fm a)
|
(define (fm a)
|
||||||
;; (define-macro (a b)
|
(define-macro (a b)
|
||||||
;; (display b)
|
(display b)
|
||||||
;; (newline)
|
(newline)
|
||||||
;; "boo"))
|
"boo"))
|
||||||
|
|
||||||
;; (display "f-define-macro: ")
|
(display "f-define-macro: ")
|
||||||
;; (fm 'dinges)
|
(fm 'dinges)
|
||||||
;; (a c)
|
(a c)
|
||||||
;; (newline)
|
(newline)
|
||||||
|
|
||||||
|
|
||||||
;; (define-macro (m a)
|
;; (define-macro (m a)
|
||||||
|
@ -59,9 +59,9 @@
|
||||||
|
|
||||||
(d-s s-r
|
(d-s s-r
|
||||||
(let ()
|
(let ()
|
||||||
(define name? symbol?)
|
;;(define name? symbol?)
|
||||||
(lambda (. n-a)
|
(lambda (. n-a)
|
||||||
|
(define name? symbol?)
|
||||||
(display "YEAH:")
|
(display "YEAH:")
|
||||||
(display n-a)
|
(display n-a)
|
||||||
(display (name? n-a))
|
(display (name? n-a))
|
||||||
|
|
254
mes.c
254
mes.c
|
@ -34,6 +34,7 @@
|
||||||
#include <stdbool.h>
|
#include <stdbool.h>
|
||||||
|
|
||||||
#define DEBUG 0
|
#define DEBUG 0
|
||||||
|
#define XDEBUG 0
|
||||||
|
|
||||||
enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
|
enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR,
|
||||||
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
|
FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn};
|
||||||
|
@ -79,6 +80,7 @@ scm scm_t = {SYMBOL, "#t"};
|
||||||
scm scm_f = {SYMBOL, "#f"};
|
scm scm_f = {SYMBOL, "#f"};
|
||||||
scm scm_unspecified = {SYMBOL, "*unspecified*"};
|
scm scm_unspecified = {SYMBOL, "*unspecified*"};
|
||||||
|
|
||||||
|
scm symbol_closure = {SYMBOL, "*lambda*"};
|
||||||
scm symbol_lambda = {SYMBOL, "lambda"};
|
scm symbol_lambda = {SYMBOL, "lambda"};
|
||||||
scm symbol_begin = {SYMBOL, "begin"};
|
scm symbol_begin = {SYMBOL, "begin"};
|
||||||
scm symbol_list = {SYMBOL, "list"};
|
scm symbol_list = {SYMBOL, "list"};
|
||||||
|
@ -266,21 +268,32 @@ apply_env (scm *fn, scm *x, scm *a)
|
||||||
scm *macro;
|
scm *macro;
|
||||||
if (atom_p (fn) != &scm_f)
|
if (atom_p (fn) != &scm_f)
|
||||||
{
|
{
|
||||||
if (fn == &symbol_current_module) // FIXME
|
if (fn == &symbol_current_module) return a;
|
||||||
return a;
|
|
||||||
if (eq_p (fn, &symbol_call_with_values) == &scm_t)
|
if (eq_p (fn, &symbol_call_with_values) == &scm_t)
|
||||||
return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
|
return call (&scm_call_with_values_env, append2 (x, cons (a, &scm_nil)));
|
||||||
if (builtin_p (fn) == &scm_t)
|
if (builtin_p (fn) == &scm_t)
|
||||||
return call (fn, x);
|
return call (fn, x);
|
||||||
scm *efn = eval (fn, a);
|
scm *efn = eval (fn, a);
|
||||||
if (efn == &scm_unspecified) assert (!"apply unspecified");
|
if (efn->type == NUMBER || efn == &scm_f || efn == &scm_t) assert (!"apply bool");
|
||||||
// FIXME: closure.scm is calling: (3 2 1)
|
|
||||||
if (efn->type == NUMBER) return cons (efn, x);
|
|
||||||
if (efn->type == NUMBER) assert (!"apply number");
|
|
||||||
return apply_env (efn, x, a);
|
return apply_env (efn, x, a);
|
||||||
}
|
}
|
||||||
else if (car (fn) == &symbol_lambda)
|
else if (car (fn) == &symbol_lambda)
|
||||||
return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a));
|
return eval (cons (&symbol_begin, cddr (fn)), pairlis (cadr (fn), x, a));
|
||||||
|
else if (car (fn) == &symbol_closure) {
|
||||||
|
int depth = length (a)->value - cadr (fn)->value - 1;
|
||||||
|
scm *args = caddr (fn);
|
||||||
|
scm *body = cdddr (fn);
|
||||||
|
for (int i=0; i < depth; i++) a = a->cdr;
|
||||||
|
// printf ("closure+pl a=");
|
||||||
|
// display (pairlis (args, x, a));
|
||||||
|
// puts ("");
|
||||||
|
return eval (cons (&symbol_begin, body), pairlis (args, x, a));
|
||||||
|
}
|
||||||
|
else if ((macro = assq (car (fn), cdr (assq (&symbol_macro, a)))) != &scm_f) {
|
||||||
|
scm *r = apply_env (eval (cdr (macro), a), cdr (fn), a);
|
||||||
|
scm *e = eval (r, a);
|
||||||
|
return apply_env (e, x, a);
|
||||||
|
}
|
||||||
return &scm_unspecified;
|
return &scm_unspecified;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -292,6 +305,7 @@ eval (scm *e, scm *a)
|
||||||
display (e);
|
display (e);
|
||||||
puts ("");
|
puts ("");
|
||||||
#endif
|
#endif
|
||||||
|
scm *macro;
|
||||||
if (e->type == SYMBOL) {
|
if (e->type == SYMBOL) {
|
||||||
scm *y = assq (e, a);
|
scm *y = assq (e, a);
|
||||||
if (y == &scm_f) {
|
if (y == &scm_f) {
|
||||||
|
@ -305,7 +319,7 @@ eval (scm *e, scm *a)
|
||||||
return e;
|
return e;
|
||||||
else if (atom_p (car (e)) == &scm_t)
|
else if (atom_p (car (e)) == &scm_t)
|
||||||
{
|
{
|
||||||
scm *macro;
|
//scm *macro;
|
||||||
if (car (e) == &symbol_quote)
|
if (car (e) == &symbol_quote)
|
||||||
return cadr (e);
|
return cadr (e);
|
||||||
if (car (e) == &symbol_begin)
|
if (car (e) == &symbol_begin)
|
||||||
|
@ -315,17 +329,121 @@ eval (scm *e, scm *a)
|
||||||
e = car (body);
|
e = car (body);
|
||||||
body = cdr (body);
|
body = cdr (body);
|
||||||
scm *r = &scm_unspecified;
|
scm *r = &scm_unspecified;
|
||||||
if (e->type == PAIR && eq_p (car (e), &symbol_define) == &scm_t)
|
|
||||||
a = cons (define (e, a), a);
|
// closure defines in one go
|
||||||
else if (e->type == PAIR && eq_p (car (e), &symbol_define_macro) == &scm_t)
|
scm *defines = &scm_nil;
|
||||||
a = cons (define_macro (e, a), a);
|
scm *macros = &scm_nil;
|
||||||
|
while (e->type == PAIR
|
||||||
|
&& (eq_p (car (e), &symbol_define) == &scm_t
|
||||||
|
|| eq_p (car (e), &symbol_define_macro) == &scm_t)) {
|
||||||
|
if (eq_p (car (e), &symbol_define) == &scm_t)
|
||||||
|
defines = append2 (defines, cons (def (e), &scm_nil));
|
||||||
|
else if (eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||||
|
macros = append2 (macros, cons (def (e), &scm_nil));
|
||||||
|
if (body == &scm_nil) e = &scm_unspecified;
|
||||||
|
if (body == &scm_nil) break;
|
||||||
|
e = car (body);
|
||||||
|
body = cdr (body);
|
||||||
|
}
|
||||||
|
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("DEFINES: ");
|
||||||
|
display (defines);
|
||||||
|
puts ("");
|
||||||
|
|
||||||
|
|
||||||
|
printf ("MACROS: ");
|
||||||
|
display (macros);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
|
||||||
|
scm* xmacros = cons (&symbol_macro,
|
||||||
|
append2 (macros, cdr (assq (&symbol_macro, a))));
|
||||||
|
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("MACROS+: ");
|
||||||
|
display (xmacros);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
scm *aa = cons (xmacros, a);
|
||||||
|
aa = append2 (defines, aa);
|
||||||
|
a = aa;
|
||||||
|
while (defines != &scm_nil) {
|
||||||
|
scm *name = caar (defines);
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("name: ");
|
||||||
|
display (name);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
scm *d = cdar (defines);
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("define: ");
|
||||||
|
display (d);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
scm *x = define (d, a);
|
||||||
|
|
||||||
|
#if DEBUG
|
||||||
|
printf ("closure: ");
|
||||||
|
display (x);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
scm *entry = assq (name, a);
|
||||||
|
set_cdr_x (entry, cdr (x));
|
||||||
|
defines = cdr (defines);
|
||||||
|
}
|
||||||
|
|
||||||
|
while (macros != &scm_nil) {
|
||||||
|
scm *name = caar (macros);
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("name: ");
|
||||||
|
display (name);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
scm *d = cdar (macros);
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("macro: ");
|
||||||
|
display (macro);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
//scm *x = define (d, a);
|
||||||
|
scm *x = define (d, a);
|
||||||
|
#if DEBUG
|
||||||
|
printf ("mcclosure: ");
|
||||||
|
display (x);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
scm *entry = assq (name, cdr (assq (&symbol_macro, a)));
|
||||||
|
set_cdr_x (entry, cdr (x));
|
||||||
|
macros = cdr (macros);
|
||||||
|
}
|
||||||
|
|
||||||
|
#if XDEBUG
|
||||||
|
printf ("a: ");
|
||||||
|
display (a);
|
||||||
|
puts ("");
|
||||||
|
|
||||||
|
printf ("E: ");
|
||||||
|
display (e);
|
||||||
|
puts ("");
|
||||||
|
#endif
|
||||||
|
|
||||||
|
// if (e->type == PAIR && eq_p (car (e), &symbol_define) == &scm_t)
|
||||||
|
// a = cons (define (e, a), a);
|
||||||
|
// else if (e->type == PAIR && eq_p (car (e), &symbol_define_macro) == &scm_t)
|
||||||
|
// a = cons (define_macro (e, a), a);
|
||||||
|
//else
|
||||||
|
if (e->type == PAIR && car (e) == &symbol_set_x)
|
||||||
|
r = set_env_x (cadr (e), eval (caddr (e), a), a);
|
||||||
else r = eval (e, a);
|
else r = eval (e, a);
|
||||||
if (body == &scm_nil) return r;
|
if (body == &scm_nil) return r;
|
||||||
return eval (cons (&symbol_begin, body), a);
|
return eval (cons (&symbol_begin, body), a);
|
||||||
}
|
}
|
||||||
if (car (e) == &symbol_lambda) {
|
if (car (e) == &symbol_lambda)
|
||||||
return make_lambda (cadr (e), closure_body (cddr (e), pairlis (cadr (e), cadr (e), a)));
|
//return make_closure (cadr (e), cddr (e), pairlis (cadr (e), cadr (e), a));
|
||||||
}
|
return make_closure (cadr (e), cddr (e), a);
|
||||||
|
if (car (e) == &symbol_closure)
|
||||||
|
return e;
|
||||||
if (car (e) == &symbol_unquote)
|
if (car (e) == &symbol_unquote)
|
||||||
return eval (cadr (e), a);
|
return eval (cadr (e), a);
|
||||||
if (car (e) == &symbol_quasiquote)
|
if (car (e) == &symbol_quasiquote)
|
||||||
|
@ -342,67 +460,6 @@ eval (scm *e, scm *a)
|
||||||
return apply_env (car (e), evlis (cdr (e), a), a);
|
return apply_env (car (e), evlis (cdr (e), a), a);
|
||||||
}
|
}
|
||||||
|
|
||||||
// FIXME: add values to closures. what is this step called, and when
|
|
||||||
// should it be run: read/eval/apply?
|
|
||||||
scm *
|
|
||||||
closure_body (scm *body, scm *a)
|
|
||||||
{
|
|
||||||
if (body == &scm_nil) return &scm_nil;
|
|
||||||
scm *e = car (body);
|
|
||||||
#if DEBUG
|
|
||||||
printf ("\nclosure_body e=");
|
|
||||||
display (e);
|
|
||||||
puts ("");
|
|
||||||
#endif
|
|
||||||
if (e->type == PAIR) {
|
|
||||||
if (eq_p (car (e), &symbol_lambda) == &scm_t) {
|
|
||||||
scm *p = pairlis (cadr (e), cadr (e), a);
|
|
||||||
return cons (make_lambda (cadr (e), cddr (e)), closure_body (cdr (body), p));
|
|
||||||
}
|
|
||||||
|
|
||||||
if (eq_p (car (e), &scm_quote) == &scm_t
|
|
||||||
|| eq_p (car (e), &scm_quasiquote) == &scm_t
|
|
||||||
|| eq_p (car (e), &scm_unquote) == &scm_t
|
|
||||||
|| eq_p (car (e), &scm_unquote_splicing) == &scm_t) {
|
|
||||||
bool have_unquote = assq (&scm_unquote, a) != &scm_f;
|
|
||||||
scm *x = e;
|
|
||||||
if (!have_unquote && eq_p (car (e), &scm_quote) == &scm_t)
|
|
||||||
;
|
|
||||||
else if (!have_unquote && eq_p (car (e), &scm_quasiquote) == &scm_t)
|
|
||||||
a = add_unquoters (a);
|
|
||||||
else
|
|
||||||
x = cons (car (x), closure_body (cdr (x), a));
|
|
||||||
return cons (x, closure_body (cdr (body), a));
|
|
||||||
}
|
|
||||||
if (eq_p (car (e), &symbol_define) == &scm_t
|
|
||||||
|| eq_p (car (e), &symbol_define_macro) == &scm_t
|
|
||||||
|| eq_p (car (e), &symbol_set_x) == &scm_t) {
|
|
||||||
if (cadr (e)->type == PAIR && cadr (e) == &scm_nil) {
|
|
||||||
scm *p = pairlis (cdadr (e), cdadr (e), cons (cons (caar (e), caar (e)), a));
|
|
||||||
return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), p))), cdr (body));
|
|
||||||
}
|
|
||||||
if (eq_p (car (e), &symbol_set_x) == &scm_t)
|
|
||||||
return cons (e, closure_body (cdr (body), a));
|
|
||||||
return cons (e, closure_body (cdr (body), a));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (builtin_p (e) == &scm_t)
|
|
||||||
return cons (e, closure_body (cdr (body), a));
|
|
||||||
else if (atom_p (e) == &scm_t) {
|
|
||||||
if (symbol_p (e) == &scm_t
|
|
||||||
&& macro_p (e, a) != &scm_t)
|
|
||||||
{
|
|
||||||
scm *s = assq (e, a);
|
|
||||||
if (s == &scm_f) fprintf (stderr, "warning: %s possibly undefined symbol\n", e->name);
|
|
||||||
else if (eq_p (s->cdr, &scm_unspecified) == &scm_t)
|
|
||||||
; // FIXME: letrec bindings use *unspecified* ...
|
|
||||||
else e = cdr (s);
|
|
||||||
}
|
|
||||||
return cons (e, closure_body (cdr (body), a));
|
|
||||||
}
|
|
||||||
return cons (closure_body (e, a), closure_body (cdr (body), a));
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
evcon (scm *c, scm *a)
|
evcon (scm *c, scm *a)
|
||||||
{
|
{
|
||||||
|
@ -635,14 +692,6 @@ builtin_list (scm *x/*...*/)
|
||||||
return x;
|
return x;
|
||||||
}
|
}
|
||||||
|
|
||||||
#if 0
|
|
||||||
scm *
|
|
||||||
vector (scm *x/*...*/) // int
|
|
||||||
{
|
|
||||||
return list_to_vector (x);
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
values (scm *x/*...*/)
|
values (scm *x/*...*/)
|
||||||
{
|
{
|
||||||
|
@ -697,6 +746,7 @@ lookup (char *x, scm *a)
|
||||||
|
|
||||||
if (!strcmp (x, symbol_begin.name)) return &symbol_begin;
|
if (!strcmp (x, symbol_begin.name)) return &symbol_begin;
|
||||||
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
|
if (!strcmp (x, symbol_cond.name)) return &symbol_cond;
|
||||||
|
if (!strcmp (x, symbol_closure.name)) return &symbol_closure;
|
||||||
if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda;
|
if (!strcmp (x, symbol_lambda.name)) return &symbol_lambda;
|
||||||
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
|
if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
|
||||||
if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
|
if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
|
||||||
|
@ -803,21 +853,6 @@ vector_to_list (scm *v)
|
||||||
return x;
|
return x;
|
||||||
}
|
}
|
||||||
|
|
||||||
scm *
|
|
||||||
builtin_lookup (scm *l, scm *a)
|
|
||||||
{
|
|
||||||
return lookup (list2str (l), a);
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
|
||||||
cossa (scm *x, scm *a)
|
|
||||||
{
|
|
||||||
if (a == &scm_nil) return &scm_f;
|
|
||||||
if (eq_p (cdar (a), x) == &scm_t)
|
|
||||||
return car (a);
|
|
||||||
return cossa (x, cdr (a));
|
|
||||||
}
|
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
newline ()
|
newline ()
|
||||||
{
|
{
|
||||||
|
@ -870,7 +905,6 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
|
||||||
else if (atom_p (x) == &scm_t) printf ("%s", x->name);
|
else if (atom_p (x) == &scm_t) printf ("%s", x->name);
|
||||||
|
|
||||||
return &scm_unspecified;
|
return &scm_unspecified;
|
||||||
return x; // FIXME: eval helper for macros
|
|
||||||
}
|
}
|
||||||
|
|
||||||
// READ
|
// READ
|
||||||
|
@ -1028,15 +1062,7 @@ readlist (scm *a)
|
||||||
scm *
|
scm *
|
||||||
readenv (scm *a)
|
readenv (scm *a)
|
||||||
{
|
{
|
||||||
#if DEBUG
|
|
||||||
scm *e = readword (getchar (), 0, a);
|
|
||||||
printf ("readenv: ");
|
|
||||||
display (e);
|
|
||||||
puts ("");
|
|
||||||
return e;
|
|
||||||
#else
|
|
||||||
return readword (getchar (), 0, a);
|
return readword (getchar (), 0, a);
|
||||||
#endif
|
|
||||||
}
|
}
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
|
@ -1170,6 +1196,20 @@ make_lambda (scm *args, scm *body)
|
||||||
return cons (&symbol_lambda, cons (args, body));
|
return cons (&symbol_lambda, cons (args, body));
|
||||||
}
|
}
|
||||||
|
|
||||||
|
scm *
|
||||||
|
make_closure (scm *args, scm *body, scm *a)
|
||||||
|
{
|
||||||
|
return cons (&symbol_closure, cons (length (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);
|
||||||
|
}
|
||||||
|
|
||||||
scm *
|
scm *
|
||||||
define (scm *x, scm *a)
|
define (scm *x, scm *a)
|
||||||
{
|
{
|
||||||
|
|
14
mes.test
14
mes.test
|
@ -1,4 +1,5 @@
|
||||||
#! /bin/sh
|
#! /bin/sh
|
||||||
|
set -x
|
||||||
mes=${1-./mes.scm}
|
mes=${1-./mes.scm}
|
||||||
echo 0 | $mes
|
echo 0 | $mes
|
||||||
echo 1 | $mes
|
echo 1 | $mes
|
||||||
|
@ -12,15 +13,14 @@ echo "(cdr '(0 1))" | $mes
|
||||||
echo "(cons 0 1)" | $mes
|
echo "(cons 0 1)" | $mes
|
||||||
#echo "(lambda (x y) (cons x y))" | $mes "(0 1)"
|
#echo "(lambda (x y) (cons x y))" | $mes "(0 1)"
|
||||||
echo "((lambda (x y) (cons x y)) 0 1)" | $mes
|
echo "((lambda (x y) (cons x y)) 0 1)" | $mes
|
||||||
echo "((label fun (lambda (x) x)) 2 2)" | $mes
|
## echo "((label fun (lambda (x) x)) 2 2)" | $mes
|
||||||
echo "(< 0 0)" | $mes
|
echo "(< 0 0)" | $mes
|
||||||
echo "(< 0 1)" | $mes
|
echo "(< 0 1)" | $mes
|
||||||
echo "((label fun\
|
# echo "((label fun\
|
||||||
(lambda (x) (cons x\
|
# (lambda (x) (cons x\
|
||||||
(cond ((< 0 x) (fun (- x 1)))\
|
# (cond ((< 0 x) (fun (- x 1)))\
|
||||||
(#t '())))))\
|
# (#t '())))))\
|
||||||
3)" | $mes
|
# 3)" | $mes
|
||||||
echo "'(0 . 1)" | $mes
|
echo "'(0 . 1)" | $mes
|
||||||
echo "(cdr '(0 . 1))" | $mes
|
echo "(cdr '(0 . 1))" | $mes
|
||||||
todo:oops
|
|
||||||
echo "(define (list . rest) rest)" | $mes
|
echo "(define (list . rest) rest)" | $mes
|
||||||
|
|
115
scm.mes
115
scm.mes
|
@ -23,59 +23,6 @@
|
||||||
|
|
||||||
(define (list . rest) rest)
|
(define (list . rest) rest)
|
||||||
|
|
||||||
(define (equal? a b) ;; FIXME: only 2 arg
|
|
||||||
(cond ((and (null? a) (null? b)) #t)
|
|
||||||
((and (pair? a) (pair? b))
|
|
||||||
(and (equal? (car a) (car b))
|
|
||||||
(equal? (cdr a) (cdr b))))
|
|
||||||
((and (vector? a) (vector? b))
|
|
||||||
(equal? (vector->list a) (vector->list b)))
|
|
||||||
(#t (eq? a b))))
|
|
||||||
|
|
||||||
(define (vector . rest) (list->vector rest))
|
|
||||||
|
|
||||||
(define (apply f args)
|
|
||||||
(eval (cons f args) (current-module)))
|
|
||||||
|
|
||||||
(define (defined? x)
|
|
||||||
(assq x (current-module)))
|
|
||||||
|
|
||||||
(define (procedure? p)
|
|
||||||
(cond ((builtin? p) #t)
|
|
||||||
((pair? p) (eq? (car p) 'lambda))
|
|
||||||
(#t #f)))
|
|
||||||
|
|
||||||
(define assv assq)
|
|
||||||
(define (memq x lst)
|
|
||||||
(cond ((null? lst) #f)
|
|
||||||
((eq? x (car lst)) lst)
|
|
||||||
(#t (memq x (cdr lst)))))
|
|
||||||
(define memv memq)
|
|
||||||
|
|
||||||
(define (member x lst)
|
|
||||||
(cond ((null? lst) #f)
|
|
||||||
((equal? x (car lst)) lst)
|
|
||||||
(#t (member x (cdr lst)))))
|
|
||||||
|
|
||||||
(define-macro (or2 x y)
|
|
||||||
`(cond (,x ,x) (#t ,y)))
|
|
||||||
|
|
||||||
(define-macro (and2 x y)
|
|
||||||
`(cond (,x ,y) (#t #f)))
|
|
||||||
|
|
||||||
(define-macro (or . x)
|
|
||||||
(cond
|
|
||||||
((null? x) #f)
|
|
||||||
((null? (cdr x)) (car x))
|
|
||||||
(#t `(cond (,(car x))
|
|
||||||
(#t (or ,@(cdr x)))))))
|
|
||||||
|
|
||||||
(define-macro (and . x)
|
|
||||||
(cond ((null? x) #t)
|
|
||||||
((null? (cdr x)) (car x))
|
|
||||||
(#t `(cond (,(car x) (and ,@(cdr x)))
|
|
||||||
(#t #f)))))
|
|
||||||
|
|
||||||
(define (split-params bindings params)
|
(define (split-params bindings params)
|
||||||
(cond ((null? bindings) params)
|
(cond ((null? bindings) params)
|
||||||
(#t (split-params (cdr bindings)
|
(#t (split-params (cdr bindings)
|
||||||
|
@ -100,6 +47,25 @@
|
||||||
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest))
|
(let-loop ,bindings-or-label ,(car rest) ,(cdr rest))
|
||||||
(simple-let ,bindings-or-label ,rest)))
|
(simple-let ,bindings-or-label ,rest)))
|
||||||
|
|
||||||
|
(define-macro (or2 x y)
|
||||||
|
`(cond (,x ,x) (#t ,y)))
|
||||||
|
|
||||||
|
(define-macro (and2 x y)
|
||||||
|
`(cond (,x ,y) (#t #f)))
|
||||||
|
|
||||||
|
(define-macro (or . x)
|
||||||
|
(cond
|
||||||
|
((null? x) #f)
|
||||||
|
((null? (cdr x)) (car x))
|
||||||
|
(#t `(cond (,(car x))
|
||||||
|
(#t (or ,@(cdr x)))))))
|
||||||
|
|
||||||
|
(define-macro (and . x)
|
||||||
|
(cond ((null? x) #t)
|
||||||
|
((null? (cdr x)) (car x))
|
||||||
|
(#t `(cond (,(car x) (and ,@(cdr x)))
|
||||||
|
(#t #f)))))
|
||||||
|
|
||||||
(define (expand-let* bindings body)
|
(define (expand-let* bindings body)
|
||||||
(cond ((null? bindings)
|
(cond ((null? bindings)
|
||||||
`((lambda () ,@body)))
|
`((lambda () ,@body)))
|
||||||
|
@ -110,6 +76,41 @@
|
||||||
(define-macro (let* bindings . body)
|
(define-macro (let* bindings . body)
|
||||||
(expand-let* bindings body))
|
(expand-let* bindings body))
|
||||||
|
|
||||||
|
(define (equal? a b) ;; FIXME: only 2 arg
|
||||||
|
(cond ((and (null? a) (null? b)) #t)
|
||||||
|
((and (pair? a) (pair? b))
|
||||||
|
(and (equal? (car a) (car b))
|
||||||
|
(equal? (cdr a) (cdr b))))
|
||||||
|
((and (vector? a) (vector? b))
|
||||||
|
(equal? (vector->list a) (vector->list b)))
|
||||||
|
(#t (eq? a b))))
|
||||||
|
|
||||||
|
(define (vector . rest) (list->vector rest))
|
||||||
|
|
||||||
|
(define (apply f args)
|
||||||
|
(eval (cons f args) (current-module)))
|
||||||
|
|
||||||
|
(define (defined? x)
|
||||||
|
(assq x (current-module)))
|
||||||
|
|
||||||
|
(define (procedure? p)
|
||||||
|
(cond ((builtin? p) #t)
|
||||||
|
((and (pair? p) (eq? (car p) 'lambda)))
|
||||||
|
((and (pair? p) (eq? (car p) '*lambda*)))
|
||||||
|
(#t #f)))
|
||||||
|
|
||||||
|
(define assv assq)
|
||||||
|
(define (memq x lst)
|
||||||
|
(cond ((null? lst) #f)
|
||||||
|
((eq? x (car lst)) lst)
|
||||||
|
(#t (memq x (cdr lst)))))
|
||||||
|
(define memv memq)
|
||||||
|
|
||||||
|
(define (member x lst)
|
||||||
|
(cond ((null? lst) #f)
|
||||||
|
((equal? x (car lst)) lst)
|
||||||
|
(#t (member x (cdr lst)))))
|
||||||
|
|
||||||
(define (map f l . r)
|
(define (map f l . r)
|
||||||
(cond ((null? l) '())
|
(cond ((null? l) '())
|
||||||
((null? r) (cons (f (car l)) (map f (cdr l))))
|
((null? r) (cons (f (car l)) (map f (cdr l))))
|
||||||
|
@ -167,12 +168,10 @@
|
||||||
;; (define gensym
|
;; (define gensym
|
||||||
;; (let ((counter 0))
|
;; (let ((counter 0))
|
||||||
;; (lambda (. rest)
|
;; (lambda (. rest)
|
||||||
;; (let ((val (number->string counter)))
|
;; (let ((value (number->string counter)))
|
||||||
;; (set! counter (+ counter 1))
|
;; (set! counter (+ counter 1))
|
||||||
;; (string->symbol (string-append "g" val))))))
|
;; (string->symbol (string-append "g" value))))))
|
||||||
|
(define *gensym* -1)
|
||||||
(define *gensym* 0)
|
|
||||||
(define (gensym)
|
(define (gensym)
|
||||||
(set! *gensym* (+ *gensym* 1))
|
(set! *gensym* (+ *gensym* 1))
|
||||||
(string->symbol (string-append "g" (number->string *gensym*))))
|
(string->symbol (string-append "g" (number->string *gensym*))))
|
||||||
|
|
||||||
|
|
8
test.mes
8
test.mes
|
@ -191,6 +191,14 @@
|
||||||
|
|
||||||
(pass-if "closure 3" (sequal? (x) '(0 0)))
|
(pass-if "closure 3" (sequal? (x) '(0 0)))
|
||||||
|
|
||||||
|
(pass-if "closure 4 "
|
||||||
|
(seq? (begin
|
||||||
|
(let ((count (let ((counter 0))
|
||||||
|
(lambda ()
|
||||||
|
counter))))
|
||||||
|
(count)))
|
||||||
|
0))
|
||||||
|
|
||||||
(newline)
|
(newline)
|
||||||
(display "passed: ") (display (car (result))) (newline)
|
(display "passed: ") (display (car (result))) (newline)
|
||||||
(display "failed: ") (display (cadr (result))) (newline)
|
(display "failed: ") (display (cadr (result))) (newline)
|
||||||
|
|
Loading…
Reference in New Issue