mescc: Mini-mes (gcc-compiled) runs read-0.mes.
[mes.git] / module / mes / mini-0.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; 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 ;;; bootstrap reader.  This file is read by a minimal core reader.  It
24 ;;; only supports s-exps and line-comments; quotes, character
25 ;;; literals, string literals cannot be used here.
26
27 ;;; Code:
28
29 (begin
30
31   (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 10))
32
33   ((lambda (a+ a)
34
35      ;; (write-byte (make-cell 0 0 48))
36      ;; (write-byte (make-cell 0 0 48))
37      ;; (write-byte (make-cell 0 0 48))
38      ;; (write-byte (make-cell 0 0 10))
39
40      (set-cdr! a+ (cdr a))
41      (set-cdr! a a+)
42      (set-cdr! (assq (quote *closure*) a) a+)
43      (car a+))
44    (cons (cons (quote env:define) #f) (list))
45    (current-module))
46
47   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 10))
48
49   (set! env:define
50         (lambda (a+ a)
51
52           ;; (write-byte (make-cell 0 0 48))
53           ;; (write-byte (make-cell 0 0 49))
54           ;; (write-byte (make-cell 0 0 48))
55           ;; (write-byte (make-cell 0 0 10))
56
57           (set-cdr! a+ (cdr a))
58           (set-cdr! a a+)
59           (set-cdr! (assq (quote *closure*) a) a+)
60           (car a+)))
61
62   (env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
63
64   ;; (core:display (quote cm:))
65   ;; (core:display <cell:macro>)
66   ;; (write-byte (make-cell 0 0 10))
67
68   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 50)) (write-byte (make-cell 0 0 10))
69
70   (env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
71
72   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 51)) (write-byte (make-cell 0 0 10))
73
74   (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
75
76   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 52)) (write-byte (make-cell 0 0 10))
77
78   (env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
79
80   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 53)) (write-byte (make-cell 0 0 10))
81
82   (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
83
84   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 54)) (write-byte (make-cell 0 0 10))
85
86   (env:define (cons (cons (quote not)
87                           (lambda (x) (if x #f #t)))
88                     (list)) (current-module))
89
90   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 55)) (write-byte (make-cell 0 0 10))
91
92
93   (env:define (cons (cons (quote pair?)
94                           (lambda (x) (eq? (core:type x) <cell:pair>)))
95                     (list)) (current-module))
96
97   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 56)) (write-byte (make-cell 0 0 10))
98
99
100   (env:define (cons (cons (quote atom?)
101                           (lambda (x) (not (pair? x))))
102                     (list)) (current-module))
103
104   ;; (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 57)) (write-byte (make-cell 0 0 10))
105
106
107   (set! sexp:define
108         (lambda (e a)
109
110           ;; (write-byte (make-cell 0 0 48))
111           ;; (write-byte (make-cell 0 0 57))
112           ;; (write-byte (make-cell 0 0 48))
113           ;; (write-byte (make-cell 0 0 10))
114
115           (if (atom? (cadr e)) (cons (cadr e) (core:eval (car (cddr e)) a))
116               (cons (car (cadr e)) (core:eval (cons (quote lambda) (cons (cdr (cadr e)) (cddr e))) a)))))
117
118   ;; (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 48)) (write-byte (make-cell 0 0 10))
119
120   (set! env:macro
121         (lambda (name+entry)
122
123           (write-byte (make-cell 0 0 49))
124           (write-byte (make-cell 0 0 48))
125           (write-byte (make-cell 0 0 48))
126           (write-byte (make-cell 0 0 10))
127
128
129           (cons
130            (cons (car name+entry)
131                  (make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
132            (list))))
133
134   ;; (core:display (quote yyy-XXXmacro-m:))
135   ;; (write-byte (make-cell 0 0 10))
136
137   ;; (core:display (quote macro-m:))
138   ;; (core:display (make-cell <cell:macro> core:display 1))
139   ;; (write-byte (make-cell 0 0 10))
140
141   ;; (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 10))
142
143   (set! cons*
144         (lambda (. rest)
145
146           ;; (write-byte (make-cell 0 0 49))
147           ;; (write-byte (make-cell 0 0 49))
148           ;; (write-byte (make-cell 0 0 48))
149           ;; (write-byte (make-cell 0 0 10))
150
151           ;; (core:display (quote rest:))
152           ;; (core:display rest)
153           ;; (write-byte (make-cell 0 0 10))
154
155           (if (null? (cdr rest)) (car rest)
156               (cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
157
158   (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 50)) (write-byte (make-cell 0 0 10))
159
160   (env:define
161    (env:macro
162     (sexp:define
163      (quote
164       (define-macro (define ARGS . BODY)
165
166         ;; (write-byte (make-cell 0 0 49))
167         ;; (write-byte (make-cell 0 0 50))
168         ;; (write-byte (make-cell 0 0 48))
169         ;; (write-byte (make-cell 0 0 10))
170
171         (cons* (quote env:define)
172                (cons* (quote cons)
173                       (cons* (quote sexp:define)
174                              (list (quote quote)
175                                    (cons (quote DEFINE) (cons ARGS BODY)))
176                              (quote ((current-module))))
177                       (quote ((list))))
178                (quote ((current-module))))))
179      (current-module))) (current-module))
180
181   (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 51)) (write-byte (make-cell 0 0 10))
182
183   (env:define
184    (env:macro
185     (sexp:define
186      (quote
187       (define-macro (define-macro ARGS . BODY)
188         (cons* (quote env:define)
189                (list (quote env:macro)
190                      (cons* (quote sexp:define)
191                             (list (quote quote)
192                                   (cons (quote DEFINE-MACRO) (cons ARGS BODY)))
193                             (quote ((current-module)))))
194                (quote ((current-module))))))
195      (current-module))) (current-module))
196
197   (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 52)) (write-byte (make-cell 0 0 10))
198   (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 52)) (write-byte (make-cell 0 0 10))
199
200   ;; (core:display (quote define:))
201   ;; (core:display define)
202   ;; (write-byte (make-cell 0 0 10))
203
204   (define <cell:character> 0)
205
206   ;; (core:display <cell:character>)
207   ;; (write-byte (make-cell 0 0 10))
208   ;; (write-byte (make-cell 0 0 49)) (write-byte (make-cell 0 0 53)) (write-byte (make-cell 0 0 10))
209
210   (define <cell:keyword> 4)
211   (define <cell:string> 10)
212
213   (define (newline . rest) (core:stderr (list->string (list (integer->char 10)))))
214   (define (display x . rest) (core:stderr x))
215
216   (define (list->symbol lst) (make-symbol lst))
217
218   (define (symbol->list s)
219     (core:car s))
220
221   (define (list->string lst)
222     (make-cell <cell:string> lst 0))
223
224   (define (integer->char x)
225     (make-cell <cell:character> 0 x))
226
227   (define (symbol->keyword s)
228     (make-cell <cell:keyword> (symbol->list s) 0))
229
230   (define (read)
231     (read-word (read-byte) (list) (current-module)))
232
233   (define (read-env a)
234     (read-word (read-byte) (list) a))
235
236   (define (read-input-file)
237     (define (helper x)
238       (if (null? x) x
239           (cons x (helper (read)))))
240     (helper (read)))
241
242   (define-macro (cond . clauses)
243     (list (quote if) (pair? clauses)
244           (list (quote if) (car (car clauses))
245                 (if (pair? (cdar clauses))
246                     (if (eq? (car (cdar clauses)) (quote =>))
247                         (append2 (cdr (cdar clauses)) (list (caar clauses)))
248                         (list (cons (quote lambda) (cons (list) (car clauses)))))
249                     (list (cons (quote lambda) (cons (list) (car clauses)))))
250                 (if (pair? (cdr clauses))
251                     (cons (quote cond) (cdr clauses))))))
252
253   (define (eat-whitespace c)
254     (cond
255      ((eq? c 32) (eat-whitespace (read-byte)))
256      ((eq? c 10) (eat-whitespace (read-byte)))
257      ((eq? c 9) (eat-whitespace (read-byte)))
258      ((eq? c 12) (eat-whitespace (read-byte)))
259      ((eq? c 13) (eat-whitespace (read-byte)))
260      ((eq? c 59) (begin (read-line-comment c)
261                         (eat-whitespace (read-byte))))
262      ((eq? c 35) (cond ((eq? (peek-byte) 33)
263                         (read-byte)
264                         (read-block-comment 33 (read-byte))
265                         (eat-whitespace (read-byte)))
266                        ((eq? (peek-byte) 59)
267                         (read-byte)
268                         (read-word (read-byte) (list) (list))
269                         (eat-whitespace (read-byte)))
270                        ((eq? (peek-byte) 124)
271                         (read-byte)
272                         (read-block-comment 124 (read-byte))
273                         (eat-whitespace (read-byte)))
274                        (#t (unread-byte 35))))
275      (#t (unread-byte c))))
276
277
278   (define (read-block-comment s c)
279     (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte)
280                       (read-block-comment s (read-byte)))
281         (read-block-comment s (read-byte))))
282
283   (define (read-line-comment c)
284     (if (eq? c 10) c
285         (read-line-comment (read-byte))))
286
287   (define (read-list a)
288     (eat-whitespace (read-byte))
289     (if (eq? (peek-byte) 41) (begin (read-byte) (list))
290         ((lambda (w)
291            (if (eq? w *dot*) (car (read-list a))
292                (cons w (read-list a))))
293          (read-word (read-byte) (list) a))))
294
295   (define-macro (and . x)
296     (if (null? x) #t
297         (if (null? (cdr x)) (car x)
298             (list (quote if) (car x) (cons (quote and) (cdr x))
299                   #f))))
300
301   (define-macro (or . x)
302     (if (null? x) #f
303         (if (null? (cdr x)) (car x)
304             (list (quote if) (car x) (car x)
305                   (cons (quote or) (cdr x))))))
306   (define (not x)
307     (if x #f #t))
308   
309   (define (read-character)
310     (define (read-octal c p n)
311       (if (not (and (> p 47) (< p 56))) n
312           (read-octal (read-byte) (peek-byte) (+ (ash n 3) (- p 48)))))
313
314     (define (read-name c p n)
315       (define (lookup-char n)
316         (cond ((assq n (quote ((*foe* . -1)
317                                (lun . 0)
318                                (mrala . 7)
319                                (ecapskcab . 8)
320                                (bat . 9)
321                                (enilwen . 10)
322                                (batv . 11)
323                                (egap . 12)
324                                (nruter . 13)
325                                (ecaps . 32)))) => cdr)
326               (#t (error (quote char-not-supported) n))))
327       (if (not (or (eq? p 42) (and (> p 96) (< p 123)))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
328           (read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
329
330     ((lambda (c p)
331        (cond ((and (> c 47) (< c 56) (> p 47) (< p 56))
332               (integer->char (read-octal c p (- c 48))))
333              ((and (or (= c 42) (and (> c 96) (< c 123)))
334                    (or (= p 42) (and (> p 96) (< p 123)))) (read-name c p (list)))
335              (#t (integer->char c))))
336      (read-byte) (peek-byte)))
337
338   (define (read-hex)
339     (define (calc c)
340       (cond ((and (> c 64) (< c 71)) (+ (- c 65) 10))
341             ((and (> c 96) (< c 103)) (+ (- c 97) 10))
342             ((and (> c 47) (< c 58)) (- c 48))
343             (#t 0)))
344     (define (read-hex c p n)
345       (if (not (or (and (> p 64) (< p 71))
346                    (and (> p 96) (< p 103))
347                    (and (> p 47) (< p 58)))) (+ (ash n 4) (calc c))
348                    (read-hex (read-byte) (peek-byte) (+ (ash n 4) (calc c)))))
349     ((lambda (c p)
350        (read-hex c p 0))
351      (read-byte) (peek-byte)))
352
353   (define (read-string)
354     (define (append-char s c)
355       (append2 s (cons (integer->char c) (list))))
356     (define (read-string c p s)
357       (cond
358        ((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
359         ((lambda (c)
360            (read-string (read-byte) (peek-byte) (append-char s c)))
361          (read-byte)))
362        ((and (eq? c 92) (eq? p 110))
363         (read-byte)
364         (read-string (read-byte) (peek-byte) (append-char s 10)))
365        ((eq? c 34) s)
366        ((eq? c -1) (error (quote EOF-in-string)))
367        (#t (read-string (read-byte) (peek-byte) (append-char s c)))))
368     (list->string (read-string (read-byte) (peek-byte) (list))))
369
370   (define (map1 f lst)
371     (if (null? lst) (list)
372         (cons (f (car lst)) (map1 f (cdr lst)))))
373
374   (define (lookup w a)
375     (core:lookup (map1 integer->char w) a))
376
377   (define (read-hash c w a)
378     (cond
379      ((eq? c 33) (begin (read-block-comment 33 (read-byte))
380                         (read-word (read-byte) w a)))
381      ((eq? c 124) (begin (read-block-comment 124 (read-byte))
382                          (read-word (read-byte) w a)))
383      ((eq? c 40) (list->vector (read-list a)))
384      ((eq? c 92) (read-character))
385      ((eq? c 120) (read-hex))
386      ((eq? c 44) (cond ((eq? (peek-byte) 64)
387                         (read-byte)
388                         (cons (quote unsyntax-splicing)
389                               (cons (read-word (read-byte) w a) w)))
390                        (#t (cons (quote unsyntax)
391                                  (cons (read-word (read-byte) w a) w)))))
392      ((eq? c 39) (cons (quote syntax) (cons (read-word (read-byte) w a) w)))
393      ((eq? c 58) (symbol->keyword (read-word (read-byte) w a)))
394      ((eq? c 59) (begin (read-word (read-byte) w a)
395                         (read-word (read-byte) w a)))
396      ((eq? c 96) (cons (quote quasisyntax)
397                        (cons (read-word (read-byte) w a) w)))
398      (#t (read-word c (append2 w (cons 35 w)) a))))
399     
400   (define (read-word c w a)
401
402      (write-byte (make-cell 0 0 66))
403      (write-byte (make-cell 0 0 66))
404      (write-byte (make-cell 0 0 58))
405      (write-byte c)
406      (write-byte (make-cell 0 0 10))
407
408     (cond
409      ((or (and (> c 96) (< c 123))
410           (eq? c 45)
411           (eq? c 63)
412           (and (> c 47) (< c 58)))
413       (read-word (read-byte) (append2 w (cons c (list))) a))
414      ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
415      ((eq? c 40) (if (null? w) (read-list a)
416                      (begin (unread-byte c) (lookup w a))))
417      ((eq? c 41) (if (null? w) (quote *FOOBAR*)
418                      (begin (unread-byte c) (lookup w a))))
419      ((eq? c 34) (if (null? w) (read-string)
420                      (begin (unread-byte c) (lookup w a))))
421      ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
422      ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
423      ((eq? c 35) (read-hash (read-byte) w a))
424      ((eq? c 39) (if (null? w) (cons (quote quote)
425                                      (cons (read-word (read-byte) w a) (list)))
426                      (begin (unread-byte c) (lookup w a))))
427      ((eq? c 44) (cond
428                   ((eq? (peek-byte) 64)
429                    (begin (read-byte)
430                           (cons
431                            (quote unquote-splicing)
432                            (cons (read-word (read-byte) w a) (list)))))
433                   (#t (cons (quote unquote)
434                             (cons (read-word (read-byte) w a) (list))))))
435      ((eq? c 96) (cons (quote quasiquote) (cons (read-word (read-byte) w a) (list))))
436      ((eq? c 59) (read-line-comment c) (read-word 10 w a))
437      ((eq? c 9) (read-word 32 w a))
438      ((eq? c 12) (read-word 32 w a))
439      ((eq? c -1) (list))
440      (#t (read-word (read-byte) (append2 w (cons c (list))) a))))
441
442   (write-byte (make-cell 0 0 65))
443   (write-byte (make-cell 0 0 66))
444   (write-byte (make-cell 0 0 67))
445   (write-byte (make-cell 0 0 10))
446
447   (core:display (quote bla-bla))
448   (write-byte (make-cell 0 0 10))
449
450   ((lambda (p)
451      ;;(core:display (quote here-we-go))
452      (write-byte (make-cell 0 0 65))
453      (write-byte (make-cell 0 0 65))
454      (write-byte (make-cell 0 0 65))
455      (write-byte (make-cell 0 0 65))
456      (write-byte (make-cell 0 0 10))
457
458      (core:display (quote blub-blub))
459      (write-byte (make-cell 0 0 10))
460
461      (write-byte (make-cell 0 0 112))
462      (write-byte (make-cell 0 0 58))
463      ;;(core:display (quote p:))
464      (core:display p)
465      (write-byte (make-cell 0 0 10))
466      (core:eval (cons (quote begin) p) (current-module)))
467    (read-input-file))
468   
469   ;;(read-input-file)
470
471 )