From 22ba3f6869b8392ab415a621a1505083e66c6f09 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 28 May 2016 16:39:44 +0200 Subject: [PATCH] Add LISP interpreter in C. mes.c: New file. --- mes.c | 645 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 645 insertions(+) create mode 100644 mes.c diff --git a/mes.c b/mes.c new file mode 100644 index 00000000..ec81e232 --- /dev/null +++ b/mes.c @@ -0,0 +1,645 @@ +/* + * 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 . + */ + +// (setq comment-start "//") +// (setq comment-end "") +/* + * The Maxwell Equations of Software -- John McCarthy page 13 + * http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf + */ + +#define _GNU_SOURCE +#include +#include +#include +#include +#include +#include +#include + +#ifndef QUOTE_SUGAR +#define QUOTE_SUGAR 1 +#endif + +enum type {NIL, F, T, ATOM, NUMBER, PAIR, UNSPECIFIED, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, LAMBDA, LABEL}; + +struct scm_t; +typedef struct scm_t* (*function0_t) (void); +typedef struct scm_t* (*function1_t) (struct scm_t*); +typedef struct scm_t* (*function2_t) (struct scm_t*, struct scm_t*); +typedef struct scm_t* (*function3_t) (struct scm_t*, struct scm_t*, struct scm_t*); + +typedef struct scm_t { + enum type type; + union { + char *name; + struct scm_t* car; + }; + union { + int value; + function0_t function0; + function1_t function1; + function2_t function2; + function3_t function3; + struct scm_t* cdr; + }; +} 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, "#"}; + +// PRIMITIVES +scm * +car (scm *x) +{ + assert (x->type == PAIR); + return x->car; +} + +scm * +cdr (scm *x) +{ + assert (x->type == PAIR); + return x->cdr; +} + +scm * +cons (scm *x, scm *y) +{ + scm *p = malloc (sizeof (scm)); + p->type = PAIR; + p->car = x; + p->cdr = y; + return p; +} + +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)) + ? &scm_t : &scm_f; +} + +scm * +null_p (scm *x) +{ + return eq_p (x, &scm_nil); +} + +scm * +pair_p (scm *x) +{ + return x->type == PAIR ? &scm_t : &scm_f; +} + +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 scm_quote; +scm * +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}; + +//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)));} +scm *caddr (scm *x) {return car (cdr (cdr (x)));} +scm *cadar (scm *x) {return car (cdr (car (x)));} + +scm * +list (scm *x, ...) +{ + va_list args; + scm *lst = &scm_nil; + + va_start (args, x); + while (x != &scm_unspecified) + { + lst = cons (x, lst); + x = va_arg (args, scm*); + } + va_end (args); + 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 * +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 + // not Page 12: + if (a == &scm_nil) return &scm_f; + // + if (eq_p (caar (a), x) == &scm_t) + return car (a); + return assoc (x, cdr (a)); +#endif +} + +// Page 13 +scm *apply (scm*, scm*, scm*); + +scm * +eval_quote (scm *fn, scm *x) +{ + return apply (fn, x, &scm_nil); +} + +scm *procedure_p (scm*); +scm *call (scm *, scm*); +scm *display (scm*); + +// .. 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 + printf ("apply fn="); + display (fn); + printf (" x="); + display (x); + puts (""); +#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) + return call (fn, x); + else + return apply (eval (fn, a), x, a); + } + else if (car (fn) == &scm_lambda) + return eval (caddr (fn), pairlis (cadr (fn), x, a)); + else if (car (fn) == &scm_label) + return apply (caddr (fn), x, cons (cons (cadr (fn), + caddr (fn)), + a)); + return &scm_unspecified; +#endif +} + +scm *evcon (scm*, scm*); +scm *evlis (scm*, scm*); + +scm * +eval (scm *e, scm *a) +{ +#if EVAL_COND +#error no eval cond here +#else + // not Page 12 + if (e->type == NUMBER + || e == &scm_t + || e== &scm_f) + return e; + // + else if (atom (e) == &scm_t) + return cdr (assoc (e, a)); + else if (atom (car (e)) == &scm_t) + { + if (car (e) == &scm_quote) + return cadr (e); + else if (car (e) == &scm_cond) + return evcon (cdr (e), 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); + return evcon (cdr (c), a); +} + +scm * +evlis (scm *m, scm *a) +{ + if (m == &scm_nil) + return &scm_nil; + return cons (eval (car (m), a), evlis (cdr (m), a)); +} + +// EXTRAS +scm scm_eval = {FUNCTION2, .function2 = &eval}; +scm scm_apply = {FUNCTION3, .function3 = &apply}; + +scm * +procedure_p (scm *x) +{ + return (x->type == FUNCTION0 + || x->type == FUNCTION1 + || x->type == FUNCTION2 + || x->type == FUNCTION3) + ? &scm_t : &scm_f; +} + +scm * +call (scm *fn, scm *x) +{ + if (fn->type == FUNCTION0) + return fn->function0 (); + else if (fn->type == FUNCTION1) + return fn->function1 (car (x)); + if (fn->type == FUNCTION2) + return fn->function2 (car (x), cadr (x)); + if (fn->type == FUNCTION3) + return fn->function3 (car (x), cadr (x), caddr (x)); + return &scm_unspecified; +} + +scm * +append (scm *x, scm *y) +{ + if (x == &scm_nil) return y; + assert (x->type == PAIR); + return cons (car (x), append (cdr (x), y)); +} + +scm * +make_atom (char const *s) +{ + // TODO: alist lookup symbols + scm *p = malloc (sizeof (scm)); + p->type = ATOM; + p->name = strdup (s); + return p; +} + +scm * +make_number (int x) +{ + scm *p = malloc (sizeof (scm)); + p->type = NUMBER; + p->value = x; + return p; +} + +scm *environment = &scm_nil; + +scm * +lookup (char *x) +{ + 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); + if (r != &scm_f) return cdr (r); + return y; + } + + return &scm_unspecified; +} + +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 *display_helper (scm*, bool, char*); + +scm * +display (scm *x) +{ + return display_helper (x, false, ""); +} + +scm * +display_helper (scm *x, bool cont, char *sep) +{ + 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); + else if (x->type == PAIR) { +#if QUOTE_SUGAR + if (car (x) == &scm_quote) { + printf ("'"); + return display_helper (car (cdr (x)), cont, ""); + } +#endif + if (!cont) printf ("("); + display (car (x)); + if (cdr (x)->type == PAIR) + display_helper (cdr (x), true, " "); + 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); + + return &scm_unspecified; +} + +// READ +int +ungetchar (int c) +{ + return ungetc (c, stdin); +} + +int +peekchar () +{ + int c = getchar (); + ungetchar (c); + return c; +} + +scm* +builtin_getchar () +{ + return make_number (getchar ()); +} +scm scm_getchar = {FUNCTION0, .name="getchar", .function0 = &builtin_getchar}; + +scm* +builtin_peekchar () +{ + return make_number (peekchar ()); +} +scm scm_peekchar = {FUNCTION0, .name="peekchar", .function0 = &builtin_peekchar}; + +scm* +builtin_ungetchar (scm* c) +{ + assert (c->type == NUMBER); + ungetchar (c->value); + return c; +} +scm scm_ungetchar = {FUNCTION1, .name="ungetchar", .function1 = &builtin_ungetchar}; + +int +readcomment (int c) +{ + if (c == '\n') return c; + return readcomment (getchar ()); +} + +int +readblock (int c) +{ + if (c == '!' && peekchar () == '#') return getchar (); + return readblock (getchar ()); +} + +scm *readlis (scm *a); + +scm * +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 == ' ') return readword ('\n', w, a); + if (c == '(' && !w) return readlis (a); + if (c == '(') {ungetchar (c); return lookup (w);} + if (c == ')' && !w) {ungetchar (c); return &scm_nil;} + if (c == ')') {ungetchar (c); return lookup (w);} + if (c == '\'' && !w) {return cons (lookup ("'"), + cons (readword (getchar (), w, a), + &scm_nil));} + if (c == ';') {readcomment (c); return readword ('\n', w, a);} + if (c == '#' && peekchar () == '!') {getchar (); readblock (getchar ()); return readword (getchar (), w, a);} + char s[2]; + s[0] = c; + s[1] = 0; + char buf[256] = ""; + return readword (getchar (), strcat (w ? w : buf, s), a); +} + +scm * +readlis (scm *a) +{ + int c = getchar (); + if (c == ')') return &scm_nil; + scm *w = readword (c, 0, a); + return cons (w, readlis (a)); +} + +scm * +read () +{ + return readword (getchar (), 0, environment); +} +scm scm_read = {FUNCTION0, .function0 = &read}; + +scm * +add_environment (scm *a, char *name, scm* x) +{ + return cons (cons (make_atom (name), x), a); +} + +scm * +less_p (scm *a, scm *b) +{ + assert (a->type == NUMBER); + assert (b->type == NUMBER); + return a->value < b->value ? &scm_t : &scm_f; +} + +scm * +minus (scm *a, scm *b) +{ + assert (a->type == NUMBER); + assert (b->type == NUMBER); + return make_number (a->value - b->value); +} + +scm scm_less_p = {FUNCTION2, .function2 = &less_p}; +scm scm_minus = {FUNCTION2, .function2 = &minus}; + +scm * +fill_environment () +{ + scm *a = &scm_nil; + a = add_environment (a, "<", &scm_less_p); + a = add_environment (a, "-", &scm_minus); + return a; +} + +int +main (int argc, char *argv[]) +{ + environment = fill_environment (); + + scm *program = read (); +#if DEBUG + puts (""); + display (program); + puts ("\n =>"); +#endif + scm *result; + result = eval (program, environment); + display (result); + puts (""); + exit (0); +}