From bd5a163654da81cc51d39321faa7e8fe068b2f53 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sun, 29 May 2016 13:44:03 +0200 Subject: [PATCH] boot.mes: boostrap into mes. --- GNUmakefile | 8 +- boot.mes | 369 +++++++++++++++++++++++++++++++++++++++++ mes.c | 462 ++++++++++++++++++++++++---------------------------- mes.test | 2 + 4 files changed, 592 insertions(+), 249 deletions(-) create mode 100644 boot.mes diff --git a/GNUmakefile b/GNUmakefile index 5c17f18e..8f4c8d40 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -9,5 +9,9 @@ all: mes check: all ./mes.test ./mes.test ./mes - ./mes < scm.mes - ./mes.scm < scm.mes + ./mes < boot.mes +# ./mes < scm.mes +# ./mes.scm < scm.mes + +boot: all + ./mes < boot.mes diff --git a/boot.mes b/boot.mes new file mode 100644 index 00000000..d5b65415 --- /dev/null +++ b/boot.mes @@ -0,0 +1,369 @@ +#! /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 programming -- John McCarthy page 13 +;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf + +;; ((label loop +;; (lambda (r e a) +;; (cond ((null e) a) +;; ((eq e 'exit) +;; (display 'loop:exiting) +;; (newline) +;; (apply 'loop2 (cons #t (cons #t (cons a '()))) a)) +;; ((atom e) (loop (eval e a) (readenv a) a)) +;; ((eq (car e) 'define) +;; (loop *unspecified* +;; (readenv a) +;; (cons +;; (cond ((atom (cadr e)) +;; (cons (cadr e) (eval (caddr e) a))) +;; (#t +;; (newline) +;; (cons (caadr e) +;; (cons 'lambda +;; (cons (cdadr e) (cddr e)))))) +;; a))) +;; (#t (loop (eval e a) (readenv a) a))))) +;; *unspecified* (readenv '()) '((*macro*))) + +(display 'loop-reading...) +(newline) + +;; loop adds definitions of mes.mes to current-environment +;;mes.mes + +;; ;; -*-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 (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))))) + + +(define (apply fn x a) + ;; (display 'mes-apply:) + ;; (newline) + ;; (display 'fn:) + ;; (display fn) + ;; (newline) + ;; (display 'builtin:) + ;; (display (builtin fn)) + ;; (newline) + ;; (display 'x:) + ;; (display x) + ;; (newline) + ;;(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)) + ;; (display 'mes-eval:) + ;; (display e) + ;; (newline) + ;; (display 'a:) + ;; (display a) + ;; (newline) + ;;(display 'pair?*macro*:) + ;;(display (assoc '*macro* a)) + ;; (display (cdr (assoc '*macro* a))) + ;; (newline) + (cond + ;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f)) + ((number e) e) + ((eq e #t) #t) + ((eq e #f) #f) + ((atom e) (cdr (assoc e a))) + ((builtin e) e) + ((atom (car e)) + (cond + ((eq (car e) 'quote) (cadr e)) + ((eq (car e) 'cond) (evcon (cdr e) a)) + ;; no macro support: + (#t (apply (car e) (evlis (cdr e) a) a)) + ;; ^^^^^^^^^^^^^^^^^ + (#t + (cond + ;; (#t + ;; (display 'could-be-macro:) + ;; (display e) + ;; (newline) + ;; (display 'null:) + ;; (display (null (cdr (assoc '*macro* a)))) + ;; (newline) + ;; #f) + ;;(#t (apply (car e) (evlis (cdr e) a) a)) + ((eq (assoc '*macro* a) #f) + ;;(null (cdr (assoc '*macro* a))) + + ;; (display 'we-have-no-macros:) + ;; (display e) + ;; (newline) + + (apply (car e) (evlis (cdr e) a) a) + ) + ((pair (assoc (car e) (cdr (assoc '*macro* a)))) + ;; (display 'expanz0r:) + ;; (display (assoc (car e) (cdr (assoc '*macro* a)))) + ;; (newline) + ;; (display 'running:) + ;; (display (cdr (assoc (car e) (cdr (assoc '*macro* a))))) + ;; (newline) + ;; (display 'args:) + ;; (display (cdr e)) + ;; (newline) + ;; (display '==>args:) + ;; (display (evlis (cdr e) a)) + ;; (newline) + (eval (apply + (cdr (assoc (car e) (cdr (assoc '*macro* a)))) + (evlis (cdr e) a) + a) + a)) + (#t (apply (car e) (evlis (cdr e) a) a)))) + (#t (apply (car e) (evlis (cdr e) a) a)))) + (#t (apply (car e) (evlis (cdr e) a) a)))) + +(define (readenv a) + (readword (getchar) '() a)) + +(define (readword c w a) + ;; (display 'readword:) + ;; (display c) + ;; (newline) + (cond ((eq c -1) ;; eof + (cond ((eq w '()) '()) + (#t (lookup w a)))) + ((eq c 10) ;; \n + (cond ((eq w '()) (readword (getchar) w a)) + (#t (lookup w a)))) + ((eq c 32) ;; \space + (readword 10 w a)) + ((eq c 40) ;; ( + (cond ((eq w '()) (readlis a)) + (#t (ungetchar c) (lookup w a)))) + ((eq c 41) ;; ) + (cond ((eq w '()) (ungetchar c) w) + (#t (ungetchar c) (lookup w a)))) + ((eq c 39) ;; ' + (cond ((eq w '()) + (cons (lookup (cons c '()) a) + (cons (readword (getchar) w a) '()))) + (#t (ungetchar c) (lookup w a)))) + ((eq c 59) ;; ; + (readcomment 59) + (readword 10 w a)) + (#t (readword (getchar) (append w (cons c '())) a)))) + +(define (readlis a) + ;; (display 'readlis:) + ;; (newline) + (cond ((eq (peekchar) 41) ;; ) + (getchar) + '()) + (#t (xcons (readlis a) (readword (getchar) '() a))))) + +(define (xcons a b) + (cons b a)) + +(define (readcomment c) + (cond ((eq c 10) ;; \n + c) + (#t (readcomment (getchar))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; we also add helpers to make loop2 simpler +(define (scm-define x a) + (cond ((atom (cadr x)) (cons (cadr x) (eval (caddr x) a))) + (#t (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x))))))) + +(define (scm-define-macro x a) + (cons '*macro* + (cons (cons (caadr e) (cons 'lambda (cons (cdadr e) (cddr e)))) + (cdr (assoc '*macro* a))))) + +(define (scm-display x) + (display x)) + +(define (loop2 r e a) + (display '____loop2) + (newline) + (display 'e:) + (display e) + ;; (newline) + (cond ((null e) r) + ((eq e 'EOF2) + (display 'loop2-exiting...) + (newline)) + ((eq (assoc '*macro* a) #f) + (loop2 r (readenv a) (cons (cons '*macro* '()) a))) + ((atom e) + ;; (display 'loop2:atom) + ;; (newline) + ;; (display 'skipping-one-read-scm:) + ;; (display (readenv a)) + ;; (newline) + (loop2 (eval e a) (readenv a) a) + ) + ((eq (car e) 'define) + (loop2 *unspecified* (readenv a) (cons (scm-define e a) a))) + ((eq (car e) 'define-macro) + (loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a))) + + (#t (loop2 (eval e a) (readenv a) a)) + ;;(#t (loop2 ((cdr (assoc 'eval a)) e a) (readenv a) a)) + )) + +;;(display 'loop:read-loop2-exiting...) +;;(newline) +;;;EOF + +;; loop2 skips one read: +'this-is-skipped-scm + +(display 123) +4 +(newline) + +(display 'hello-display-symbol) +(newline) + +(display '(0 1 2)) +(newline) + +(display (- 12 3)) +(newline) + +(define (+ x y) (- x (- 0 y))) +(display (+ 3 4)) + +(newline) + +;; (define-macro (and x y) +;; (cond (x +;; (display 'true-inside-and:) +;; (display x) +;; (newline) +;; y) +;; (#t +;; (display 'false-inside-and:) +;; (display x) +;; #f))) + +;; (define-macro (and x y) +;; (cond (x y) +;; (#t #f))) + +;; (define-macro (or x y) +;; (cond (x x) +;; (#t y))) + +;; (display 'and-0-1:) +;; ;; ;;(display (and 0 1)) +;; (and 0 1) +;; (and 0 2) +;; (and #f 3) +;; (newline) +;; (display 'xscm-display) +;; (newline) +;; ;; ;;(eval '(display (and 0 1)) '((*macro*))) +;; (display (and 0 1)) + +'() +EOF2 +EOF + diff --git a/mes.c b/mes.c index 9339d5d7..5921635a 100644 --- a/mes.c +++ b/mes.c @@ -57,7 +57,7 @@ typedef struct scm_t { int value; function0_t function0; function1_t function1; - function2_t function2; + function2_t function2; function3_t function3; struct scm_t* cdr; }; @@ -69,17 +69,17 @@ 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*"}; +scm scm_symbol_cond = {ATOM, "cond"}; +scm scm_symbol_quote = {ATOM, "quote"}; // PRIMITIVES scm * -atom (scm *x) +atom_p (scm *x) { return x->type == PAIR ? &scm_f : &scm_t; } -scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom}; +scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom_p}; scm * car (scm *x) @@ -112,10 +112,10 @@ eq_p (scm *x, scm *y) || (x->type == NUMBER && y->type == NUMBER && x->value == y->value) // FIXME: alist lookup symbols - || (atom (x) == &scm_t + || (atom_p (x) == &scm_t && x->type != NUMBER - && y->type != NUMBER - && atom (y) == &scm_t + && y->type != NUMBER + && atom_p (y) == &scm_t && !strcmp (x->name, y->name))) ? &scm_t : &scm_f; } @@ -143,39 +143,6 @@ quote (scm *x) return cons (&scm_quote, x); } -#if QUASIQUOTE -scm scm_unquote; -scm * -unquote (scm *x) -{ - return cons (&scm_unquote, x); -} - -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; @@ -218,10 +185,16 @@ list (scm *x, ...) return lst; } -// Page 12 scm * pairlis (scm *x, scm *y, scm *a) { +#if 0 //DEBUG + printf ("pairlis x="); + display (x); + printf (" y="); + display (y); + puts (""); +#endif if (x == &scm_nil) return a; return cons (cons (car (x), car (y)), @@ -232,23 +205,21 @@ scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis}; scm * assoc (scm *x, scm *a) { - //printf ("assoc: %s\n" , x->name); - // not Page 12: 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)); } scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc}; -// Page 13 scm *apply (scm*, scm*, scm*); +scm *eval_ (scm*, scm*); +scm *apply_ (scm*, scm*, scm*); scm * eval_quote (scm *fn, scm *x) @@ -261,27 +232,22 @@ scm *call (scm *, scm*); scm *display (scm*); scm *newline (); -// .. continued Page 13 scm * -apply (scm *fn, scm *x, scm *a) +apply_ (scm *fn, scm *x, scm *a) { #if DEBUG printf ("apply fn="); display (fn); - printf (" x="); - display (x); + //printf (" x="); + //display (x); puts (""); #endif - if (atom (fn) != &scm_f) + if (atom_p (fn) != &scm_f) { if (builtin_p (fn) == &scm_t) return call (fn, x); return apply (eval (fn, a), 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); @@ -299,20 +265,11 @@ scm *evcon (scm*, scm*); scm *evlis (scm*, scm*); scm * -eval (scm *e, scm *a) +eval_ (scm *e, scm *a) { -#if DEBUG - printf ("eval e="); - display (e); - // printf (" a="); - // display (a); - puts (""); -#endif - // not Page 12 if (e->type == NUMBER) return e; - // - else if (atom (e) == &scm_t) { + else if (atom_p (e) == &scm_t) { scm *y = assoc (e, a); if (y == &scm_f) { printf ("eval: no such symbol: %s\n", e->name); @@ -320,59 +277,14 @@ eval (scm *e, scm *a) } return cdr (y); } - // not Page 12 if (builtin_p (e) == &scm_t) return e; - // - else if (atom (car (e)) == &scm_t) + else if (atom_p (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) + if (car (e) == &scm_symbol_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) + else if (car (e) == &scm_symbol_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); } @@ -380,18 +292,43 @@ eval (scm *e, scm *a) } scm * -evcon (scm *c, scm *a) +evcon_ (scm *c, scm *a) { - // if (eval (caar (c), a) != &scm_f) - // return eval (cadar (c), a); +#if DEBUG + printf ("evcon_ clause="); + display (car (c)); + puts (""); +#endif if (eval (caar (c), a) != &scm_f) { +#if DEBUG + //if (fn != &scm_display && fn != &scm_call) + //if (fn != &scm_call) + printf ("#t clause="); + display (car (c)); + printf (" cddar="); + display (cddar (c)); + printf (" nil=%d", cddar (c) == &scm_nil); + puts (""); +#endif 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_ (cons (cons (&scm_t, cddar (c)), &scm_nil), a); } - return evcon (cdr (c), a); + return evcon_ (cdr (c), a); } + +scm * +evcon (scm *c, scm *a) +{ +#if DEBUG + printf ("\n****evcon="); + display (c); + puts (""); +#endif + return evcon_ (c, a); +} + scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon}; scm * @@ -403,7 +340,24 @@ evlis (scm *m, scm *a) } scm scm_evlis = {FUNCTION2, .name="evlis", .function2 = &evlis}; -// EXTRAS + +//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 = &evcon}; +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}; + +scm scm_eval = {FUNCTION2, .name="eval", .function2 = &eval}; +scm scm_apply = {FUNCTION3, .name="apply", .function3 = &apply}; + +scm scm_apply_ = {FUNCTION3, .name="c:apply", .function3 = &apply_}; +scm scm_eval_ = {FUNCTION2, .name="c:eval", .function2 = &eval_}; + +//Helpers scm * builtin_p (scm *x) @@ -423,13 +377,35 @@ number_p (scm *x) } scm scm_number_p = {FUNCTION1, .name="number", .function1 = &number_p}; +scm *display_helper (scm*, bool, char*, bool); + +scm * +display (scm *x) +{ + return display_helper (x, false, "", false); +} +scm scm_display = {FUNCTION1, .name="display", .function1 = &display}; + +scm *call (scm*, scm*); +scm scm_call = {FUNCTION2, .name="call", .function2 = &call}; scm * call (scm *fn, scm *x) { +#if DEBUG + //if (fn != &scm_display && fn != &scm_call) + //if (fn != &scm_call) + { + printf ("\ncall fn="); + display (fn); + printf (" x="); + display (x); + puts (""); + } +#endif if (fn->type == FUNCTION0) return fn->function0 (); - else if (fn->type == FUNCTION1) + if (fn->type == FUNCTION1) return fn->function1 (car (x)); if (fn->type == FUNCTION2) return fn->function2 (car (x), cadr (x)); @@ -437,7 +413,6 @@ 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) @@ -473,29 +448,39 @@ lookup (char *x, scm *a) { if (isdigit (*x) || (*x == '-' && isdigit (*(x+1)))) return make_number (atoi (x)); - if (x) { - scm *y = make_atom (x); - scm *r = assoc (y, a); -#if 0 - if (!strcmp (x, "eval")) { - printf ("lookup %s ==> ", x); - display (r); - puts (""); - } + if (*x == '\'') return &scm_symbol_quote; - if (!strcmp (x, "apply")) { - printf ("lookup %s ==> ", x); - display (r); - puts (""); - } -#endif - if (r != &scm_f) return cdr (r); - return y; - } + if (!strcmp (x, scm_symbol_cond.name)) return &scm_symbol_cond; + if (!strcmp (x, scm_symbol_quote.name)) return &scm_symbol_quote; + if (!strcmp (x, scm_lambda.name)) return &scm_lambda; + if (!strcmp (x, scm_label.name)) return &scm_label; + if (!strcmp (x, scm_nil.name)) return &scm_nil; - return &scm_unspecified; + return make_atom (x); } +char * +list2str (scm *l) +{ + static char buf[256]; + char *p = buf; + while (l != &scm_nil) { + scm *c = car (l); + assert (c->type == NUMBER); + *p++ = c->value; + l = cdr (l); + } + *p = 0; + return buf; +} + +scm * +builtin_lookup (scm *l, scm *a) +{ + return lookup (list2str (l), a); +} +scm scm_lookup = {FUNCTION2, .name="lookup", .function2 = &builtin_lookup}; + scm * cossa (scm *x, scm *a) { @@ -505,15 +490,6 @@ cossa (scm *x, scm *a) return cossa (x, cdr (a)); } -scm *display_helper (scm*, bool, char*, bool); - -scm * -display (scm *x) -{ - return display_helper (x, false, "", false); -} -scm scm_display = {FUNCTION1, .name="display", .function1 = &display}; - scm * newline () { @@ -526,7 +502,7 @@ scm * display_helper (scm *x, bool cont, char *sep, bool quote) { scm *r; - printf (sep); + printf ("%s", sep); if (x->type == NUMBER) printf ("%d", x->value); else if (x->type == PAIR) { #if QUOTE_SUGAR @@ -534,16 +510,6 @@ display_helper (scm *x, bool cont, char *sep, bool quote) printf ("'"); 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)); @@ -555,12 +521,13 @@ display_helper (scm *x, bool cont, char *sep, bool quote) } if (!cont) printf (")"); } - else if (atom (x) == &scm_t) printf (x->name); + else if (atom_p (x) == &scm_t) printf ("%s", x->name); return &scm_unspecified; } // READ + int ungetchar (int c) { @@ -630,11 +597,9 @@ readword (int c, char* w, scm *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); + char buf[256] = {0}; + char ch = c; + return readword (getchar (), strncat (w ? w : buf, &ch, 1), a); } scm * @@ -651,13 +616,18 @@ readenv (scm *a) { return readword (getchar (), 0, a); } -scm scm_readenv = {FUNCTION1, .function1 = &readenv}; +scm scm_readenv = {FUNCTION1, .name="readenv", .function1 = &readenv}; + +// Extras to make interesting program scm * -add_environment (scm *a, char *name, scm* x) +hello_world () { - return cons (cons (make_atom (name), x), a); + puts ("c: hello world"); + return &scm_unspecified; } +scm scm_hello_world = {FUNCTION0, .name="hello-world", .function0 = &hello_world}; + scm * less_p (scm *a, scm *b) @@ -670,37 +640,38 @@ less_p (scm *a, scm *b) scm * minus (scm *a, scm *b) { +#if DEBUG + printf ("\nminus a="); + display (a); + printf (" b="); + display (b); + puts (""); +#endif assert (a->type == NUMBER); assert (b->type == NUMBER); - return make_number (a->value - b->value); + //return make_number (a->value - b->value); + scm *r = make_number (a->value - b->value); +#if DEBUG + printf (" ==> "); + display (r); + puts (""); +#endif + return r; } scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p}; scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus}; -scm *global_environment; scm * -apply_environment (scm *fn, scm *x, scm *a) +add_environment (scm *a, char *name, scm* x) { - return apply (fn, x, append (a, global_environment)); + return cons (cons (make_atom (name), x), a); } -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); @@ -723,31 +694,31 @@ initial_environment () 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, "pairlis", &scm_pairlis); a = add_environment (a, "assoc", &scm_assoc); + a = add_environment (a, "c:eval", &scm_eval_); + a = add_environment (a, "c:apply", &scm_apply_); a = add_environment (a, "eval", &scm_eval); a = add_environment (a, "apply", &scm_apply); + a = add_environment (a, "getchar", &scm_getchar); + a = add_environment (a, "peekchar", &scm_peekchar); + a = add_environment (a, "ungetchar", &scm_ungetchar); + a = add_environment (a, "lookup", &scm_lookup); + 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, "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, "hello-world", &scm_hello_world); a = add_environment (a, "<", &scm_less_p); a = add_environment (a, "-", &scm_minus); @@ -765,30 +736,9 @@ initial_environment () 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) { @@ -798,37 +748,27 @@ define_lambda (scm *x, scm *a) scm * define (scm *x, scm *a) { - if (atom (cadr (x)) != &scm_f) + if (atom_p (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)), + if (e == &scm_nil) + return r; + else if (eq_p (e, make_atom ("EOF")) == &scm_t) + return apply (cdr (assoc (make_atom ("loop2"), a)), cons (&scm_unspecified, cons (&scm_t, cons (a, &scm_nil))), a); - else if (atom (e) == &scm_t) + else if (eq_p (e, make_atom ("EOF2")) == &scm_t) + return r; + else if (atom_p (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); } @@ -836,17 +776,45 @@ int main (int argc, char *argv[]) { scm *a = initial_environment (); - //global_environment = a; - scm *x = readenv (a); -#if DEBUG - printf ("program="); - display (x); - puts (""); -#endif - //display (eval (x, a)); - display (loop (&scm_unspecified, x, a)); - // loop (&scm_unspecified, x, a); - //loop (&scm_unspecified, read (), initial_environment ()); + display (loop (&scm_unspecified, readenv (a), a)); newline (); return 0; } + +scm * +apply (scm* fn, scm *x, scm *a) +{ +#if DEBUG + printf ("\nc:apply fn="); + display (fn); + printf (" x="); + display (x); + puts (""); +#endif + if (fn == &scm_apply_) + return eval_ (x, a); + return apply_ (fn, x, a); +} + +bool evalling_p = false; + +scm * +eval (scm *e, scm *a) +{ +#if DEBUG + printf ("\nc:eval e="); + display (e); + puts (""); +#endif + + scm *eval__ = assoc (make_atom ("eval"), a); + assert (eval__ != &scm_f); + eval__ = cdr (eval__); + if (builtin_p (eval__) == &scm_t + || evalling_p) + return eval_ (e, a); + evalling_p = true; + scm *r = apply (eval__, cons (e, cons (a, &scm_nil)), a); + evalling_p = false; + return r; +} diff --git a/mes.test b/mes.test index c7abf61f..9a417044 100755 --- a/mes.test +++ b/mes.test @@ -4,6 +4,8 @@ echo 0 | $mes echo 1 | $mes #echo car | $mes "((0 1))" echo "(car '(0 1))" | $mes +echo "(car (quote (0 1)))" | $mes +echo "(car '(0 1))" | $mes #echo cdr | $mes "((0 1))" echo "(cdr '(0 1))" | $mes #echo cons | $mes "(0 1)"