boot.mes: generate from mes.mes, scm.mes, test.mes.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Jul 2016 11:23:58 +0000 (13:23 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sat, 9 Jul 2016 11:23:58 +0000 (13:23 +0200)
.gitignore
GNUmakefile
boot.mes [deleted file]
mes.mes
scm.mes
test.mes [new file with mode: 0644]

index 71a427fd042afc16aadc255af00ca76f6df4ac14..a00372159b4d223cd9d20604f35c2a265d7717df 100644 (file)
@@ -1,6 +1,6 @@
-*~
 *-
 *.go
 *.o
+*~
+/boot.mes
 /mes
-
index 5271407c309248c085c0fb6149be51908c6c9010..739b5973a9b58d07eaa0bb379cac044b6cc8df50 100644 (file)
@@ -4,14 +4,18 @@ CFLAGS=-std=c99 -O3 -finline-functions
 
 default: all
 
-all: mes
+all: mes boot.mes
 
 check: all
        ./mes.test
        ./mes.test ./mes
-#      ./mes < boot.mes
-#      ./mes < scm.mes
-#      ./mes.scm < scm.mes
+       ./mes < test.mes
+
+boot.mes: mes.mes scm.mes test.mes
+       cat $^ > $@
 
 boot: all
        ./mes < boot.mes
+
+run: all
+       ./mes < test.mes
diff --git a/boot.mes b/boot.mes
deleted file mode 100644 (file)
index 01af330..0000000
--- a/boot.mes
+++ /dev/null
@@ -1,339 +0,0 @@
-#! /bin/sh
-# -*-scheme-*-
-exec ./mes "$@" < "$0"
-!#
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;; The Maxwell Equations of programming -- John McCarthy page 13
-;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
-
-;; 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)
-;;    ((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)))))
-
-;; ;; 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)
-  ;; (display 'mes-evlis:)
-  ;; (display m)
-  ;; (newline)
-  (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)
-  (cond
-   ((atom fn)
-    (cond
-     ((builtin fn)
-      (call fn x))
-     (#t (apply (eval fn a) x a))))
-   ((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)
-                                                         (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)
-  (cond
-   ((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))
-     ((pair (assoc (car e) (cdr (assoc '*macro* a))))
-      (c:eval
-       (c:apply
-        (cdr (assoc (car e) (cdr (assoc '*macro* a))))
-        (cdr e)
-        a)
-       a))
-     (#t (apply (car e) (evlis (cdr e) a) a))))
-   (#t (apply (car e) (evlis (cdr e) a) a))))
-
-;; readenv et al works, but slows down dramatically
-(define (DISABLED-readenv a)
-  (readword (getchar) '() a))
-
-(define (readword c w a)
-  (display 'mes-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))
-               ;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() 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 'mes-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))
-        ((atom e)
-         (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
-
-(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 y)
-        (#t #f)))
-
-(define-macro (or x y)
-  (cond (x x)
-        (#t y)))
-
-;; EOF2
-;; EOF
-;; EOF2
-
-(display 'and-0-1:)
-(display (and 0 1))
-(newline)
-(display 'and-#f-2:)
-(display (and #f 2))
-(newline)
-
-(display 'or-0-1:)
-(display (or 0 1))
-(newline)
-(display 'or-#f-2:)
-(display (or #f 2))
-(newline)
-
-(define (split-params 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)
-        (#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)
-
-'()
diff --git a/mes.mes b/mes.mes
index 7b0c02a595066df2faad7c02f2b43816cbb7d98c..9911546c12ae7c8190d9155fa1645e18b2c85da0 100644 (file)
--- a/mes.mes
+++ b/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)
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; mes.mes: 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 <http://www.gnu.org/licenses/>.
+
+;; The Maxwell Equations of Software -- John McCarthy page 13
+;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
+
+;; (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)
+;;    ((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)))))
+
+;; ;; 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
-   ((null x) a)
-   (#t (cons (cons (car x) (car y))
-             (pairlis (cdr x) (cdr y) a)))))
+   ;; 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 (assoc x a)
-  ;;(stderr "assoc x=~a\n" x)
-  (debug "assoc x=~a a=~a\n" x a)
+(define (evlis m a)
+  ;;(debug "evlis m=~a a=~a\n" m a)
+  ;; (display 'mes-evlis:)
+  ;; (display m)
+  ;; (newline)
   (cond
-   ((null a) #f)
-   ((eq (caar a) x) (car a))
-   (#t (assoc x (cdr a)))))
+   ((null m) '())
+   (#t (cons (eval (car m) a) (evlis (cdr m) a)))))
 
-;; Page 13
-(define (eval-quote fn x)
-  (debug "eval-quote fn=~a x=~a" fn x)
-  (apply fn x '()))
 
-(define (apply fn x a)
-  (debug "apply fn=~a x=~a a=~a\n" fn x 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)
   (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))
+     ((builtin fn)
+      (call fn x))
      (#t (apply (eval fn a) x a))))
-   ;; John McCarthy LISP 1.5
-   ((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)))
            (eval (caddr fn) (pairlis (cadr fn) x a)))
           (#t
                                                          (caddr fn)) a)))))
 
 (define (eval e a)
-  (debug "eval e=~a a=~a\n" 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)
   (cond
-   ;;((and (stderr "NUMBER? ~a ==> ~a\n" e (number e)) #f))
    ((number e) e)
-   ;; error: extra
-   ((atom e) (cond ((eq (assoc e a) #f)
-                    (stderr "no such symbol: ~a\n" e)
-                    (guile:exit 1))
-                   (#t (cdr (assoc e a)))))
+   ((eq e #t) #t)
+   ((eq e #f) #f)
    ((atom e) (cdr (assoc e a)))
    ((builtin e) e)
-   ;;((and (stderr "eeee: ~a\n" e) #f))
    ((atom (car e))
     (cond
      ((eq (car e) 'quote) (cadr e))
      ((eq (car e) 'cond) (evcon (cdr e) a))
-     ;; EXTRA: macro expandszor
-     ;;((and (stderr "2eeee: ~a\n" (cdr (assoc '*macro* a))) #f))
-     (;;;(pair (assoc (car e) (cdr (assoc '*macro* a))))
-      #f
-      ;;(stderr "macro: ~a\n" (assoc (car e) (cdr (assoc '*macro* a))))
-      (stderr "apply: ~a ~a\n"
-              `(cons 'lambda (cdr (cdr
-                                   ,(assoc (car e) (cdr (assoc '*macro* a)))
-                                   )))
-              `(evlis ,(cddr e) a)
-              ;;'(evlist foobar)
-              )
-      (eval (apply
-             `(cons 'lambda (cdr (cdr
-                                  ,(assoc (car e) (cdr (assoc '*macro* a)))
-                                  )))
-             `(evlis ,(cddr e) a)
-             a)
-            a))
+     ((pair (assoc (car e) (cdr (assoc '*macro* a))))
+      (c:eval
+       (c:apply
+        (cdr (assoc (car e) (cdr (assoc '*macro* a))))
+        (cdr e)
+        a)
+       a))
      (#t (apply (car e) (evlis (cdr e) a) a))))
    (#t (apply (car e) (evlis (cdr e) a) a))))
 
-(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))))
+;; readenv et al works, but slows down dramatically
+(define (DISABLED-readenv a)
+  (readword (getchar) '() 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 (readword c w a)
+  (display 'mes-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))
+               ;; DOT ((eq w '(*dot*)) (car (readword (getchar) '() 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 'mes-readlis:)
+  (newline)
+  (cond ((eq (peekchar) 41) ;; )
+         (getchar)
+         '())
+        ;; TODO *dot*
+        (#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)))))
diff --git a/scm.mes b/scm.mes
index 4115b586d127c9033c1c35dba095f59926fe0ea1..03ea900258b1102a3eb11385555f486ff25698c8 100755 (executable)
--- a/scm.mes
+++ b/scm.mes
@@ -1,12 +1,9 @@
-#! /bin/sh
-# -*-scheme-*-
-exec ./mes "$@" < "$0"
-!#
+;;; -*-scheme-*-
 
 ;;; Mes --- Maxwell Equations of Software
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;
-;;; This file is part of Mes.
+;;; scm.mes: 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
@@ -24,44 +21,36 @@ exec ./mes "$@" < "$0"
 ;; The Maxwell Equations of Software -- John McCarthy page 13
 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
 
-(display 'boo)
-(newline)
-
-;; (display '*a*:)
-;; (display (eval '*a* '()))
-;; (newline)
-
-(define (+ x y) (- x (- 0 y)))
-
-(display (+ 3 4))
-(newline)
-
-(define-macro (and x y)
-  (cond (x y)
-        (#t #f)))
-
-(define-macro (or x y)
-  (cond (x x)
-        (#t y)))
-
-(define (split-params 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)
-        (#t (split-values (cdr bindings)
-                          (append values (cdar bindings) '())))))
-
-(define-macro (let bindings body)
-  (cons (cons 'lambda (cons (split-params bindings '()) (cons body '())))
-        (split-values bindings '())))
-
-(display 'and-0-1:)
-(display (and 0 1))
-(newline)
-
-(display 'or-#f-1:)
-(display (or #f 2))
-(newline)
+(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 (loop2 r e a)
+  ;; (display '____loop2)
+  ;; (newline)
+  ;; (display 'e:)
+  ;; (display e)  
+  ;; (newline)
+  (cond ((null e) r)
+        ((eq e 'EOF2)
+         (display 'loop2-exiting...)
+         (newline))
+        ((atom e)
+         (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
diff --git a/test.mes b/test.mes
new file mode 100644 (file)
index 0000000..05a1672
--- /dev/null
+++ b/test.mes
@@ -0,0 +1,127 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; test.mes: 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 <http://www.gnu.org/licenses/>.
+
+;; The Maxwell Equations of Software -- John McCarthy page 13
+;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
+
+(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 y)
+        (#t #f)))
+
+(define-macro (or x y)
+  (cond (x x)
+        (#t y)))
+
+;; EOF2
+;; EOF
+;; EOF2
+
+(display 'and-0-1:)
+(display (and 0 1))
+(newline)
+(display 'and-#f-2:)
+(display (and #f 2))
+(newline)
+
+(display 'or-0-1:)
+(display (or 0 1))
+(newline)
+(display 'or-#f-2:)
+(display (or #f 2))
+(newline)
+
+(define (split-params 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)
+        (#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)
+
+'()