snarf scm functions and environment.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Jul 2016 21:12:25 +0000 (23:12 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Jul 2016 21:12:25 +0000 (23:12 +0200)
.gitignore
GNUmakefile
mes.c
mes.mes
mes.scm
scm.mes

index a00372159b4d223cd9d20604f35c2a265d7717df..9a2a8654bdc689b75a58c563974493e190723872 100644 (file)
@@ -4,3 +4,4 @@
 *~
 /boot.mes
 /mes
+/mes.h
index b06fbfe5d5812e7da8df626bc42d31a70dd4e325..9d9bed0735368dcdcd958aa971dff3bb099d0c1a 100644 (file)
@@ -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 2475f4544ba458769ee8a3ebc6d902218e57b266..3feca25aae4de695744c942a24087d5889da4e20 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -28,7 +28,6 @@
 #define _GNU_SOURCE
 #include <assert.h>
 #include <ctype.h>
-#include <stdarg.h>
 #include <stdio.h>
 #include <string.h>
 #include <stdlib.h>
@@ -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 = &quote};
-
-#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 (scmc)
+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, scmx)
+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, "*macro*", &scm_nil);
+  a = add_environment (a, "*dot*", &scm_dot);
+  a = add_environment (a, "current-module", &scm_symbol_current_module);
 
-  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);
+#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 (scmfn, 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 6abf69d5686abbbab681ced3aafc6effd01d23f2..74f14a22bbc356d01b7ed4ce9f8bf1d712b157d4 100644 (file)
--- 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)))))
 
 
   ;; (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)
   ;; (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))))
   ;; (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
   ;; (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))
   ;; (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 327b4d90abf1124eeb1e3c844559b047fb4fbb4a..f882c87e6f78cd177a2b2097bd5975e80e5c078f 100755 (executable)
--- 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 d816e3289e67b015b08b635593362ab2f0d22e61..1786c1d7bbeb5d04e96dfdee2f4785536e15fab4 100755 (executable)
--- 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)
   ;; (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))))))