From 1a565a9208c3a62a2dc232ceb4c5a654da17b97f Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 16 May 2016 00:07:44 +0200 Subject: [PATCH] Leave pure LISP. * GNUmakefile: New file. * mes.c: Lots of work. * mes.mes: New file, split-off from mes.scm. (builtin, number): New function. (apply): Use them. * mes.test: New file. * scm.mes: New file, split-off from mes.scm. --- GNUmakefile | 13 ++ mes.c | 591 +++++++++++++++++++++++++++++++++++----------------- mes.mes | 120 +++++++++++ mes.scm | 201 ++++++++++-------- mes.test | 20 ++ scm.mes | 67 ++++++ 6 files changed, 733 insertions(+), 279 deletions(-) create mode 100644 GNUmakefile create mode 100644 mes.mes mode change 100644 => 100755 mes.scm create mode 100755 mes.test create mode 100755 scm.mes diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 index 00000000..5c17f18e --- /dev/null +++ b/GNUmakefile @@ -0,0 +1,13 @@ +.PHONY: all check default +CFLAGS=-std=c99 -O3 -finline-functions +#CFLAGS=-g + +default: all + +all: mes + +check: all + ./mes.test + ./mes.test ./mes + ./mes < scm.mes + ./mes.scm < scm.mes diff --git a/mes.c b/mes.c index ec81e232..9339d5d7 100644 --- a/mes.c +++ b/mes.c @@ -34,12 +34,13 @@ #include #include +#define DEBUG 0 + #ifndef QUOTE_SUGAR #define QUOTE_SUGAR 1 #endif -enum type {NIL, F, T, ATOM, NUMBER, PAIR, UNSPECIFIED, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, LAMBDA, LABEL}; - +enum type {ATOM, NUMBER, PAIR, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3}; struct scm_t; typedef struct scm_t* (*function0_t) (void); typedef struct scm_t* (*function1_t) (struct scm_t*); @@ -62,14 +63,24 @@ typedef struct scm_t { }; } scm; -scm scm_nil = {NIL, "()"}; -scm scm_t = {T, "#t"}; -scm scm_f = {F, "#f"}; -scm scm_lambda = {LAMBDA, "lambda"}; -scm scm_label = {LABEL, "label"}; -scm scm_unspecified = {UNSPECIFIED, "#"}; +scm scm_nil = {ATOM, "()"}; +scm scm_t = {ATOM, "#t"}; +scm scm_f = {ATOM, "#f"}; +scm scm_lambda = {ATOM, "lambda"}; +scm scm_label = {ATOM, "label"}; +scm scm_unspecified = {ATOM, "*unspecified*"}; +scm scm_define = {ATOM, "define"}; +scm scm_macro = {ATOM, "*macro*"}; // PRIMITIVES + +scm * +atom (scm *x) +{ + return x->type == PAIR ? &scm_f : &scm_t; +} +scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom}; + scm * car (scm *x) { @@ -98,11 +109,14 @@ scm * eq_p (scm *x, scm *y) { return (x == y - // FIXME: alist lookup symbols - || (x->type == ATOM && y->type == ATOM - && !strcmp (x->name, y->name)) || (x->type == NUMBER && y->type == NUMBER - && x->value == y->value)) + && x->value == y->value) + // FIXME: alist lookup symbols + || (atom (x) == &scm_t + && x->type != NUMBER + && y->type != NUMBER + && atom (y) == &scm_t + && !strcmp (x->name, y->name))) ? &scm_t : &scm_f; } @@ -120,21 +134,7 @@ pair_p (scm *x) scm *eval (scm*, scm*); -scm * -cond (scm *x, scm *a) -{ - if (x == &scm_nil) return &scm_unspecified; - assert (x->type == PAIR); - scm *clause = car (x); - assert (clause->type == PAIR); - scm *expr = eval (car (clause), a); - if (expr != &scm_f) { - if (clause->type != PAIR) - return expr; - return eval (car (cdr (clause)), a); - } - return cond (cdr (x), a); -} +scm *display (scm*); scm scm_quote; scm * @@ -143,26 +143,64 @@ quote (scm *x) return cons (&scm_quote, x); } -//PRIMITIVES -scm scm_car = {FUNCTION1, .function1 = &car}; -scm scm_cdr = {FUNCTION1, .function1 = &cdr}; -scm scm_cons = {FUNCTION2, .function2 = &cons}; -scm scm_cond = {FUNCTION2, .function2 = &cond}; -scm scm_eq_p = {FUNCTION2, .function2 = &eq_p}; -scm scm_null_p = {FUNCTION1, .function1 = &null_p}; -scm scm_pair_p = {FUNCTION1, .function1 = &pair_p}; -scm scm_quote = {FUNCTION1, .function1 = "e}; +#if QUASIQUOTE +scm scm_unquote; +scm * +unquote (scm *x) +{ + return cons (&scm_unquote, x); +} -//LIBRARY FUNCTIONS +scm scm_quasiquote; +scm * +quasiquote (scm *x) +{ + return cons (&scm_quasiquote, x); +} + +scm *eval_quasiquote (scm *, scm *); +#endif + +//Primitives +scm scm_car = {FUNCTION1, "car", .function1 = &car}; +scm scm_cdr = {FUNCTION1, "cdr", .function1 = &cdr}; +scm scm_cons = {FUNCTION2, "cons", .function2 = &cons}; +scm scm_cond = {FUNCTION2, "cond"}; //, .function2 = &cond}; +scm scm_eq_p = {FUNCTION2, "eq", .function2 = &eq_p}; +scm scm_null_p = {FUNCTION1, "null", .function1 = &null_p}; +scm scm_pair_p = {FUNCTION1, "pair", .function1 = &pair_p}; +scm scm_quote = {FUNCTION1, "quote", .function1 = "e}; + +#if QUASIQUOTE +scm scm_unquote = {FUNCTION1, "unquote", .function1 = &unquote}; +scm scm_quasiquote = {FUNCTION1, "quasiquote", .function1 = &quasiquote}; +#endif + +//Library functions scm scm_read; -// NEXT -scm *caar (scm *x) {return (car (car (x)));} -scm *cadr (scm *x) {return (car (cdr (x)));} -scm *cdar (scm *x) {return (cdr (car (x)));} +// Derived, non-primitives +scm *caar (scm *x) {return car (car (x));} +scm *cadr (scm *x) {return car (cdr (x));} +scm *cdar (scm *x) {return cdr (car (x));} +scm *cddr (scm *x) {return cdr (cdr (x));} +scm *caadr (scm *x) {return car (car (cdr (x)));} scm *caddr (scm *x) {return car (cdr (cdr (x)));} +scm *cdadr (scm *x) {return cdr (car (cdr (x)));} scm *cadar (scm *x) {return car (cdr (car (x)));} +scm *cddar (scm *x) {return cdr (cdr (car (x)));} +scm *cdddr (scm *x) {return cdr (cdr (cdr (x)));} +scm scm_caar = {FUNCTION1, .name="caar ", .function1 = &caar }; +scm scm_cadr = {FUNCTION1, .name="cadr ", .function1 = &cadr }; +scm scm_cdar = {FUNCTION1, .name="cdar ", .function1 = &cdar }; +scm scm_cddr = {FUNCTION1, .name="cddr ", .function1 = &cddr }; +scm scm_caadr = {FUNCTION1, .name="caadr", .function1 = &caadr}; +scm scm_caddr = {FUNCTION1, .name="caddr", .function1 = &caddr}; +scm scm_cdadr = {FUNCTION1, .name="cdadr", .function1 = &cdadr}; +scm scm_cadar = {FUNCTION1, .name="cadar", .function1 = &cadar}; +scm scm_cddar = {FUNCTION1, .name="cddar", .function1 = &cddar}; +scm scm_cdddr = {FUNCTION1, .name="cdddr", .function1 = &cdddr}; scm * list (scm *x, ...) @@ -180,63 +218,34 @@ list (scm *x, ...) return lst; } -scm * -atom (scm *x) -{ -#if EVAL_COND - return cond - (list (cons (pair_p (x), &scm_f), - cons (null_p (x), &scm_f), - cons (&scm_t, x), - &scm_unspecified), - &scm_nil); -#else - if (pair_p (x) == &scm_t) - return &scm_f; - else if (null_p (x) == &scm_t) - return &scm_f; - return &scm_t; -#endif -} - // Page 12 scm * pairlis (scm *x, scm *y, scm *a) { -#if EVAL_COND - return cond - (list (cons (null_p (x), a), - cons (&scm_t, cons (cons (car (x), car (y)), - pairlis (cdr (x), cdr (y), a))), - &scm_unspecified), - a); -#else if (x == &scm_nil) return a; return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a)); - -#endif } +scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis}; scm * assoc (scm *x, scm *a) { -#if EVAL_COND - return cond - (list (cons (eq_p (caar (a), x), car (a)), - cons (&scm_t, assoc (x, cdr (a))), - &scm_unspecified), - a); -#else + //printf ("assoc: %s\n" , x->name); // not Page 12: - if (a == &scm_nil) return &scm_f; + if (a == &scm_nil) { +#if DEBUG + printf ("alist miss: %s\n", x->name); +#endif + return &scm_f; + } // if (eq_p (caar (a), x) == &scm_t) return car (a); return assoc (x, cdr (a)); -#endif } +scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc}; // Page 13 scm *apply (scm*, scm*, scm*); @@ -247,25 +256,16 @@ eval_quote (scm *fn, scm *x) return apply (fn, x, &scm_nil); } -scm *procedure_p (scm*); +scm *builtin_p (scm*); scm *call (scm *, scm*); scm *display (scm*); +scm *newline (); // .. continued Page 13 scm * apply (scm *fn, scm *x, scm *a) { -#if EVAL_COND - return cond - (list (cons (atom (fn), - cond (list ( - &scm_unspecified), - a)), - cons (eq_p (car (fn), &scm_lambda), - eval (caddr (fn), pairlis (cadr (fn), x, a))), - &scm_unspecified), a); -#else -#if 0 +#if DEBUG printf ("apply fn="); display (fn); printf (" x="); @@ -274,29 +274,25 @@ apply (scm *fn, scm *x, scm *a) #endif if (atom (fn) != &scm_f) { - if (fn == &scm_car) - return caar (x); - else if (fn == &scm_cdr) - return cdar (x); - else if (fn == &scm_cdr) - return cdar (x); - else if (fn == &scm_cons) - return cons (car (x), cadr (x)); - else if (fn == &scm_eq_p) - return eq_p (car (x), cadr (x)); - else if (procedure_p (fn) != &scm_f) + if (builtin_p (fn) == &scm_t) return call (fn, x); - else - return apply (eval (fn, a), x, a); + return apply (eval (fn, a), x, a); } - else if (car (fn) == &scm_lambda) - return eval (caddr (fn), pairlis (cadr (fn), x, a)); + // Page 12: single statement lambda + // else if (car (fn) == &scm_lambda) + // return eval (caddr (fn), pairlis (cadr (fn), x, a)); + // Multi-statement lambda + else if (car (fn) == &scm_lambda) { + scm *body = cddr (fn); + scm *ax = pairlis (cadr (fn), x, a); + scm *result = eval (car (body), ax); + if (cdr (body) == &scm_nil) + return result; + return apply (cons (car (fn), cons (cadr (fn), cdddr (fn))), x, ax); + } else if (car (fn) == &scm_label) - return apply (caddr (fn), x, cons (cons (cadr (fn), - caddr (fn)), - a)); + return apply (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a)); return &scm_unspecified; -#endif } scm *evcon (scm*, scm*); @@ -305,37 +301,98 @@ scm *evlis (scm*, scm*); scm * eval (scm *e, scm *a) { -#if EVAL_COND -#error no eval cond here -#else +#if DEBUG + printf ("eval e="); + display (e); + // printf (" a="); + // display (a); + puts (""); +#endif // not Page 12 - if (e->type == NUMBER - || e == &scm_t - || e== &scm_f) + if (e->type == NUMBER) + return e; + // + else if (atom (e) == &scm_t) { + scm *y = assoc (e, a); + if (y == &scm_f) { + printf ("eval: no such symbol: %s\n", e->name); + exit (1); + } + return cdr (y); + } + // not Page 12 + if (builtin_p (e) == &scm_t) return e; // - else if (atom (e) == &scm_t) - return cdr (assoc (e, a)); else if (atom (car (e)) == &scm_t) { + scm *macro; +#if DEBUG + printf ("e:"); + display (e); + puts (""); + scm *macros = cdr (assoc (&scm_macro, a)); + if (pair_p (macros) == &scm_t) { + printf ("macros:"); + display (macros); + puts (""); + } +#endif if (car (e) == &scm_quote) return cadr (e); +#if QUASIQUOTE + else if (car (e) == &scm_unquote) + return eval (cadr (e), a); + else if (car (e) == &scm_quasiquote) { +#if DEBUG + printf ("cadr e:"); + display (cadr (e)); + puts (""); + printf ("qq:"); + display (eval_quasiquote (cadr (e), a)); + puts (""); +#endif + return eval_quasiquote (cadr (e), a); + } +#endif else if (car (e) == &scm_cond) return evcon (cdr (e), a); + //return cond (cdr (e), a); + else if ((macro = assoc (car (e), cdr (assoc (&scm_macro, a)))) != &scm_f) { +#if DEBUG + printf ("eval macro:"); + display (cdr (macro)); + puts (""); + printf ("macro evlis:"); + display (evlis (cdr (e), a)); + puts (""); +#endif + return eval (apply + (cdr (macro), + evlis (cdr (e), a), + a), + a); + } else return apply (car (e), evlis (cdr (e), a), a); } return apply (car (e), evlis (cdr (e), a), a); -#endif } scm * evcon (scm *c, scm *a) { - if (eval (caar (c), a) != &scm_f) - return eval (cadar (c), a); + // if (eval (caar (c), a) != &scm_f) + // return eval (cadar (c), a); + if (eval (caar (c), a) != &scm_f) { + if (cddar (c) == &scm_nil) + return eval (cadar (c), a); + eval (cadar (c), a); + return evcon (cons (cons (&scm_t, cddar (c)), &scm_nil), a); + } return evcon (cdr (c), a); } +scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon}; scm * evlis (scm *m, scm *a) @@ -344,13 +401,12 @@ evlis (scm *m, scm *a) return &scm_nil; return cons (eval (car (m), a), evlis (cdr (m), a)); } +scm scm_evlis = {FUNCTION2, .name="evlis", .function2 = &evlis}; // EXTRAS -scm scm_eval = {FUNCTION2, .function2 = &eval}; -scm scm_apply = {FUNCTION3, .function3 = &apply}; scm * -procedure_p (scm *x) +builtin_p (scm *x) { return (x->type == FUNCTION0 || x->type == FUNCTION1 @@ -358,6 +414,15 @@ procedure_p (scm *x) || x->type == FUNCTION3) ? &scm_t : &scm_f; } +scm scm_builtin_p = {FUNCTION1, .name="builtin", .function1 = &builtin_p}; + +scm * +number_p (scm *x) +{ + return x->type == NUMBER ? &scm_t : &scm_f; +} +scm scm_number_p = {FUNCTION1, .name="number", .function1 = &number_p}; + scm * call (scm *fn, scm *x) @@ -372,6 +437,7 @@ call (scm *fn, scm *x) return fn->function3 (car (x), cadr (x), caddr (x)); return &scm_unspecified; } +scm scm_call = {FUNCTION1, .name="call", .function2 = &call}; scm * append (scm *x, scm *y) @@ -380,6 +446,8 @@ append (scm *x, scm *y) assert (x->type == PAIR); return cons (car (x), append (cdr (x), y)); } +scm scm_append = {FUNCTION2, .name="append", .function2 = &append}; + scm * make_atom (char const *s) @@ -400,32 +468,27 @@ make_number (int x) return p; } -scm *environment = &scm_nil; - scm * -lookup (char *x) +lookup (char *x, scm *a) { - if (!strcmp (x, " ()")) return &scm_nil; - if (!strcmp (x, "#t")) return &scm_t; - if (!strcmp (x, "#f")) return &scm_f; - if (!strcmp (x, "'")) return &scm_quote; // assert !quote? if (isdigit (*x) || (*x == '-' && isdigit (*(x+1)))) return make_number (atoi (x)); - - // TODO: alist lookup symbols - if (!strcmp (x, "label")) return &scm_label; - if (!strcmp (x, "lambda")) return &scm_lambda; - - if (!strcmp (x, "car")) return &scm_car; - if (!strcmp (x, "cdr")) return &scm_cdr; - if (!strcmp (x, "cons")) return &scm_cons; - if (!strcmp (x, "eq")) return &scm_eq_p; - if (!strcmp (x, "quote")) return &scm_quote; - if (!strcmp (x, "cond")) return &scm_cond; - if (x) { scm *y = make_atom (x); - scm *r = assoc (y, environment); + scm *r = assoc (y, a); +#if 0 + if (!strcmp (x, "eval")) { + printf ("lookup %s ==> ", x); + display (r); + puts (""); + } + + if (!strcmp (x, "apply")) { + printf ("lookup %s ==> ", x); + display (r); + puts (""); + } +#endif if (r != &scm_f) return cdr (r); return y; } @@ -442,59 +505,57 @@ cossa (scm *x, scm *a) return cossa (x, cdr (a)); } -scm *display_helper (scm*, bool, char*); +scm *display_helper (scm*, bool, char*, bool); scm * display (scm *x) { - return display_helper (x, false, ""); + return display_helper (x, false, "", false); } +scm scm_display = {FUNCTION1, .name="display", .function1 = &display}; scm * -display_helper (scm *x, bool cont, char *sep) +newline () +{ + puts (""); + return &scm_unspecified; +} +scm scm_newline = {FUNCTION0, .name="newline", .function0 = &newline}; + +scm * +display_helper (scm *x, bool cont, char *sep, bool quote) { scm *r; printf (sep); - if (x == &scm_nil) printf ("()"); - else if (x == &scm_t) printf ("#t"); - else if (x == &scm_f) printf ("#f"); - else if (x == &scm_unspecified) printf ("#"); - else if (x == &scm_quote) printf ("quote"); - - else if (x == &scm_label) printf ("label"); - else if (x == &scm_lambda) printf ("lambda"); - - else if (x == &scm_car) printf ("car"); - else if (x == &scm_cdr) printf ("cdr"); - else if (x == &scm_cons) printf ("cons"); - else if (x == &scm_cond) printf ("cond"); - else if (x == &scm_eq_p) printf ("eq"); - else if (x == &scm_null_p) printf ("null"); - else if (x == &scm_pair_p) printf ("pair"); - else if (x == &scm_quote) printf ("quote"); - - else if (x->type == NUMBER) printf ("%d", x->value); - else if (x->type == NUMBER) printf ("0"); - else if (x->type == ATOM) printf (x->name); + if (x->type == NUMBER) printf ("%d", x->value); else if (x->type == PAIR) { #if QUOTE_SUGAR if (car (x) == &scm_quote) { printf ("'"); - return display_helper (car (cdr (x)), cont, ""); + return display_helper (car (cdr (x)), cont, "", true); } +#if QUASIQUOTE + if (car (x) == &scm_quasiquote) { + printf ("`"); + return display_helper (car (cdr (x)), cont, "", true); + } + if (car (x) == &scm_unquote) { + printf (","); + return display_helper (car (cdr (x)), cont, "", true); + } +#endif #endif if (!cont) printf ("("); display (car (x)); if (cdr (x)->type == PAIR) - display_helper (cdr (x), true, " "); + display_helper (cdr (x), true, " ", false); else if (cdr (x) != &scm_nil) { printf (" . "); display (cdr (x)); } if (!cont) printf (")"); } - else if ((r = cossa (x, environment)) != &scm_f) - printf (car (r)->name); + else if (atom (x) == &scm_t) printf (x->name); return &scm_unspecified; } @@ -558,13 +619,13 @@ readword (int c, char* w, scm *a) { if (c == EOF && !w) return &scm_nil; if (c == '\n' && !w) return readword (getchar (), w, a); - if (c == EOF || c == '\n') return lookup (w); + if (c == EOF || c == '\n') return lookup (w, a); if (c == ' ') return readword ('\n', w, a); if (c == '(' && !w) return readlis (a); - if (c == '(') {ungetchar (c); return lookup (w);} + if (c == '(') {ungetchar (c); return lookup (w, a);} if (c == ')' && !w) {ungetchar (c); return &scm_nil;} - if (c == ')') {ungetchar (c); return lookup (w);} - if (c == '\'' && !w) {return cons (lookup ("'"), + if (c == ')') {ungetchar (c); return lookup (w, a);} + if (c == '\'' && !w) {return cons (lookup ("'", a), cons (readword (getchar (), w, a), &scm_nil));} if (c == ';') {readcomment (c); return readword ('\n', w, a);} @@ -586,11 +647,11 @@ readlis (scm *a) } scm * -read () +readenv (scm *a) { - return readword (getchar (), 0, environment); + return readword (getchar (), 0, a); } -scm scm_read = {FUNCTION0, .function0 = &read}; +scm scm_readenv = {FUNCTION1, .function1 = &readenv}; scm * add_environment (scm *a, char *name, scm* x) @@ -614,32 +675,178 @@ minus (scm *a, scm *b) return make_number (a->value - b->value); } -scm scm_less_p = {FUNCTION2, .function2 = &less_p}; -scm scm_minus = {FUNCTION2, .function2 = &minus}; +scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p}; +scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus}; + +scm *global_environment; scm * -fill_environment () +apply_environment (scm *fn, scm *x, scm *a) { + return apply (fn, x, append (a, global_environment)); +} + +scm * +eval_environment (scm *e, scm *a) +{ + return eval (e, append (a, global_environment)); +} + +//scm scm_cond = {FUNCTION2, .name="cond", .function2 = &evcon}; +scm scm_eval = {FUNCTION2, .name="eval", .function2 = &eval_environment}; +scm scm_apply = {FUNCTION3, .name="apply", .function3 = &apply_environment}; + +scm * +initial_environment () +{ + scm_cond.function2 = &evcon; + scm *a = &scm_nil; + + a = add_environment (a, "()", &scm_nil); + a = add_environment (a, "#t", &scm_t); + a = add_environment (a, "#f", &scm_f); + a = add_environment (a, "*unspecified*", &scm_unspecified); + + a = add_environment (a, "label", &scm_label); + a = add_environment (a, "lambda", &scm_lambda); + + a = add_environment (a, "atom", &scm_atom); + a = add_environment (a, "car", &scm_car); + a = add_environment (a, "cdr", &scm_cdr); + a = add_environment (a, "cons", &scm_cons); + a = add_environment (a, "cond", &scm_cond); + a = add_environment (a, "eq", &scm_eq_p); + + a = add_environment (a, "null", &scm_null_p); + a = add_environment (a, "pair", &scm_pair_p); + a = add_environment (a, "quote", &scm_quote); + a = add_environment (a, "'", &scm_quote); + +#if QUASIQUOTE + a = add_environment (a, "quasiquote", &scm_quasiquote); + a = add_environment (a, "unquote", &scm_unquote); + a = add_environment (a, ",", &scm_unquote); + a = add_environment (a, "`", &scm_quasiquote); +#endif + + a = add_environment (a, "evlis", &scm_evlis); + a = add_environment (a, "evcon", &scm_evcon); + a = add_environment (a, "pairlis", &scm_pairlis); + a = add_environment (a, "assoc", &scm_assoc); + + a = add_environment (a, "eval", &scm_eval); + a = add_environment (a, "apply", &scm_apply); + + a = add_environment (a, "readenv", &scm_readenv); + a = add_environment (a, "display", &scm_display); + a = add_environment (a, "newline", &scm_newline); + + a = add_environment (a, "builtin", &scm_builtin_p); + a = add_environment (a, "number", &scm_number_p); + a = add_environment (a, "call", &scm_call); + + a = add_environment (a, "define", &scm_define); + a = add_environment (a, "<", &scm_less_p); a = add_environment (a, "-", &scm_minus); + + // DERIVED + a = add_environment (a, "caar", &scm_caar); + a = add_environment (a, "cadr", &scm_cadr); + a = add_environment (a, "cdar", &scm_cdar); + a = add_environment (a, "cddr", &scm_cddr); + a = add_environment (a, "caadr", &scm_caadr); + a = add_environment (a, "caddr", &scm_caddr); + a = add_environment (a, "cdadr", &scm_cdadr); + a = add_environment (a, "cadar", &scm_cadar); + a = add_environment (a, "cddar", &scm_cddar); + a = add_environment (a, "cdddr", &scm_cdddr); + + a = add_environment (a, "append", &scm_append); + + a = add_environment (a, "*macro*", &scm_nil); + + // Hmm + //a = add_environment (a, "*a*", &scm_nil); + global_environment = add_environment (a, "*a*", a); return a; } +#if QUASIQUOTE +scm * +eval_quasiquote (scm *e, scm *a) +{ + if (e == &scm_nil) return e; + else if (atom (e) == &scm_t) return e; + else if (car (e) == &scm_unquote) + return eval (cadr (e), a); + else if (car (e) == &scm_quote) + return cadr (e); + else if (car (e) == &scm_quasiquote) + return cadr (e); + return cons (car (e), eval_quasiquote (cdr (e), a)); +} +#endif + +scm * +define_lambda (scm *x, scm *a) +{ + return cons (caadr (x), cons (&scm_lambda, cons (cdadr (x), cddr (x)))); +} + +scm * +define (scm *x, scm *a) +{ + if (atom (cadr (x)) != &scm_f) + return cons (cadr (x), eval (caddr (x), a)); + return define_lambda (x, a); +} + +scm * +define_macro (scm *x, scm *a) +{ + return cons (&scm_macro, + cons (define_lambda (x, a), + cdr (assoc (&scm_macro, a)))); +} + +scm * +loop (scm *r, scm *e, scm *a) +{ + //global_environment = add_environment (a, "*a*", a); + if (e == &scm_nil) return r; //a; + else if (eq_p (e, make_atom ("exit")) == &scm_t) + return apply (cdr (assoc (make_atom ("loop"), a)), + cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a); + else if (atom (e) == &scm_t) + return loop (eval (e, a), readenv (a), a); + else if (eq_p (car (e), make_atom ("define")) == &scm_t) + return loop (&scm_unspecified, + readenv (a), + cons (define (e, a), a)); + else if (eq_p (car (e), make_atom ("define-macro")) == &scm_t) + return loop (&scm_unspecified, + readenv (a), + cons (define_macro (e, a), a)); + return loop (eval (e, a), readenv (a), a); +} + int main (int argc, char *argv[]) { - environment = fill_environment (); - - scm *program = read (); + scm *a = initial_environment (); + //global_environment = a; + scm *x = readenv (a); #if DEBUG + printf ("program="); + display (x); puts (""); - display (program); - puts ("\n =>"); #endif - scm *result; - result = eval (program, environment); - display (result); - puts (""); - exit (0); + //display (eval (x, a)); + display (loop (&scm_unspecified, x, a)); + // loop (&scm_unspecified, x, a); + //loop (&scm_unspecified, read (), initial_environment ()); + newline (); + return 0; } diff --git a/mes.mes b/mes.mes new file mode 100644 index 00000000..264dfc51 --- /dev/null +++ b/mes.mes @@ -0,0 +1,120 @@ +;; -*-scheme-*- +;; +(define (caar x) (car (car x))) +(define (cadr x) (car (cdr x))) +(define (cdar x) (cdr (car x))) +(define (cddr x) (cdr (cdr x))) +(define (caadr x) (car (car (cdr x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) + +;; Page 12 +(define (pairlis x y a) + (debug "pairlis x=~a y=~a a=~a\n" x y a) + (cond + ((null x) a) + (#t (cons (cons (car x) (car y)) + (pairlis (cdr x) (cdr y) a))))) + +(define (assoc x a) + ;;(stderr "assoc x=~a\n" x) + (debug "assoc x=~a a=~a\n" x a) + (cond + ((null a) #f) + ((eq (caar a) x) (car a)) + (#t (assoc x (cdr a))))) + +;; Page 13 +(define (eval-quote fn x) + (debug "eval-quote fn=~a x=~a" fn x) + (apply fn x '())) + +(define (apply fn x a) + (debug "apply fn=~a x=~a a=~a\n" fn x a) + (cond + ((atom fn) + (debug "(atom fn)=~a\n" (atom fn)) + (cond + ;; John McCarthy LISP 1.5 + ;; ((eq fn CAR) (caar x)) + ;; ((eq fn CDR) (cdar x)) + ;; ((eq fn CONS) (cons (car x) (cadr x))) + ;; ((eq fn ATOM) (atom (car x))) + ;; ((eq fn EQ) (eq (car x) (cadr x))) + ((builtin fn) (call fn x)) + (#t (apply (eval fn a) x a)))) + ;; John McCarthy LISP 1.5 + ((eq (car fn) 'single-line-LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a))) + ((eq (car fn) 'lambda) + ;; (CDDR fn) all eval + (cond ((null (cdr (cddr fn))) + (eval (caddr fn) (pairlis (cadr fn) x a))) + (#t + (eval (caddr fn) (pairlis (cadr fn) x a)) + (apply (cons (car fn) (cons (cadr fn) (cdddr fn))) + x + (pairlis (cadr fn) x a))))) + ((eq (car fn) 'label) (apply (caddr fn) x (cons (cons (cadr fn) + (caddr fn)) a))))) + +(define (eval e a) + (debug "eval e=~a a=~a\n" e a) + ;;(debug "eval (atom ~a)=~a\n" e (atom e)) + (cond + ;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f)) + ((number e) e) + ;; error: extra + ((atom e) (cond ((eq (assoc e a) #f) + (stderr "no such symbol: ~a\n" e) + (guile:exit 1)) + (#t (cdr (assoc e a))))) + ((atom e) (cdr (assoc e a))) + ((builtin e) e) + ;;((and (stderr "eeee: ~a\n" e) #f)) + ((atom (car e)) + (cond + ((eq (car e) 'quote) (cadr e)) + ((eq (car e) 'cond) (evcon (cdr e) a)) + ;; EXTRA: macro expandszor + ;;((and (stderr "2eeee: ~a\n" (cdr (assoc '*macro* a))) #f)) + (;;;(pair (assoc (car e) (cdr (assoc '*macro* a)))) + #f + ;;(stderr "macro: ~a\n" (assoc (car e) (cdr (assoc '*macro* a)))) + (stderr "apply: ~a ~a\n" + `(cons 'lambda (cdr (cdr + ,(assoc (car e) (cdr (assoc '*macro* a))) + ))) + `(evlis ,(cddr e) a) + ;;'(evlist foobar) + ) + (eval (apply + `(cons 'lambda (cdr (cdr + ,(assoc (car e) (cdr (assoc '*macro* a))) + ))) + `(evlis ,(cddr e) a) + a) + a)) + (#t (apply (car e) (evlis (cdr e) a) a)))) + (#t (apply (car e) (evlis (cdr e) a) a)))) + +(define (evcon c a) + (debug "evcon c=~a a=~a\n" c a) + (cond + ;; single-statement cond + ;; ((eval (caar c) a) (eval (cadar c) a)) + ((eval (caar c) a) + (cond ((null (cddar c)) (eval (cadar c) a)) + (#t (eval (cadar c) a) + (evcon + (cons (cons #t (cddar c)) '()) + a)))) + (#t (evcon (cdr c) a)))) + +(define (evlis m a) + (debug "evlis m=~a a=~a\n" m a) + (cond + ((null m) '()) + (#t (cons (eval (car m) a) (evlis (cdr m) a))))) diff --git a/mes.scm b/mes.scm old mode 100644 new mode 100755 index c331111e..327b4d90 --- a/mes.scm +++ b/mes.scm @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -exec guile -L $(pwd) -e '(scm)' -s "$0" "$@" +exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" !# ;;; Mes --- The Maxwell Equations of Software @@ -24,7 +24,7 @@ exec guile -L $(pwd) -e '(scm)' -s "$0" "$@" ;; The Maxwell Equations of Software -- John McCarthy page 13 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf -(define-module (scm) +(define-module (mes) #:export (main)) (set-current-module @@ -34,12 +34,16 @@ exec guile -L $(pwd) -e '(scm)' -s "$0" "$@" ;; Debugging apply cons* - current-output-port current-error-port + current-output-port display + eof-object? + exit force-output format newline + read + with-input-from-string ;; Guile admin module-define! @@ -52,6 +56,13 @@ exec guile -L $(pwd) -e '(scm)' -s "$0" "$@" eq? null? pair? + + ;; ADDITIONAL PRIMITIVES + apply + number? + procedure? + < + - ) #:renamer (symbol-prefix-proc 'guile:))))) @@ -82,101 +93,117 @@ exec guile -L $(pwd) -e '(scm)' -s "$0" "$@" (define cons guile:cons) (define eq guile:eq?) (define null guile:null?) +(define pair guile:pair?) +(define builtin guile:procedure?) +(define number guile:number?) +(define call guile:apply) +(include "mes.mes") -(define ATOM 'atom) -(define CAR 'car) -(define CDR 'cdr) -(define COND 'cond) -(define CONS 'cons) -(define EQ 'eq) -(define LABEL 'label) -(define LAMBDA 'lambda) -(define NIL '()) -(define QUOTE 'quote) +(define (append x y) + (cond ((null x) y) + (#t (cons (car x) (append (cdr x) y))))) -(define (caar x) (guile:car (guile:car x))) -(define (cadr x) (guile:car (guile:cdr x))) -(define (cdar x) (guile:car (guile:cdr (guile:car x)))) -(define (caddr x) (guile:car (guile:cdr (guile:cdr x)))) -(define (cadar x) (guile:car (guile:cdr (guile:car x)))) +(define (eval-environment e a) + (eval e (append a environment))) -;; Page 12 -(define (pairlis x y a) - (debug "pairlis x=~a y=~a a=~a\n" x y a) - (cond - ((null x) a) - (#t (cons (cons (car x) (car y)) - (pairlis (cdr x) (cdr y) a))))) +(define (apply-environment fn e a) + (apply fn e (append a environment))) -(define (assoc x a) - (debug "assoc x=~a a=~a\n" x a) - (cond - ((eq (caar a) x) (car a)) - (#t (assoc x (cdr a))))) +(define (readenv a) + (let ((x (guile:read))) + (if (guile:eof-object? x) '() + x))) -;; Page 13 -(define (eval-quote fn x) - (debug "eval-quote fn=~a x=~a" fn x) - (apply fn x NIL)) +(define environment + `( + (() . ()) + (#t . #t) + (#f . #f) + + (*unspecified* . ,*unspecified*) -(define (apply fn x a) - (debug "apply fn=~a x=~a a=~a\n" fn x a) - (cond - ((atom fn) - (debug "(atom fn)=~a\n" (atom fn)) - (cond - ((eq fn CAR) (caar x)) - ((eq fn CDR) (cdar x)) - ((eq fn CONS) (cons (car x) (cadr x))) - ((eq fn ATOM) (atom (car x))) - ((eq fn EQ) (eq (car x) (cadr x))) - (#t (apply (eval fn a) x a)))) - ((eq (car fn) LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a))) - ((eq (car fn) LABEL) (apply (caddr fn) x (cons (cons (cadr fn) - (caddr fn)) a))))) + (atom . ,atom) + (car . ,car) + (cdr . ,cdr) + (cons . ,cons) + (cond . ,evcon) + (eq . ,eq) -(define (eval e a) - (debug "eval e=~a a=~a\n" e a) - (debug "eval (atom ~a)=~a\n" e (atom e)) - (cond - ((atom e) (cdr (assoc e a))) - ((atom (car e)) - (cond - ((eq (car e) QUOTE) (cadr e)) - ((eq (car e) COND) (evcon (cdr e) a)) - (#t (apply (car e) (evlis (cdr e) a) a)))) - (#t (apply (car e) (evlis (cdr e) a) a)))) + (null . ,null) + (pair . ,guile:pair?) + ;;(quote . ,quote) -(define (evcon c a) - (debug "evcon c=~a a=~a\n" c a) - (cond - ((eval (caar c) a) (eval (cadar c) a)) - (#t (evcon (cdr c) a)))) + (evlis . ,evlis) + (evcon . ,evcon) + (pairlis . ,pairlis) + (assoc . ,assoc) -(define (evlis m a) - (debug "evlis m=~a a=~a\n" m a) - (cond - ((null m) NIL) - (#t (cons (eval (car m) a) (evlis (cdr m) a))))) + (eval . ,eval-environment) + (apply . ,apply-environment) + + (readenv . ,readenv) + (display . ,guile:display) + (newline . ,guile:newline) + + (builtin . ,builtin) + (number . ,number) + (call . ,call) + + (< . ,guile:<) + (- . ,guile:-) + + ;; DERIVED + (caar . ,caar) + (cadr . ,cadr) + (cdar . ,cdar) + (cddr . ,cddr) + (caadr . ,caadr) + (caddr . ,caddr) + (cdadr . ,cdadr) + (cadar . ,cadar) + (cddar . ,cddar) + (cdddr . ,cdddr) + + (append . ,append) + (exit . ,guile:exit) + + (*macro* . ()) + + ;; + (stderr . ,stderr))) + +(define (mes-define-lambda x a) + (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x))))) + +(define (mes-define x a) + (if (atom (cadr x)) + (cons (cadr x) (eval (caddr x) a)) + (mes-define-lambda x a))) + +(define (mes-define-macro x a) + (cons '*macro* + (cons (mes-define-lambda x a) + (cdr (assoc '*macro* a))))) + +(define (loop r e a) + (cond ((null e) r) + ((eq e 'exit) + (apply (cdr (assoc 'loop a)) + (cons *unspecified* (cons #t (cons a '()))) + a)) + ((atom e) (loop (eval e a) (readenv a) a)) + ((eq (car e) 'define) + (loop *unspecified* (readenv a) (cons (mes-define e a) a))) + ((eq (car e) 'define-macro) + (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a))) + (#t (loop (eval e a) (readenv a) a)))) (define (main arguments) - (stdout "Hello scm\n") - (guile:display (eval 0 '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (eval 1 '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (eval '(car '(0 1)) '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (eval '(cdr '(0 1)) '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (apply 'cons '(0 1) '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (eval '(cons 0 1) '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (apply '(lambda (x y) (cons x y)) '(0 1) '((0 . 0) (1 . 1)))) - (guile:newline) - (guile:display (eval '((label fun (lambda (x) x)) 2 2) '((2 . 2)))) + (let ((a (append environment `((*a* . ,environment))))) + ;;(guile:display (eval (readenv a) a)) + (guile:display (loop *unspecified* (readenv a) a)) + ) (guile:newline)) -(guile:module-define! (guile:resolve-interface '(scm)) 'main main) +(guile:module-define! (guile:resolve-interface '(mes)) 'main main) diff --git a/mes.test b/mes.test new file mode 100755 index 00000000..c7abf61f --- /dev/null +++ b/mes.test @@ -0,0 +1,20 @@ +#! /bin/sh +mes=${1-./mes.scm} +echo 0 | $mes +echo 1 | $mes +#echo car | $mes "((0 1))" +echo "(car '(0 1))" | $mes +#echo cdr | $mes "((0 1))" +echo "(cdr '(0 1))" | $mes +#echo cons | $mes "(0 1)" +echo "(cons 0 1)" | $mes +#echo "(lambda (x y) (cons x y))" | $mes "(0 1)" +echo "((lambda (x y) (cons x y)) 0 1)" | $mes +echo "((label fun (lambda (x) x)) 2 2)" | $mes +echo "(< 0 0)" | $mes +echo "(< 0 1)" | $mes +echo "((label fun\ + (lambda (x) (cons x\ + (cond ((< 0 x) (fun (- x 1)))\ + (#t '())))))\ + 3)" | $mes diff --git a/scm.mes b/scm.mes new file mode 100755 index 00000000..2b7b2038 --- /dev/null +++ b/scm.mes @@ -0,0 +1,67 @@ +#! /bin/sh +# -*-scheme-*- +exec ./mes "$@" < "$0" +!# + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; Mes is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Mes is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mes. If not, see . + +;; The Maxwell Equations of Software -- John McCarthy page 13 +;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf + +(display 'boo) +(newline) + +;; (display '*a*:) +;; (display (eval '*a* '())) +;; (newline) + +(define (+ x y) (- x (- 0 y))) + +(display (+ 3 4)) +(newline) + +(define-macro (and x y) + (cond (x y) + (#t #f))) + +(define-macro (or x y) + (cond (x x) + (#t y))) + +(define (split-params bindings params) + (cond ((null bindings) params) + (#t (split-params (cdr bindings) + (append params (cons (caar bindings) '())))))) + +(define (split-values bindings values) + (cond ((null bindings) values) + (#t (split-values (cdr bindings) + (append values (cdar bindings) '()))))) + +;; (define-macro (let bindings body) +;; (cons (cons 'lambda (cons (split-params bindings '()) body)) +;; (split-values bindings '()))) + +(display 'and-0-1:) +(display (and 0 1)) +(newline) + +(display 'or-#f-1:) +(display (or #f 2)) +(newline)