Speedup boot eval/apply.
[mes.git] / module / mes / mes-0.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; mes-0.mes: This file is part of Mes.
7 ;;;
8 ;;; Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; mes-0.mes - bootstrap into Scheme, re
24
25 ;;; When compiling mes.c with -DBOOT=1, eval/apply et al. are lacking
26 ;;; features wrt the fat-c variant, e.g., define and define-macro are
27 ;;; not available; instead label is supplied.  Before loading
28 ;;; boot-0.mes, loop-0.mes is loaded to provide a richer eval/apply.
29
30 ;;; This might enable moving more functionality from C to Scheme,
31 ;;; making the entirely-from-source bootstrap process more feasible.
32 ;;; However, currently performance is 400x worse.  Also several tests
33 ;;; in the test suite fail and the REPL does not work yet.
34
35 ;;; Code:
36
37 (define-macro (cond . clauses)
38   (list 'if (null? clauses) *unspecified*
39         (if (null? (cdr clauses))
40             (list 'if (car (car clauses))
41                   (list (cons 'lambda (cons '() (cons (car (car clauses)) (cdr (car clauses))))))
42                   *unspecified*)
43             (if (eq? (car (cadr clauses)) 'else)
44                 (list 'if (car (car clauses))
45                       (list (cons 'lambda (cons '() (car clauses))))
46                       (list (cons 'lambda (cons '() (cons *unspecified* (cdr (cadr clauses)))))))
47                 (list 'if (car (car clauses))
48                       (list (cons 'lambda (cons '() (car clauses))))
49                       (cons 'cond (cdr clauses)))))))
50
51 (define (map f l . r)
52   (if (null? l) '()
53       (if (null? r) (cons (f (car l)) (map f (cdr l)))
54           (if (null? (cdr r))
55               (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
56
57 (define-macro (simple-let bindings . rest)
58   (cons (cons 'lambda (cons (map car bindings) rest))
59         (map cadr bindings)))
60
61 (define-macro (let bindings . rest)
62   (cons 'simple-let (cons bindings rest)))
63
64 (define-macro (or . x)
65   (if (null? x) #f
66       (if (null? (cdr x)) (car x)
67           (list 'if (car x) (car x)
68                 (cons 'or (cdr x))))))
69
70 (define-macro (and . x)
71   (if (null? x) #t
72       (if (null? (cdr x)) (car x)
73           (list 'if (car x) (cons 'and (cdr x))
74                 #f))))
75
76 (define (not x)
77   (if x #f #t))
78
79 (define (evlis-env m a)
80   (cond
81    ((null? m) '())
82    ((not (pair? m)) (eval m a))
83    (#t (cons (eval (car m) a) (evlis-env (cdr m) a)))))
84
85 (define (evlis-env m a)
86   (if (null? m) '()
87       (if (not (pair? m)) (eval m a)
88           (cons (eval (car m) a) (evlis-env (cdr m) a)))))
89
90 (define (apply-env fn x a) 
91   (cond
92    ((atom? fn)
93     (cond
94      ((builtin? fn) (call fn x))
95      ((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
96      ((eq? fn 'current-module) a)
97      (#t (apply-env (eval fn a) x a))))
98    ((eq? (car fn) 'lambda)
99     (let ((p (pairlis (cadr fn) x a)))
100       (cache-invalidate-range p (cdr a))
101       (let ((r (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
102         (cache-invalidate-range p (cdr a))
103         r)))
104    ((eq? (car fn) '*closure*)
105     (let ((args (caddr fn))
106           (body (cdddr fn))
107           (a (cddr (cadr fn))))
108       (let ((p (pairlis args x a)))
109         (cache-invalidate-range p (cdr a))
110         (let ((r (eval-begin-env body (cons (cons '*closure* p) p))))
111           (cache-invalidate-range p (cdr a))
112           r))))
113    ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
114    (#t (apply-env (eval fn a) x a))))
115
116 (define (apply-env fn x a) 
117   (if (atom? fn) (if (builtin? fn) (call fn x)
118                      (if (eq? fn 'call-with-values) (c:apply-env 'call-with-values x a)
119                          (if (eq? fn 'current-module) a
120                              (apply-env (eval fn a) x a))))
121       (if (eq? (car fn) 'lambda)
122           ;; (let ((p (pairlis (cadr fn) x a)))
123           ;;   (cache-invalidate-range p (cdr a))
124           ;;   (let ((r (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
125           ;;     (cache-invalidate-range p (cdr a))
126           ;;     r))
127           ((lambda (p)
128              (cache-invalidate-range p (cdr a))
129              ((lambda (r)
130                 (cache-invalidate-range p (cdr a))
131                 r)
132               (eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
133            (pairlis (cadr fn) x a))
134           (if (eq? (car fn) '*closure*)
135               ;; (let ((args (caddr fn))
136               ;;       (body (cdddr fn))
137               ;;       (a (cddr (cadr fn))))
138               ;;   (let ((p (pairlis args x a)))
139               ;;     (cache-invalidate-range p (cdr a))
140               ;;     (let ((r (eval-begin-env body (cons (cons '*closure* p) p))))
141               ;;       (cache-invalidate-range p (cdr a))
142               ;;       r)))
143               ((lambda (a)
144                  ((lambda (p)
145                     (cache-invalidate-range p (cdr a))
146                     ((lambda (r)
147                        (cache-invalidate-range p (cdr a))
148                        r)
149                      (eval-begin-env (cdddr fn) (cons (cons '*closure* p) p))))
150                   (pairlis (caddr fn) x a)))
151                (cddr (cadr fn)))
152               
153               ;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
154               (apply-env (eval fn a) x a)))))
155
156 (define (eval-expand e a)
157   (cond
158    ((symbol? e) (assq-ref-cache e a))
159    ((atom? e) e)
160    ((atom? (car e))
161     (cond
162      ((eq? (car e) 'quote) (cadr e))
163      ((eq? (car e) 'syntax) (cadr e))
164      ((eq? (car e) 'begin) (eval-begin-env e a))
165      ((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
166      ((eq? (car e) '*closure*) e)
167      ((eq? (car e) 'if) (eval-if-env (cdr e) a))
168      ((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
169      ((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
170      ((eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a))
171      ((eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a))
172      ((eq? (car e) 'unquote) (eval (cadr e) a))
173      ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
174      (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
175    (#t (apply-env (car e) (evlis-env (cdr e) a) a))))
176
177 (define (eval-expand e a)
178   (if (symbol? e) (assq-ref-cache e a)
179       (if (atom? e) e
180           (if (atom? (car e))
181               (if (eq? (car e) 'quote) (cadr e)
182                   (if (eq? (car e) 'syntax) (cadr e)
183                       (if (eq? (car e) 'begin) (eval-begin-env e a)
184                           (if (eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a))
185                               (if (eq? (car e) '*closure*) e
186                                   (if (eq? (car e) 'if) (eval-if-env (cdr e) a)
187                                       (if (eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a)
188                                           (if (eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a)
189                                               (if (eq? (car e) 'set!) (set-env! (cadr e) (eval (caddr e) a) a)
190                                                   (if (eq? (car e) 'apply-env) (apply-env (eval (cadr e) a) (evlis-env (caddr e) a) a)
191                                                       (if (eq? (car e) 'unquote) (eval (cadr e) a)
192                                                           (if (eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a))
193                                                               (apply-env (car e) (evlis-env (cdr e) a) a)))))))))))))
194               (apply-env (car e) (evlis-env (cdr e) a) a)))))
195
196 (define (unquote x) (cons 'unquote x))
197 (define (unquote-splicing x) (cons 'quasiquote x))
198
199 (define %the-unquoters
200   (cons
201    (cons 'unquote unquote)
202    (cons (cons 'unquote-splicing unquote-splicing) '())))
203
204 (define (add-unquoters a)
205   (cons %the-unquoters a))
206
207 (define (eval e a)
208   (eval-expand (expand-macro-env e a) a))
209
210 (define (expand-macro-env e a)
211   (if (pair? e) ((lambda (macro)
212                    (if macro (expand-macro-env (apply-env macro (cdr e) a) a)
213                        e))
214                  (lookup-macro (car e) a))
215       e))
216
217 (define (eval-begin-env e a)
218   (if (null? e) *unspecified*
219       (if (null? (cdr e)) (eval (car e) a)
220           (begin
221             (eval (car e) a)
222             (eval-begin-env (cdr e) a)))))
223
224 (define (eval-if-env e a)
225   (if (eval (car e) a) (eval (cadr e) a)
226       (if (pair? (cddr e)) (eval (caddr e) a))))
227
228 (define (eval-quasiquote e a)
229   (cond ((null? e) e)
230         ((atom? e) e)
231         ((eq? (car e) 'unquote) (eval (cadr e) a))
232         ((and (pair? (car e))
233               (eq? (caar e) 'unquote-splicing))
234          (append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a)))
235         (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
236
237 (define (eval-quasiquote e a)
238   (if (null? e) e
239       (if (atom? e) e
240           (if (eq? (car e) 'unquote) (eval (cadr e) a)
241               (if (pair? (car e)) (if (eq? (caar e) 'unquote-splicing) (append2 (eval (cadar e) a) (eval-quasiquote (cdr e) a))
242                                       
243                                       (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))
244                   (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))))
245
246 (define (sexp:define e a)
247   (if (atom? (cadr e)) (cons (cadr e) (eval (caddr e) a))
248       (cons (caadr e) (eval (cons 'lambda (cons (cdadr e) (cddr e))) a))))
249
250 (define (env:define a+ a)
251   (set-cdr! a+ (cdr a))
252   (set-cdr! a a+)
253   (set-cdr! (assq '*closure* a) a))
254
255 (define (env:macro name+entry)
256   (cons
257    (cons (car name+entry)
258          (make-macro (car name+entry)
259                      (cdr name+entry)))
260    '()))
261
262 ;; boot into loop-0
263 (cache-invalidate-range (current-module) '())
264 ()
265 ignored