From 72d96eb485f9f8a668dd17d498066fb300232453 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 9 Jul 2016 23:12:25 +0200 Subject: [PATCH] snarf scm functions and environment. --- .gitignore | 1 + GNUmakefile | 17 +++++ mes.c | 180 +++++++--------------------------------------------- mes.mes | 106 +++++++++++++++---------------- mes.scm | 54 ++++++++++------ scm.mes | 24 +++---- 6 files changed, 141 insertions(+), 241 deletions(-) diff --git a/.gitignore b/.gitignore index a0037215..9a2a8654 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ *~ /boot.mes /mes +/mes.h diff --git a/GNUmakefile b/GNUmakefile index b06fbfe5..9d9bed07 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -6,6 +6,23 @@ default: all all: mes boot.mes +#mes.o: mes.c mes.h +mes: mes.c mes.h + +mes.h: mes.c GNUmakefile +# $(info FUNCTIONS:$(FUNCTIONS)) + ( echo '#if MES'; echo '#if MES' 1>&2;\ + grep -E '^(scm [*])*[a-z_]+ \(.*\)( {|$$)' $< | grep -Ev '\(.*(char |bool |int )' | sed -e 's,^scm [*],,' | sort |\ + while read f; do\ + fun=$$(echo $$f | sed -e 's,^scm [*],,' -e 's,{.*,,');\ + name=$$(echo $$fun | sed -e 's,^scm [\*],,' | grep -o '^[^ ]*');\ + scm_name=$$(echo $$name | sed -e 's,_p$$,?,' -e 's,^builtin_,,' -re 's,(.*)_$$,c:\1,' | sed -e 's,^less?$$,<,' -e 's,^minus$$,-,' -e 's,_,-,g');\ + args=$$(echo $$fun | grep -o 'scm [\*]' | wc -l);\ + echo "scm *$$fun;";\ + echo "scm scm_$$name = {FUNCTION$$args, .name=\"$$scm_name\", .function$$args=&$$name};";\ + echo "a = add_environment (a, \"$$scm_name\", &scm_$$name);" 1>&2;\ + done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i + check: all ./mes.test ./mes.test ./mes diff --git a/mes.c b/mes.c index 2475f454..3feca25a 100644 --- a/mes.c +++ b/mes.c @@ -28,7 +28,6 @@ #define _GNU_SOURCE #include #include -#include #include #include #include @@ -66,6 +65,11 @@ typedef struct scm_t { }; } scm; +#define MES 1 +#include "mes.h" + +scm *display_helper (scm*, bool, char*, bool); + scm scm_nil = {ATOM, "()"}; scm scm_dot = {ATOM, "."}; scm scm_t = {ATOM, "#t"}; @@ -91,7 +95,6 @@ atom_p (scm *x) { return x->type == PAIR ? &scm_f : &scm_t; } -scm scm_atom = {FUNCTION1, .name="atom", .function1 = &atom_p}; scm * car (scm *x) @@ -148,26 +151,23 @@ scm *eval (scm*, scm*); scm *display (scm*); -scm scm_quote; scm * quote (scm *x) { - return cons (&scm_quote, x); + return cons (&scm_symbol_quote, x); } #if QUASIQUOTE -scm scm_unquote; scm * unquote (scm *x) { - return cons (&scm_unquote, x); + return cons (&scm_symbol_unquote, x); } -scm scm_quasiquote; scm * quasiquote (scm *x) { - return cons (&scm_quasiquote, x); + return cons (&scm_symbol_quasiquote, x); } scm *eval_quasiquote (scm *, scm *); @@ -175,8 +175,6 @@ scm *eval_quasiquote (scm *, scm *); #endif //Library functions -scm scm_read; - // Derived, non-primitives scm *caar (scm *x) {return car (car (x));} @@ -189,32 +187,6 @@ 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, ...) -{ - 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* make_atom (char const *); @@ -235,7 +207,6 @@ pairlis (scm *x, scm *y, scm *a) return cons (cons (car (x), car (y)), pairlis (cdr (x), cdr (y), a)); } -scm scm_pairlis = {FUNCTION3, .name="pairlis", .function3 = &pairlis}; scm * assoc (scm *x, scm *a) @@ -250,7 +221,6 @@ assoc (scm *x, scm *a) return car (a); return assoc (x, cdr (a)); } -scm scm_assoc = {FUNCTION2, .name="assoc", .function2 = &assoc}; scm *apply (scm*, scm*, scm*); scm *eval_ (scm*, scm*); @@ -395,8 +365,6 @@ evcon (scm *c, scm *a) return evcon_ (c, a); } -scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon}; - scm * evlis (scm *m, scm *a) { @@ -410,29 +378,6 @@ evlis (scm *m, scm *a) scm *e = eval (car (m), a); return cons (e, evlis (cdr (m), a)); } -scm scm_evlis = {FUNCTION2, .name="evlis", .function2 = &evlis}; - - -//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}; - -#if QUASIQUOTE -scm scm_unquote = {FUNCTION1, "unquote", .function1 = &unquote}; -scm scm_quasiquote = {FUNCTION1, "quasiquote", .function1 = &quasiquote}; -#endif - -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 @@ -445,26 +390,18 @@ builtin_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 *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) @@ -498,8 +435,6 @@ 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) @@ -572,7 +507,6 @@ 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) @@ -589,7 +523,6 @@ newline () puts (""); return &scm_unspecified; } -scm scm_newline = {FUNCTION0, .name="newline", .function0 = &newline}; scm * display_helper (scm *x, bool cont, char *sep, bool quote) @@ -634,13 +567,13 @@ display_helper (scm *x, bool cont, char *sep, bool quote) // READ int -ungetchar (int c) +ungetchar (int c) //int { return ungetc (c, stdin); } int -peekchar () +peekchar () //int { int c = getchar (); ungetchar (c); @@ -652,23 +585,20 @@ 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) +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) @@ -740,7 +670,6 @@ readenv (scm *a) { return readword (getchar (), 0, a); } -scm scm_readenv = {FUNCTION1, .name="readenv", .function1 = &readenv}; // Extras to make interesting program @@ -750,8 +679,6 @@ hello_world () 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) @@ -783,9 +710,6 @@ minus (scm *a, scm *b) return r; } -scm scm_less_p = {FUNCTION2, .name="<", .function2 = &less_p}; -scm scm_minus = {FUNCTION2, .name="-", .function2 = &minus}; - #if QUASIQUOTE scm * eval_quasiquote (scm *e, scm *a) @@ -813,17 +737,16 @@ eval_quasiquote (scm *e, scm *a) return cdar (e); return cons (car (e), eval_quasiquote (cdr (e), a)); } -scm scm_eval_quasiquote = {FUNCTION2, .name="c:eval-quasiquote", .function2 = &eval_quasiquote}; #endif scm * -add_environment (scm *a, char *name, scm* x) +add_environment (scm *a, char *name, scm *x) { return cons (cons (make_atom (name), x), a); } scm * -initial_environment () +mes_environment () { scm *a = &scm_nil; @@ -831,76 +754,19 @@ initial_environment () 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); - a = add_environment (a, "eval-quasiquote", &scm_eval_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, "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, "builtin", &scm_builtin_p); - a = add_environment (a, "number", &scm_number_p); - a = add_environment (a, "call", &scm_call); - - - a = add_environment (a, "hello-world", &scm_hello_world); - 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); a = add_environment (a, "*dot*", &scm_dot); a = add_environment (a, "current-module", &scm_symbol_current_module); + + a = add_environment (a, "'", &scm_quote); +#if QUASIQUOTE + a = add_environment (a, ",", &scm_unquote); + a = add_environment (a, "`", &scm_quasiquote); +#endif + +#include "environment.i" return a; } @@ -966,14 +832,14 @@ loop (scm *r, scm *e, scm *a) int main (int argc, char *argv[]) { - scm *a = initial_environment (); + scm *a = mes_environment (); display (loop (&scm_unspecified, readenv (a), a)); newline (); return 0; } scm * -apply (scm* fn, scm *x, scm *a) +apply (scm *fn, scm *x, scm *a) { #if DEBUG printf ("\nc:apply fn="); diff --git a/mes.mes b/mes.mes index 6abf69d5..74f14a22 100644 --- a/mes.mes +++ b/mes.mes @@ -36,8 +36,8 @@ ;; (define (pairlis x y a) ;; ;;(debug "pairlis x=~a y=~a a=~a\n" x y a) ;; (cond -;; ((null x) a) -;; ((atom x) (cons (cons x y) a)) +;; ((null? x) a) +;; ((atom? x) (cons (cons x y) a)) ;; (#t (cons (cons (car x) (car y)) ;; (pairlis (cdr x) (cdr y) a))))) @@ -45,8 +45,8 @@ ;; ;;(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)) +;; ((null? a) #f) +;; ((eq? (caar a) x) (car a)) ;; (#t (assoc x (cdr a))))) ;; ;; Page 13 @@ -60,7 +60,7 @@ ;; single-statement cond ;; ((eval (caar c) a) (eval (cadar c) a)) ((eval (caar c) a) - (cond ((null (cddar c)) (eval (cadar c) a)) + (cond ((null? (cddar c)) (eval (cadar c) a)) (#t (eval (cadar c) a) (evcon (cons (cons #t (cddar c)) '()) @@ -73,7 +73,7 @@ ;; (display m) ;; (newline) (cond - ((null m) '()) + ((null? m) '()) (#t (cons (eval (car m) a) (evlis (cdr m) a))))) @@ -84,33 +84,33 @@ ;; (display fn) ;; (newline) ;; (display 'builtin:) - ;; (display (builtin fn)) + ;; (display (builtin? fn)) ;; (newline) ;; (display 'x:) ;; (display x) ;; (newline) (cond - ((atom fn) + ((atom? fn) (cond - ((eq fn 'current-module) ;; FIXME + ((eq? fn 'current-module) ;; FIXME (c:apply current-module '() a)) - ((builtin fn) + ((builtin? fn) (call fn x)) (#t (apply (eval fn a) x a)))) - ((eq (car fn) 'lambda) - (cond ((null (cdr (cddr fn))) + ((eq? (car fn) 'lambda) + (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) + ((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)) + ;;(debug "eval (atom? ~a)=~a\n" e (atom? e)) ;; (display 'mes-eval:) ;; (display e) ;; (newline) @@ -118,19 +118,19 @@ ;; (display a) ;; (newline) (cond - ((number e) e) - ((eq e #t) #t) - ((eq e #f) #f) - ((atom e) (cdr (assoc e a))) - ((builtin e) e) - ((atom (car e)) + ((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) 'lambda) e) - ((eq (car e) 'unquote) (eval (cadr e) a)) - ((eq (car e) 'quasiquote) (eval-quasiquote (cadr e) a)) - ((eq (car e) 'cond) (evcon (cdr e) a)) - ((pair (assoc (car e) (cdr (assoc '*macro* a)))) + ((eq? (car e) 'quote) (cadr e)) + ((eq? (car e) 'lambda) e) + ((eq? (car e) 'unquote) (eval (cadr e) a)) + ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a)) + ((eq? (car e) 'cond) (evcon (cdr e) a)) + ((pair? (assoc (car e) (cdr (assoc '*macro* a)))) (c:eval (c:apply (cdr (assoc (car e) (cdr (assoc '*macro* a)))) @@ -144,12 +144,12 @@ ;; (display 'mes-eval-quasiquote:) ;; (display e) ;; (newline) - (cond ((null e) e) - ((atom e) e) - ((atom (car e)) (cons (car e) (eval-quasiquote (cdr e) a))) - ((eq (caar e) 'unquote) (cons (eval (cadar e) a) '())) - ((eq (caar e) 'quote) (cons (cadar e) '())) - ((eq (caar e) 'quasiquote) (cons (cadar e) '())) + (cond ((null? e) e) + ((atom? e) e) + ((atom? (car e)) (cons (car e) (eval-quasiquote (cdr e) a))) + ((eq? (caar e) 'unquote) (cons (eval (cadar e) a) '())) + ((eq? (caar e) 'quote) (cons (cadar e) '())) + ((eq? (caar e) 'quasiquote) (cons (cadar e) '())) (#t (cons (car e) (eval-quasiquote (cdr e) a))))) ;; readenv et al works, but slows down dramatically @@ -160,31 +160,31 @@ ;; (display 'mes-readword:) ;; (display c) ;; (newline) - (cond ((eq c -1) ;; eof - (cond ((eq w '()) '()) + (cond ((eq? c -1) ;; eof + (cond ((eq? w '()) '()) (#t (lookup w a)))) - ((eq c 10) ;; \n - (cond ((eq w '()) (readword (getchar) w a)) - ;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() a))) + ((eq? c 10) ;; \n + (cond ((eq? w '()) (readword (getchar) w a)) + ;; DOT ((eq? w '(*dot*)) (car (readword (getchar) '() a))) (#t (lookup w a)))) - ((eq c 32) ;; \space + ((eq? c 32) ;; \space (readword 10 w a)) - ((eq c 40) ;; ( - (cond ((eq w '()) (readlis a)) + ((eq? c 40) ;; ( + (cond ((eq? w '()) (readlis a)) (#t (ungetchar c) (lookup w a)))) - ((eq c 41) ;; ) - (cond ((eq w '()) (ungetchar c) w) + ((eq? c 41) ;; ) + (cond ((eq? w '()) (ungetchar c) w) (#t (ungetchar c) (lookup w a)))) - ((eq c 39) ;; ' - (cond ((eq w '()) + ((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) ;; ; + ((eq? c 59) ;; ; (readcomment c) (readword 10 w a)) - ((eq c 35) ;; # - (cond ((eq (peekchar) 33) ;; ! + ((eq? c 35) ;; # + (cond ((eq? (peekchar) 33) ;; ! (getchar) (readblock (getchar)) (readword 10 w a)) @@ -195,27 +195,27 @@ ;; (display 'mes-readblock:) ;; (display c) ;; (newline) - (cond ((eq c 33) (cond ((eq (peekchar) 35) (getchar)) + (cond ((eq? c 33) (cond ((eq? (peekchar) 35) (getchar)) (#t (readblock (getchar))))) (#t (readblock (getchar))))) (define (eat-whitespace) - (cond ((eq (peekchar) 10) (getchar) (eat-whitespace)) - ((eq (peekchar) 32) (getchar) (eat-whitespace)) - ((eq (peekchar) 35) (getchar) (eat-whitespace)) + (cond ((eq? (peekchar) 10) (getchar) (eat-whitespace)) + ((eq? (peekchar) 32) (getchar) (eat-whitespace)) + ((eq? (peekchar) 35) (getchar) (eat-whitespace)) (#t #t))) (define (readlis a) ;; (display 'mes-readlis:) ;; (newline) (eat-whitespace) - (cond ((eq (peekchar) 41) ;; ) + (cond ((eq? (peekchar) 41) ;; ) (getchar) '()) ;; TODO *dot* (#t (cons (readword (getchar) '() a) (readlis a))))) (define (readcomment c) - (cond ((eq c 10) ;; \n + (cond ((eq? c 10) ;; \n c) (#t (readcomment (getchar))))) diff --git a/mes.scm b/mes.scm index 327b4d90..f882c87e 100755 --- a/mes.scm +++ b/mes.scm @@ -81,7 +81,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" ;;(define debug stderr) ;; TODO -(define (atom x) +(define (atom? x) (cond ((guile:pair? x) #f) ((guile:null? x) #f) @@ -91,17 +91,33 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (define car guile:car) (define cdr guile:cdr) (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 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 (pairlis x y a) + ;;(debug "pairlis x=~a y=~a a=~a\n" x y a) + (cond + ((null? x) a) + ((atom? x) (cons (cons x y) 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))))) + (define (append x y) - (cond ((null x) y) + (cond ((null? x) y) (#t (cons (car x) (append (cdr x) y))))) (define (eval-environment e a) @@ -123,15 +139,15 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (*unspecified* . ,*unspecified*) - (atom . ,atom) + (atom? . ,atom?) (car . ,car) (cdr . ,cdr) (cons . ,cons) (cond . ,evcon) - (eq . ,eq) + (eq? . ,eq?) - (null . ,null) - (pair . ,guile:pair?) + (null? . ,null?) + (pair? . ,guile:pair?) ;;(quote . ,quote) (evlis . ,evlis) @@ -146,8 +162,8 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (display . ,guile:display) (newline . ,guile:newline) - (builtin . ,builtin) - (number . ,number) + (builtin? . ,builtin?) + (number? . ,number?) (call . ,call) (< . ,guile:<) @@ -177,7 +193,7 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x))))) (define (mes-define x a) - (if (atom (cadr x)) + (if (atom? (cadr x)) (cons (cadr x) (eval (caddr x) a)) (mes-define-lambda x a))) @@ -187,15 +203,15 @@ exec guile -L $(pwd) -e '(mes)' -s "$0" "$@" (cdr (assoc '*macro* a))))) (define (loop r e a) - (cond ((null e) r) - ((eq e 'exit) + (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) + ((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) + ((eq? (car e) 'define-macro) (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a))) (#t (loop (eval e a) (readenv a) a)))) diff --git a/scm.mes b/scm.mes index d816e328..1786c1d7 100755 --- a/scm.mes +++ b/scm.mes @@ -24,7 +24,7 @@ (define (list . rest) rest) (define (scm-define x a) - (cond ((atom (cadr x)) (cons (cadr x) (eval (caddr 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) @@ -38,15 +38,15 @@ ;; (display 'e:) ;; (display e) ;; (newline) - (cond ((null e) r) - ((eq e 'EOF2) + (cond ((null? e) r) + ((eq? e 'EOF2) (display 'loop2-exiting...) (newline)) - ((atom e) + ((atom? e) (loop2 (eval e a) (readenv a) a)) - ((eq (car e) 'define) + ((eq? (car e) 'define) (loop2 *unspecified* (readenv a) (cons (scm-define e a) a))) - ((eq (car e) 'define-macro) + ((eq? (car e) 'define-macro) (loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a))) (#t (loop2 (eval e a) (readenv a) a)) @@ -68,12 +68,12 @@ EOF (#t y))) (define (split-params bindings params) - (cond ((null 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) + (cond ((null? bindings) values) (#t (split-values (cdr bindings) (append values (cdar bindings) '()))))) @@ -82,7 +82,7 @@ EOF (split-values bindings '()))) (define (expand-let* bindings body) - (cond ((null bindings) + (cond ((null? bindings) (cons (cons 'lambda (cons '() body)) '())) (#t (cons @@ -94,7 +94,7 @@ EOF (expand-let* bindings body)) (define (map f l . r) - (cond ((null l) '()) - ((null r) (cons (f (car l)) (map f (cdr l)))) - ((null (cdr r)) + (cond ((null? l) '()) + ((null? r) (cons (f (car l)) (map f (cdr l)))) + ((null? (cdr r)) (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))