mes.c: support `.' and add let.

GNUmakefile

@@ -9,7 +9,7 @@ all: mes
 check: all
 	./mes.test
 	./mes.test ./mes
-	./mes < boot.mes
+#	./mes < boot.mes
 #	./mes < scm.mes
 #	./mes.scm < scm.mes
 

boot.mes

@@ -45,6 +45,7 @@ exec ./mes "$@" < "$0"
 ;;   (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)))))
 
@@ -76,6 +77,9 @@ exec ./mes "$@" < "$0"
 
 (define (evlis m a)
   ;;(debug "evlis m=~a a=~a\n" m a)
+  ;; (display 'mes-evlis:)
+  ;; (display m)
+  ;; (newline)
   (cond
    ((null m) '())
    (#t (cons (eval (car m) a) (evlis (cdr m) a)))))
@@ -119,10 +123,6 @@ exec ./mes "$@" < "$0"
   ;; (display 'a:)
   ;; (display a)
   ;; (newline)
-  ;;(display 'pair?*macro*:)
-  ;;(display (assoc '*macro* a))
-  ;; (display (cdr (assoc '*macro* a)))
-  ;; (newline)
   (cond
    ((number e) e)
    ((eq e #t) #t)
@@ -133,36 +133,13 @@ exec ./mes "$@" < "$0"
     (cond
      ((eq (car e) 'quote) (cadr e))
      ((eq (car e) 'cond) (evcon (cdr e) a))
-     (;;#f  ;; #f: no macro support
+     ((pair (assoc (car e) (cdr (assoc '*macro* a))))
-      #t ;; #t: macro support
+      (c:eval
-      (cond
+       (c:apply
-       ((eq (assoc '*macro* a) #f)
+        (cdr (assoc (car e) (cdr (assoc '*macro* a))))
-        (display 'we-have-no-macros:)
+        (cdr e)
-        (display e)
+        a)
-        (newline)
+       a))
-
-        (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))))
 
@@ -171,14 +148,15 @@ exec ./mes "$@" < "$0"
   (readword (getchar) '() a))
 
 (define (readword c w a)
-  ;; (display 'readword:)
+  (display 'mes-readword:)
-  ;; (display c)
+  (display c)
-  ;; (newline)
+  (newline)
   (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)))
                (#t (lookup w a))))
         ((eq c 32) ;; \space
          (readword 10 w a))
@@ -199,8 +177,8 @@ exec ./mes "$@" < "$0"
         (#t (readword (getchar) (append w (cons c '())) a))))
 
 (define (readlis a)
-  ;; (display 'readlis:)
+  (display 'mes-readlis:)
-  ;; (newline)
+  (newline)
   (cond ((eq (peekchar) 41) ;; )
          (getchar)
          '())
@@ -255,10 +233,8 @@ exec ./mes "$@" < "$0"
 ;;(newline)
 EOF
 
-;; loop2 skips one read:
-'this-is-skipped-scm
-
 (display 123)
+
 4
 (newline)
 
@@ -284,6 +260,10 @@ EOF
   (cond (x x)
         (#t y)))
 
+;; EOF2
+;; EOF
+;; EOF2
+
 (display 'and-0-1:)
 (display (and 0 1))
 (newline)
@@ -298,7 +278,62 @@ EOF
 (display (or #f 2))
 (newline)
 
-'()
+(define (split-params bindings params)
-EOF2
+  (cond ((null bindings) params)
-EOF
+        (#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 (let1 bindings body)
+  (cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
+        (split-values bindings '())))
+
+(let1 ((a 3)
+      (b 4))
+      ((lambda ()
+         (display 'let-a:3-b:4)
+         (newline)
+         (display 'a:)
+         (display a)
+         (newline)
+         (display 'b:)
+         (display b)
+         (newline))))
+
+(display 'let1-dun)
+(newline)
+
+(define-macro (let bindings . body)
+  (cons (cons 'lambda (cons (split-params bindings '()) body))
+        (split-values bindings '())))
+
+(let ((p 5)
+       (q 6))
+      (display 'let-p:3-q:4)
+      (newline)
+      (display 'p:)
+      (display p)
+      (newline)
+      (display 'q:)
+      (display q)
+      (newline))
+
+
+(display
+ (let ((p 5)
+       (q 6))
+   (display 'hallo)
+   (display p)
+   (display 'daar)
+   (display q)
+   (display 'dan)))
+
+(newline)
+(display 'let-dun)
+(newline)
+
+'()

mes.c

@@ -36,6 +36,8 @@
 
 #define DEBUG 0
 
+#define MACROS 1
+
 #ifndef QUOTE_SUGAR
 #define QUOTE_SUGAR 1
 #endif
@@ -64,6 +66,7 @@ typedef struct scm_t {
 } scm;
 
 scm scm_nil = {ATOM, "()"};
+scm scm_dot = {ATOM, "."};
 scm scm_t = {ATOM, "#t"};
 scm scm_f = {ATOM, "#f"};
 scm scm_lambda = {ATOM, "lambda"};
@@ -71,6 +74,7 @@ scm scm_label = {ATOM, "label"};
 scm scm_unspecified = {ATOM, "*unspecified*"};
 scm scm_symbol_cond = {ATOM, "cond"};
 scm scm_symbol_quote = {ATOM, "quote"};
+scm scm_macro = {ATOM, "*macro*"};
 
 // PRIMITIVES
 
@@ -185,10 +189,12 @@ list (scm *x, ...)
   return lst;
 }
 
+scm* make_atom (char const *);
+
 scm *
 pairlis (scm *x, scm *y, scm *a)
 {
-#if 0 //DEBUG
+#if DEBUG
   printf ("pairlis x=");
   display (x);
   printf (" y=");
@@ -197,6 +203,8 @@ pairlis (scm *x, scm *y, scm *a)
 #endif
   if (x == &scm_nil)
     return a;
+  if (atom_p (x) == &scm_t)
+    return cons (cons (x, y), a);
   return cons (cons (car (x), car (y)),
                pairlis (cdr (x), cdr (y), a));
 }
@@ -238,8 +246,8 @@ apply_ (scm *fn, scm *x, scm *a)
 #if DEBUG
   printf ("apply fn=");
   display (fn);
-  //printf (" x=");
+  printf (" x=");
-  //display (x);
+  display (x);
   puts ("");
 #endif
   if (atom_p (fn) != &scm_f)
@@ -250,6 +258,7 @@ apply_ (scm *fn, scm *x, scm *a)
     }
   else if (car (fn) == &scm_lambda) {
     scm *body = cddr (fn);
+    scm *ca = cadr (fn);
     scm *ax = pairlis (cadr (fn), x, a);
     scm *result = eval (car (body), ax);
     if (cdr (body) == &scm_nil)
@@ -267,6 +276,11 @@ scm *evlis (scm*, scm*);
 scm *
 eval_ (scm *e, scm *a)
 {
+#if DEBUG
+  printf ("eval e=");
+  display (e);
+  puts ("");
+#endif
   if (e->type == NUMBER)
     return e;
   else if (atom_p (e) == &scm_t) {
@@ -281,12 +295,18 @@ eval_ (scm *e, scm *a)
     return e;
   else if (atom_p (car (e)) == &scm_t)
     {
+#if MACROS
+      scm *macro;
+#endif // MACROS
       if (car (e) == &scm_symbol_quote)
         return cadr (e);
       else if (car (e) == &scm_symbol_cond)
         return evcon (cdr (e), a);
-      else
+#if MACROS
-        return apply (car (e), evlis (cdr (e), a), a);
+      else if ((macro = assoc (car (e), cdr (assoc (&scm_macro, a)))) != &scm_f)
+        return eval (apply_ (cdr (macro), cdr (e), a), a);
+#endif // MACROS
+      return apply (car (e), evlis (cdr (e), a), a);
     }
   return apply (car (e), evlis (cdr (e), a), a);
 }
@@ -334,6 +354,11 @@ scm scm_evcon = {FUNCTION2, .name="evcon", .function2 = &evcon};
 scm *
 evlis (scm *m, scm *a)
 {
+#if DEBUG
+  printf ("evlis m=");
+  display (m);
+  puts ("");
+#endif
   if (m == &scm_nil)
     return &scm_nil;
   return cons (eval (car (m), a), evlis (cdr (m), a));
@@ -586,6 +611,7 @@ 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 == '\n' && *w == '.' && w[1] == 0) return &scm_dot;
   if (c == EOF || c == '\n') return lookup (w, a);
   if (c == ' ') return readword ('\n', w, a);
   if (c == '(' && !w) return readlis (a);
@@ -608,6 +634,8 @@ readlis (scm *a)
   int c = getchar ();
   if (c == ')') return &scm_nil;
   scm *w = readword (c, 0, a);
+  if (w == &scm_dot)
+    return car (readlis (a));
   return cons (w, readlis (a));
 }
 
@@ -738,6 +766,7 @@ initial_environment ()
 
   //
   a = add_environment (a, "*macro*", &scm_nil);
+  a = add_environment (a, "*dot*", &scm_dot);
 
   return a;
 }
@@ -756,9 +785,22 @@ define (scm *x, scm *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)
 {
+#if DEBUG
+  printf ("\nc:loop e=");
+  display (e);
+  puts ("");
+#endif
   if (e == &scm_nil)
     return r;
   else if (eq_p (e, make_atom ("EOF")) == &scm_t)
@@ -772,6 +814,10 @@ loop (scm *r, scm *e, scm *a)
     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);
 }
 

mes.mes

@@ -47,7 +47,7 @@
      ((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) (eval (caddr fn) (pairlis (cadr fn) x a)))
    ((eq (car fn) 'lambda)
     ;; (CDDR fn) all eval
     (cond ((null (cdr (cddr fn)))

mes.test

@@ -20,3 +20,5 @@ echo "((label fun\
                          (cond ((< 0 x) (fun (- x 1)))\
                                (#t '())))))\
        3)" | $mes
+echo "'(0 . 1)" | $mes
+echo "(cdr '(0 . 1))" | $mes

scm.mes

@@ -54,9 +54,9 @@ exec ./mes "$@" < "$0"
         (#t (split-values (cdr bindings)
                           (append values (cdar bindings) '())))))
 
-;; (define-macro (let bindings body)
+(define-macro (let bindings body)
-;;   (cons (cons 'lambda (cons (split-params bindings '()) body))
+  (cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
-;;         (split-values bindings '())))
+        (split-values bindings '())))
 
 (display 'and-0-1:)
 (display (and 0 1))