Implement eval/apply in Scheme.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 16 Oct 2016 16:53:31 +0000 (18:53 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 16 Oct 2016 16:53:31 +0000 (18:53 +0200)
* module/mes/loop-0.mes: New file.
* module/mes/mes.mes: Remove

module/mes/loop-0.mes [new file with mode: 0644]
module/mes/mes.mes [deleted file]

diff --git a/module/mes/loop-0.mes b/module/mes/loop-0.mes
new file mode 100644 (file)
index 0000000..28977fe
--- /dev/null
@@ -0,0 +1,192 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; loop-0.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/>.
+
+;;; Commentary:
+
+;;; loop-0.mes - bootstrap into Scheme from minimal -DBOOT=1 core.
+
+;;; When compiling mes.c with -DBOOT=1, eval/apply et al. are lacking
+;;; features wrt the fat-c variant, e.g., define and define-macro are
+;;; not available; instead label is supplied.  Before loading
+;;; boot-0.mes, loop-0.mes is loaded to provide a richer eval/apply.
+
+;;; This might enable moving more functionality from C to Scheme,
+;;; making the full source bootstrap process more feasible.  However,
+;;; currently performance is 400x worse.  Also several tests in the
+;;; test suite fail and the REPL does not work yet.
+
+;;; Code:
+
+((label loop-0
+        (lambda (r e a)
+          ;; (display "***LOOP-0*** ... e=") (display e) (newline)
+          (if (null? e) (eval (read-file (read-env a) a) a)
+              (if (atom? e) (loop-0 (eval e a) (read-env a) a)
+                  (if (eq? (car e) 'define)
+                      ((lambda (aa)     ; env:define
+                         ;; (display "0DEFINE name=") (display (cadr e)) (newline)
+                         (set-cdr! aa (cdr a))
+                         (set-cdr! a aa)
+                         (set-cdr! (assq '*closure* a) a)
+                         (loop-0 *unspecified* (read-env a) a))
+                       (cons            ; sexp:define
+                        (if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
+                            (cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a)))
+                        '()))
+                      (if (eq? (car e) 'define-macro)
+                          ((lambda (name+entry) ; env:macro
+                             ;; (display "0MACRO name=") (display (car name+entry)) (newline)
+                             ((lambda (aa) ; env:define
+                                (set-cdr! aa (cdr a))
+                                (set-cdr! a aa)
+                                (set-cdr! (assq '*closure* a) a)
+                                (loop-0 *unspecified* (read-env a) a))
+                              (cons
+                               (cons (car name+entry)
+                                     (make-macro (car name+entry)
+                                                 (cdr name+entry)))
+                               '())))
+                                        ; sexp:define
+                           (if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
+                               (cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a)))
+                           '())
+                          (loop-0 (eval e a) (read-env a) a)))))))
+ *unspecified* (read-env '()) (current-module))
+
+()
+;; enter reading loop-0
+(display "loop-0 ...\n")
+
+(define (evcon c a)
+  ;; (display "evcon c=")
+  ;; (display c)
+  ;; (newline)
+  (if (null? c) *unspecified*
+      (if (eval-env (caar c) a)
+          (if (null? (cdar c) (eval-env (caar c) a))
+              (if (null? (cddar c)) (eval-env (cadar c) a)
+                  ((lambda ()
+                     (eval-env (cadar c) a)
+                     (evcon (cons (cons #t (cddar c)) '()) a)))))
+          (evcon (cdr c) a))))
+
+(define (not x)
+  (if x #f #t))
+
+(define (evlis-env m a)
+  (cond
+   ((null? m) '())
+   ((not (pair? m)) (eval m a))
+   (#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
+
+(define (apply-env fn x a) 
+  (cond
+   ((atom? fn)
+    (cond
+     ((builtin? fn) (call fn x))
+     ((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
+     ((eq? fn 'current-module) a)
+     (#t (apply-env (eval fn a) x a))))
+   ((eq? (car fn) 'lambda)
+    ;; (let ((p (pairlis (cadr fn) x a)))
+    ;;   (eval (cons 'begin (cddr fn)) (cons (cons '*closure* p)) p))
+    (eval (cons 'begin (cddr fn))
+              (cons (cons '*closure* (pairlis (cadr fn) x a))
+                    (pairlis (cadr fn) x a))))
+   ((eq? (car fn) '*closure*)
+    ;; (let* ((args (caddr fn))
+    ;;        (body (cdddr fn))
+    ;;        (a (cddr (cadr fn)))
+    ;;        (p (pairlis args x a)))
+    ;; (eval (cons 'begin body) (cons (cons '*closure* p) p)))
+    (eval (cons 'begin (cdddr fn))
+              (cons (cons '*closure* (pairlis (caddr fn) x (cddr (cadr fn))))
+                    (pairlis (caddr fn) x (cddr (cadr fn))))))
+
+   ((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
+   (#t (apply-env (eval fn a) x a))))
+
+(define (eval-expand e a)
+  (cond
+   ((internal? e) e)
+   ((builtin? e) e)
+   ((char? e) e)
+   ((number? e) e)
+   ((string? e) e)
+   ((vector? e) e)
+   ((atom? e) (cdr (assq e a)))
+   ((atom? (car e))
+    (cond
+     ((eq? (car e) 'quote) (cadr e))
+     ((eq? (car e) 'syntax) (cadr e))
+     ((eq? (car e) 'begin) (eval-begin-env e a))
+     ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
+     ((eq? (car e) '*closure*) e)
+     ((eq? (car e) 'cond) (evcon (cdr e) a))
+     ((eq? (car e) 'if) (eval-if-env (cdr e) a))
+     ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
+     ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
+     ((eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a))
+     ((eq? (car e) 'unquote) (eval (cadr e) a))
+     ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
+     (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
+   (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
+
+(define (eval e a)
+  (eval-expand (expand-macro-env e a) a))
+
+(define (expand-macro-env e a)
+  (if (pair? e) ((lambda (macro)
+                   (if macro (expand-macro-env (apply-env macro (cdr e) a) a)
+                       e))
+                 (lookup-macro (car e) a))
+      e))
+
+(define (eval-begin-env e a)
+  (if (null? e) *unspecified*
+      (if (null? (cdr e)) (eval (car e) a)
+          (begin
+            (eval (car e) a)
+            (eval-begin-env (cdr e) a)))))
+
+(define (eval-if-env e a)
+  (if (eval (car e) a) (eval (cadr e) a)
+      (if (pair? (cddr e)) (eval (caddr e) a))))
+
+(define (sexp:define e a)
+  (if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
+      (cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
+
+(define (env:define a+ a)
+  (set-cdr! a+ (cdr a))
+  (set-cdr! a a+)
+  (set-cdr! (assq '*closure* a) a))
+
+(define (env:macro name+entry)
+  (cons
+   (cons (car name+entry)
+         (make-macro (car name+entry)
+                     (cdr name+entry)))
+   '()))
+
+;; boot into loop-0
+(cache-invalidate-range (current-module) '())
+()
+ignored
diff --git a/module/mes/mes.mes b/module/mes/mes.mes
deleted file mode 100644 (file)
index bb56be8..0000000
+++ /dev/null
@@ -1,232 +0,0 @@
-;;; -*-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 (assq x a)
-;;   ;;(stderr "assq x=~a\n" x)
-;;   ;;(debug "assq x=~a a=~a\n" x a)
-;;   (cond
-;;    ((null? a) #f)
-;;    ((eq? (caar a) x) (car a))
-;;    (#t (assq x (cdr a)))))
-
-;; ;; Page 13
-;; (define (eval-quote fn x)
-;;   ;(debug "eval-quote fn=~a x=~a" fn x)
-;;   (apply-env fn x '()))
-
-(define (evcon c a)
-  ;;(debug "evcon c=~a a=~a\n" c a)
-  (cond
-   ((null? c) *unspecified*)
-   ;; 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-env fn x a) 
-  ;; (display 'mes-apply-env:)
-  ;; (newline)
-  ;; (display 'fn:)
-  ;; (display fn)
-  ;; (newline)
-  ;; (display 'builtin:)
-  ;; (display (builtin? fn))
-  ;; (newline)
-  ;; (display 'x:)
-  ;; (display x)
-  ;; (newline)
-  (cond
-   ((atom? fn)
-    (cond
-     ((eq? fn 'current-module)
-      (c:apply-env current-module '() a))
-     ((eq? fn 'call-with-values)
-      (c:apply-env 'call-with-values x a))
-     ((builtin? fn)
-      (call fn x))
-     (#t (apply-env (eval fn a) x a))))
-   ((eq? (car fn) 'lambda)
-    (begin-env (cddr fn) (pairlis (cadr fn) x a)))
-   ((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn)
-                                                         (caddr fn)) a)))))
-
-(define (begin-env body a)
-  (cond ((null? body) *unspecified*)
-        ((null? (cdr body)) (eval (car body) a))
-        (#t (eval (car body) a)
-            (begin-env (cdr body) a))))
-
-(define (set-env! x e a)
-  (set-cdr! (assq x a) e))
-
-(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
-   ((eq? e #t) #t)
-   ((eq? e #f) #f)
-   ((char? e) e)
-   ((number? e) e)
-   ((string? e) e)
-   ((vector? e) e)
-   ((atom? e) (cdr (assq e a)))
-   ((builtin? e) e)
-   ((atom? (car e))
-    (cond
-     ((eq? (car e) 'quote) (cadr e))
-     ((eq? (car e) 'lambda) e)
-     ((eq? (car e) 'set!) (set-env! (cadr e) (caddr e) a))
-     ((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? (assq (car e) (cdr (assq '*macro* a))))
-      (c:eval
-       (c:apply-env
-        (cdr (assq (car e) (cdr (assq '*macro* a))))
-        (cdr e)
-        a)
-       a))
-     (#t (apply-env (car e) (evlis (cdr e) a) a))))
-   (#t (apply-env (car e) (evlis (cdr e) a) a))))
-
-(define (eval-quasiquote e 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) '()))
-        (#t (cons (car e) (eval-quasiquote (cdr e) a)))))
-
-;; readenv et al works, but slows down dramatically
-(define (DISABLED-readenv a)
-  (readword (read-char) '() 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 (read-char) w a))
-               ;; DOT ((eq? w '(*dot*)) (car (readword (read-char) '() a)))
-               (#t (lookup w a))))
-        ((eq? c 32) ;; \space
-         (readword 10 w a))
-        ((eq? c 40) ;; (
-         (cond ((eq? w '()) (readlist a))
-               (#t (unread-char c) (lookup w a))))
-        ((eq? c 41) ;; )
-         (cond ((eq? w '()) (unread-char c) w)
-               (#t (unread-char c) (lookup w a))))
-        ((eq? c 39) ;; '
-         (cond ((eq? w '())
-                (cons (lookup (cons c '()) a)
-                      (cons (readword (read-char) w a) '())))
-               (#t (unread-char c) (lookup w a))))
-        ((eq? c 59) ;; ;
-         (readcomment c)
-         (readword 10 w a))
-        ((eq? c 35) ;; #
-         (cond ((eq? (peek-char) 33) ;; !
-                (read-char)
-                (readblock (read-char))
-                (readword 10 w a))
-               ;; TODO: char, vector
-               (#t (readword (read-char) (append w (cons c '())) a))))
-        (#t (readword (read-char) (append w (cons c '())) a))))
-
-(define (readblock c)
-  ;; (display 'mes-readblock:)
-  ;; (display c)
-  ;; (newline)
-  (cond ((eq? c 33) (cond ((eq? (peek-char) 35) (read-char))
-                         (#t (readblock (read-char)))))
-        (#t (readblock (read-char)))))
-
-(define (eat-whitespace)
-  (cond ((eq? (peek-char) 10) (read-char) (eat-whitespace))
-        ((eq? (peek-char) 32) (read-char) (eat-whitespace))
-        ((eq? (peek-char) 35) (read-char) (eat-whitespace))
-        (#t #t)))
-
-(define (readlist a)
-  ;; (display 'mes-readlist:)
-  ;; (newline)
-  (eat-whitespace)
-  (cond ((eq? (peek-char) 41) ;; )
-         (read-char)
-         '())
-        ;; TODO *dot*
-        (#t (cons (readword (read-char) '() a) (readlist a)))))
-
-(define (readcomment c)
-  (cond ((eq? c 10) ;; \n
-         c)
-        (#t (readcomment (read-char)))))