From 3a28828bdfc4e0ed447198353b7ae3e2632c9b01 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Mon, 18 Jul 2016 22:43:16 +0200
Subject: [PATCH] remove booting into mes (would need VM), boot.mes; rewrite
 test.mes.

---
 .gitignore  |   1 -
 GNUmakefile |   9 +-
 c1.mes      |   7 +-
 mes.c       |  90 ++++++------
 scm.mes     |   8 +-
 syntax.mes  |  19 +++
 test.mes    | 412 ++++++++++++++++------------------------------------
 7 files changed, 195 insertions(+), 351 deletions(-)

diff --git a/.gitignore b/.gitignore
index f7ea23e4..49240b9b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -2,7 +2,6 @@
 *.go
 *.o
 *~
-/boot.mes
 /mes
 /mes.h
 /environment.i
diff --git a/GNUmakefile b/GNUmakefile
index 13b9dc0d..f82ff6f9 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -4,9 +4,8 @@ CFLAGS=-std=c99 -O3 -finline-functions
 
 default: all
 
-all: mes boot.mes
+all: mes
 
-#mes.o: mes.c mes.h
 mes: mes.c mes.h
 
 mes.h: mes.c GNUmakefile
@@ -36,12 +35,6 @@ check: all
 	./mes.test ./mes
 	cat scm.mes test.mes | ./mes
 
-boot.mes: mes.mes loop2.mes scm.mes test.mes
-	cat $^ > $@
-
-boot: all
-	./mes < boot.mes
-
 run: all
 	cat scm.mes test.mes | ./mes
 
diff --git a/c1.mes b/c1.mes
index bd5b9ba7..8f3de4a7 100644
--- a/c1.mes
+++ b/c1.mes
@@ -6,10 +6,9 @@
   (define b 1)
   (define (y) b)
   (set! b 0)
-  (display b)
-  (let ((b 2))
-    (y))
-  )
+  (list b
+        (let ((b 2))
+          (y))))
 
 (display (x))
 (newline)
diff --git a/mes.c b/mes.c
index e09c82e9..3f2ea530 100644
--- a/mes.c
+++ b/mes.c
@@ -277,7 +277,7 @@ assq (scm *x, scm *a)
 }
 
 scm *
-apply_env_ (scm *fn, scm *x, scm *a)
+apply_env (scm *fn, scm *x, scm *a)
 {
 #if DEBUG
   printf ("apply_env fn=");
@@ -316,9 +316,9 @@ apply_env_ (scm *fn, scm *x, scm *a)
     display (x);
     puts ("");
 #endif
-    //return apply_env_ (eval_ (fn, a), x, a);
-    scm *e = eval_ (fn, a);
-    return apply_env_ (e, x, a);
+    //return apply_env (eval (fn, a), x, a);
+    scm *e = eval (fn, a);
+    return apply_env (e, x, a);
     //return &scm_unspecified;
   }
 #if MACROS
@@ -333,13 +333,13 @@ apply_env_ (scm *fn, scm *x, scm *a)
     puts ("");
 #endif
     //scm *r = apply_env (cdr (macro), cdr (fn), a);
-    scm *r = apply_env (eval_ (cdr (macro), a), cdr (fn), a);
+    scm *r = apply_env (eval (cdr (macro), a), cdr (fn), a);
 #if DEBUG
     printf ("APPLY MACRO GOT: ==> ");
     display (r);
     puts ("");
 #endif
-    scm *e = eval_ (r, a);
+    scm *e = eval (r, a);
     return apply_env (e, x, a);
   }
 #endif // MACROS
@@ -347,7 +347,7 @@ apply_env_ (scm *fn, scm *x, scm *a)
 }
 
 scm *
-eval_ (scm *e, scm *a)
+eval (scm *e, scm *a)
 {
 #if DEBUG
   printf ("eval e=");
@@ -413,7 +413,7 @@ eval_ (scm *e, scm *a)
         display (cdr (e));
         puts ("");
 #endif
-        return eval (apply_env_ (cdr (macro), cdr (e), a), a);
+        return eval (apply_env (cdr (macro), cdr (e), a), a);
       }
 #endif // MACROS
       return apply_env (car (e), evlis (cdr (e), a), a);
@@ -465,6 +465,9 @@ closure_body (scm *body, scm *a)
         scm *p = pairlis (cdadr (e), cdadr (e), cons (cons (caar (e), caar (e)), a));
         return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), p))), cdr (body));
       }
+      if (eq_p (car (e), &scm_symbol_set_x) == &scm_t)
+        return cons (e, closure_body (cdr (body), a));
+      // skip closure-body-ing macros
       if (eq_p (car (e), &scm_symbol_define_macro) == &scm_t)
         return cons (e, closure_body (cdr (body), a));
       return cons (cons (car (e), cons (cadr (e), closure_body (cddr (e), a))), cdr (body));
@@ -787,10 +790,10 @@ values (scm *x/*...*/)
 scm *
 call_with_values_env (scm *producer, scm *consumer, scm *a)
 {
-  scm *v = apply_env_ (producer, &scm_nil, a);
+  scm *v = apply_env (producer, &scm_nil, a);
   if (v->type == VALUES)
     v = v->cdr;
-  return apply_env_ (consumer, v, a);
+  return apply_env (consumer, v, a);
 }
 
 scm *
@@ -882,6 +885,20 @@ list_to_vector (scm *x)
   return v;
 }
 
+scm*
+integer_to_char (scm *x)
+{
+  assert (x->type == NUMBER);
+  return make_char (x->value);
+}
+
+scm*
+char_to_integer (scm *x)
+{
+  assert (x->type == CHAR);
+  return make_number (x->value);
+}
+
 scm*
 number_to_string (scm *x)
 {
@@ -891,6 +908,13 @@ number_to_string (scm *x)
   return make_string (buf);
 }
 
+scm*
+builtin_exit (scm *x)
+{
+  assert (x->type == NUMBER);
+  exit (x->value);
+}
+
 scm*
 string_to_symbol (scm *x)
 {
@@ -1271,13 +1295,19 @@ eval_quasiquote (scm *e, scm *a)
   }
   puts ("");
 #endif
+//   bool have_unquote = assq (&scm_unquote, a) != &scm_f;
+// #if DEBUG
+//   printf ("eval_quasiquote[%d] ==> ", have_unquote);
+//   display (e);
+//   puts ("");
+// #endif
   if (e == &scm_nil) return e;
   else if (atom_p (e) == &scm_t) return e;
   else if (eq_p (car (e), &scm_symbol_unquote) == &scm_t)
     return eval (cadr (e), a);
   else if (e->type == PAIR && e->car->type == PAIR
            && eq_p (caar (e), &scm_symbol_unquote_splicing) == &scm_t)
-      return append2 (eval_ (cadar (e), a), eval_quasiquote (cdr (e), a));
+      return append2 (eval (cadar (e), a), eval_quasiquote (cdr (e), a));
   return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
 }
 #endif
@@ -1427,44 +1457,6 @@ read_file (scm *e, scm *a)
   return cons (e, read_file (readenv (a), a));
 }
 
-scm *
-apply_env (scm *fn, scm *x, scm *a)
-{
-#if DEBUG
-  printf ("\nc:apply_env fn=");
-  display (fn);
-  printf (" x=");
-  display (x);
-  puts ("");
-#endif
-  if (fn == &scm_apply_env_)
-    return eval_ (x, a);
-  return apply_env_ (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__ = assq (&scm_symbol_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_env (eval__, cons (e, cons (a, &scm_nil)), a);
-  evalling_p = false;
-  return r;
-}
-
 int
 main (int argc, char *argv[])
 {
diff --git a/scm.mes b/scm.mes
index 419d0295..2965d1b3 100755
--- a/scm.mes
+++ b/scm.mes
@@ -36,7 +36,7 @@
 (define (vector . rest) (list->vector rest))
 
 (define (apply f args)
-  (c:eval (cons f args) (current-module)))
+  (eval (cons f args) (current-module)))
 
 (define (defined? x)
   (assq x (current-module)))
@@ -171,3 +171,9 @@
 ;;       (let ((val (number->string counter)))
 ;;         (set! counter (+ counter 1))
 ;;         (string->symbol (string-append "g" val))))))
+
+(define *gensym* 0)
+(define (gensym)
+  (set! *gensym* (+ *gensym* 1))
+  (string->symbol (string-append "g" (number->string *gensym*))))
+
diff --git a/syntax.mes b/syntax.mes
index 914bb1cb..4acce4b1 100644
--- a/syntax.mes
+++ b/syntax.mes
@@ -156,6 +156,7 @@
         (display "make-transformer") (newline)
         `(lambda (,%input ,%rename ,%compare)
            (let ((,%tail (cdr ,%input)))
+             (display "TEEL:") (display ,%tail) (newline)
              (cond ,@(map process-rule rules)
                    (#t ;;else
                     (syntax-error
@@ -169,6 +170,24 @@
                     (null? (cddr rule)))
                (let ((pattern (cdar rule))
                      (template (cadr rule)))
+                 (let ((xx `,(process-pattern pattern
+                                              %tail
+                                              (lambda (x) x)))
+                       (tt `,%tail)
+                       (yy (process-match %tail pattern)))
+                   (display "METS>>>") (newline)
+                   (display yy)
+                   (newline)
+                   (display "TEEL>>>") (newline)
+                   (display tt)
+                   (newline)
+                   (display "<<<METS") (newline)
+                   (display "PETTERN>>>") (newline)
+                   (display xx)
+                   (newline)
+                   (display "<<<PETTERN") (newline)
+                   )
+                 
                  `((and ,@(process-match %tail pattern))
                    (let* ,(process-pattern pattern
                                            %tail
diff --git a/test.mes b/test.mes
index 991a1139..c832ed98 100644
--- a/test.mes
+++ b/test.mes
@@ -21,251 +21,93 @@
 ;; The Maxwell Equations of Software -- John McCarthy page 13
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
-(display 123)
+;; haha, broken.  lat0r
+(define pass 0)
+(define fail 0)
+(define result #f)
+(let ((pass 0)
+      (fail 0))
+  (set! result
+    (lambda (. t)
+      (cond ((null? t) (list pass fail))
+            ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
+            (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
 
-4
-(newline)
+(define-macro (pass-if name t)
+  `(let ()
+     (display "test: ") (display ,name)
+     (result ,t)))
 
-(cons (display 'one-) (display 'two))
-(newline)
+(define-macro (pass-if-not name f)
+  `(let ()
+     (display "test: ") (display ,name)
+     (result (not ,f))))
 
-(display 'hello-display-symbol)
-(newline)
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
 
-(display '(0 1 2))
-(newline)
+(pass-if "and" (eq? (and 1) 1))
+(pass-if "and 2" (eq? (and 1 (= 0 1) #f) #f))
+(pass-if "or" (eq? (or) #f))
+(pass-if "or 2" (eq? (or 1) 1))
+(pass-if "or 3" (eq? (or #f (= 0 1) 3) 3))
+(pass-if "let" (eq? (let ((p 5) (q 6)) (+ p q)) 11))
+(pass-if "let loop" (equal? (let loop ((lst '(3 2 1)))
+                              (if (null? lst) '()
+                                  (cons (car lst)
+                                        (loop (cdr lst))))) '(3 2 1)))
+(pass-if "quasiquote" (let ((cc 'bb)) (equal? `(aa bb ,cc) '(aa bb bb))))
+(pass-if "let* comments" (eq? (let* ((aa 2)
+                                     (bb (+ aa 3))
+                                     #! boo !#
+                                     ;;(bb 4)
+                                     )
+                                bb)
+                              5))
 
-(display (- 12 3))
-(newline)
-
-(display (+ 3 4))
-
-(newline)
-
-(display "(and): ")
-(display (and))
-(newline)
-(display "(and 1): ")
-(display (and 1))
-(newline)
-(display "(and 1 (= 0 1)): ")
-(display (and 1 (= 0 1)))
-(newline)
-
-(display "(or): ")
-(display (or))
-(newline)
-(display "(or 1): ")
-(display (or 1))
-(newline)
-(display "(or #f (= 0 1) 3): ")
-(display (or #f (= 0 1) 3))
-(newline)
-(display (or (= 0 1) #f (and (display "YEAH") (newline) 'woet)))
-(newline)
-
-(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)
-
-(let loop ((lst '(3 2 1)))
-  (display "loop")
-  (newline)
-  (if (null? lst) (begin (display "dun") 'dun)
-      (begin
-        (display "looping: ")
-        (display (car lst))
-        (newline)
-        (loop (cdr lst)))))
-(newline)
-
-(define c 'b)
-`(aa bb ,c)
-(display `(pp qq ,c))
-(newline)
-
-(display
- (let* ((aa 2)
-       (bb (+ aa 3))
-       #! boo !#
-       ;;(bb 4)
-       )
-   (display 'allo:)
-   bb))
-
-(newline)
-(display 'let*-dun)
-(newline)
-(map display '(1 2 3 4))
-(newline)
-(map (lambda (x) (display x) (newline)) '(5 6 7 8))
-(newline)
-
-(map (lambda (i a) (display i) (display ':) (display a) (newline)) '(1 2 3 4) '(a b c d))
-(newline)
-
-(define a 0)
-(display 'a=0:)
-(display a)
-(newline)
-(display "set!")
-(display (set! a 1))
-(set! a 1)
-(display 'a=1:)
-(display a)
-(newline)
-
-(display
- ((lambda (x)
-    (display 'x:)
-    (display x)
-    (newline)
-    (display 'setting-x=2)
-    (newline)
-    (set! x 2)
-    (display 'x:)
-    (display x)
-    (newline))
-  1))
-
-(display (+ 11 12))
-(newline)
-(display (* 3 3))
-(newline)
-(display (/ 9 3))
-(newline)
-(display (= 3 '3))
-(newline)
-
-(display (if #t 'true))
-(newline)
-(display (if (eq? 0 '0) 'true 'false))
-(newline)
-(display (if (= 1 2) 'true 'false))
-(newline)
-
-(display 'factorial4=)
-(display
- (letrec ((factorial (lambda (n)
-                       ;; (display 'factorial:)
-                       ;; (display n)
-                       ;; (newline)
-                       (if (= n 1) 1
-                           (* n (factorial (- n 1)))))))
-   (factorial 4)))
-(newline)
-
-(define a 2)
-(begin
-  (display 'a+3=)
-  (display (+ a 3)))
-(newline)
-
-" a b c"
-(display "string me")
-(newline)
-(display (string-append "a" "b" "c"))
-(newline)
-(display (string-length (string-append "a" "b" "c")))
-(newline)
-
-#\m
-(display #\m)
-(newline)
-(display #\101)
-(newline)
-(display #\newline)
-(newline)
-(display #\space)
-(newline)
-
-(display (string #\a #\space #\s #\t #\r #\i #\n #\g #\newline))
-(newline)
-
-(display "length of nil: ")
-(display (length '()))
-(newline)
-(display "length of '(a b c): ")
-(display (length '(a b c)))
-(newline)
-
-#(a b c)
-(display #(0 1 2))
-(newline)
-(define v #("a" "b" "c"))
-(display "vector?: ")
-(display (vector? v))
-(newline)
-(display "length of ")
-(display v)
-(display ": ")
-(display (vector-length v))
-(newline)
-(display "as list: ")
-(define lv (vector->list v))
-(display lv)
-(newline)
-(display "again as vector: ")
-(display (list->vector lv))
-(newline)
-
-(display "(vector 0 1 2): ")
-(display (vector 0 1 2))
-(newline)
-
-(display "v[1]: ")
-(display (vector-ref v 1))
-(newline)
-
-(display "v[1]=q: ")
-(vector-set! v 1 'q)
-(display v)
-(newline)
-
-(display "memq a: ")
-(display (memq 'a '(a b c)))
-(newline)
-
-(display "memq b: ")
-(display (memq 'b '(a b c)))
-(newline)
-
-(display "memq c: ")
-(display (memq 'c '(a b c)))
-(newline)
-
-(display "memq d: ")
-(display (memq 'd '(a b c)))
-(newline)
-
-(display "member a: ")
-(display (member '(a) '((a) b c)))
-(newline)
-
-(display "plus: ")
-(display (+ 1 1 1 1))
-(newline)
+(pass-if "map" (equal? (map identity '(1 2 3 4)) '(1 2 3 4)))
+(pass-if "map 2 " (equal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d))
+                          '((1 . a) (2 . b) (3 . c) (4 . d))))
+(define xxxa 0)
+(pass-if "set! " (eq? (begin (set! xxxa 1) xxxa) 1))
+(pass-if "set! 2" (eq? (let ((a 0)) (set! a 1) a) 1))
+(pass-if "+" (eq? (+ 1 2 3) 6))
+(pass-if "*" (eq? (* 3 3 3) 27))
+(pass-if "/" (eq? (/ 9 3) 3))
+(pass-if "=" (= 3 '3))
+(pass-if "= 2" (not (= 3 '4)))
+(pass-if "if" (eq? (if #t 'true) 'true))
+(pass-if "if 2" (eq? (if (eq? 0 '0) 'true 'false) 'true))
+(pass-if "if 3" (eq? (if (= 1 2) 'true 'false) 'false))
+(pass-if "letrec" (= (letrec ((factorial (lambda (n)
+                                           (if (= n 1) 1
+                                               (* n (factorial (- n 1)))))))
+                       (factorial 4))
+                     24))
+(pass-if "begin" (eq? (begin 'a 'b (+ 1 2)) 3))
+(pass-if "string-append" (equal? (string-append "a" "b" "c") "abc"))
+(pass-if "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
+(pass-if "string-length" (= (string-length (string-append "a" "b" "c")) 3))
+(pass-if "char" (= (char->integer #\A) 65))
+(pass-if "char 2" (= (char->integer #\101) (char->integer #\A)))
+(pass-if "char 3" (eq? (integer->char 10) #\newline))
+(pass-if "char 4" (eq? (integer->char 32) #\space))
+(pass-if "string " (equal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string"))
+(pass-if "length" (eq? (length '()) 0))
+(pass-if "length 2" (= (length '(a b c)) 3))
+(pass-if "vector?" (vector? #(1 2 c)))
+(pass-if "vector-length" (= (vector-length #(1)) 1))
+(pass-if "list->vector" (equal? (list->vector '(a b c)) #(a b c)))
+(pass-if "vector" (equal? #(vector 0 1 2) #(vector 0 1 2)))
+(pass-if "vector-ref" (eq? (vector-ref #(0 1) 1) 1))
+;;(pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q)))
+;;(pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #()))
+(pass-if "equal?" (equal? #(1) #(1)))
+(pass-if "equal?" (not (equal? #() #(1))))
+(pass-if "memq" (equal? (memq 'a '(a b c)) '(a b c)))
+(pass-if "memq" (equal? (memq 'b '(a b c)) '(b c)))
+(pass-if "memq" (eq? (memq 'd '(a b c)) #f))
+(pass-if "member" (equal? (member '(a) '((a) b c)) '((a) b c)))
 
 ;; works, but debugging is foo
 ;; (cond ((defined? 'loop2)
@@ -286,53 +128,47 @@
 ;;        (display ((lambda (x) x) (values 1 2 3)))
 ;;        (newline)))
 
-(display "(procedure? builtin?: ")
-(display (procedure? builtin?))
+(define (guile?) (defined? 'gc))
+(if (guile?)
+    (module-define! (current-module) 'builtin? (lambda (. x) #t)))
+
+(pass-if "builtin?" (builtin? eval))
+;;(pass-if "builtin?" (builtin? cond))
+(pass-if "procedure?" (procedure? builtin?))
+(pass-if "procedure?" (procedure? procedure?))
+(when (not (guile?))
+  (pass-if "gensym" (eq? (gensym) 'g0))
+  (pass-if "gensym" (eq? (gensym) 'g1))
+  (pass-if "gensym" (eq? (gensym) 'g2)))
+(pass-if "unquote" (equal? `,(list 1 2 3 4) '(1 2 3 4)))
+(pass-if "splice" (equal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2)))
+(pass-if "splice" (equal? `(1 ,@(list 2 3) 4) '(1 2 3 4)))
+(pass-if "splice" (equal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4)))
+(pass-if "unquote" (equal? `(1 2 '(,(+ 1 2))) '(1 2 '(3))))
+(pass-if "when" (eq? (when #t 'true) 'true))
+(pass-if "when 2" (eq? (when #f 'true) *unspecified*))
+
+(define b 0)
+(define x (lambda () b))
+(define (x) b)
+(pass-if "closure" (= (x) 0))
+(define (c b)
+  (x))
+(pass-if "closure 2" (= (c 1) 0))
+
+(define (x)
+  (define b 1)
+  (define (y) b)
+  (set! b 0)
+  (list b
+        (let ((b 2))
+          (y))))
+
+(pass-if "closure 3" (equal? (x) '(0 0)))
+
 (newline)
+(display "passed: ") (display (car (result))) (newline)
+(display "failed: ") (display (cadr (result))) (newline)
+(display "total: ") (display (apply + (result))) (newline)
 
-(display "(procedure? procedure?): ")
-(display (procedure? procedure?))
-(newline)
-
-(define *gensym* 0)
-(define (gensym)
-  (set! *gensym* (+ *gensym* 1))
-  (string->symbol (string-append "g" (number->string *gensym*))))
-
-(display (gensym))
-(newline)
-(display (gensym))
-(newline)
-(display (gensym))
-(newline)
-
-(display "unquote:")
-(display `,(list 1 2 3 4))
-(newline)
-
-(display `('boo ,@'(bah baz) 1 2))
-(newline)
-
-(display "splice:")
-(display `(1 ,@(list 2 3) 4))
-(newline)
-
-(define s-r '(2 3))
-(display "splice:")
-(display `(1 ,@s-r 4))
-(newline)
-
-(display "`(1 2 '(,(+ 1 2))): ")
-(display `(1 2 '(,(+ 1 2))))
-(newline)
-
-(display "when:")
-(when #t
-  (display "true")
-  (newline))
-
-(when #f
-  (display "must not see")
-  (newline))
-
-'()
+(exit (cadr (result)))