diff --git a/module/mes/loop-0.mes b/module/mes/loop-0.mes new file mode 100644 index 00000000..28977fe6 --- /dev/null +++ b/module/mes/loop-0.mes @@ -0,0 +1,192 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; 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 index bb56be81..00000000 --- a/module/mes/mes.mes +++ /dev/null @@ -1,232 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen -;;; -;;; 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 . - -;; 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)))))