test: Add syntax tests.
[mes.git] / module / mes / read-0.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016,2017,2018 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 ;;; read-0.mes - bootstrap reader.  This file is read by a minimal
24 ;;; core reader.  It only supports s-exps and line-comments; quotes,
25 ;;; character literals, string literals cannot be used here.
26
27 ;;; Code:
28
29 (begin
30   (if %c-define
31       (begin
32         (define <cell:pair> 7)
33         (define (not x) (if x #f #t))
34         (define (pair? x) (eq? (core:type x) <cell:pair>))
35         (define (atom? x) (not (pair? x))))
36       (begin
37         ((lambda (a+ a)
38            (set-cdr! a+ (cdr a))
39            (set-cdr! a a+)
40            (set-cdr! (assq (quote *closure*) a) a+)
41            (car a+))
42          (cons (cons (quote env:define) #f) (list))
43          (current-module))
44
45         (set! env:define
46               (lambda (a+ a)
47                 (set-cdr! a+ (cdr a))
48                 (set-cdr! a a+)
49                 (set-cdr! (assq (quote *closure*) a) a+)
50                 (car a+)))
51
52         (env:define (cons (cons (quote <cell:macro>) 5) (list)) (current-module))
53         (env:define (cons (cons (quote <cell:pair>) 7) (list)) (current-module))
54         (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module))
55         (env:define (cons (cons (quote env:macro) #f) (list)) (current-module))
56         (env:define (cons (cons (quote cons*) #f) (list)) (current-module))
57         (env:define (cons (cons (quote not)
58                                 (lambda (x) (if x #f #t)))
59                           (list)) (current-module))
60         (env:define (cons (cons (quote pair?)
61                                 (lambda (x) (eq? (core:type x) <cell:pair>)))
62                           (list)) (current-module))
63         (env:define (cons (cons (quote atom?)
64                                 (lambda (x) (not (pair? x))))
65                           (list)) (current-module))
66
67         (set! sexp:define
68               (lambda (e a)
69                 (if (atom? (car (cdr e))) (cons (car (cdr e)) (core:eval (car (cdr (cdr e))) a))
70                     (cons (car (car (cdr e))) (core:eval (cons (quote lambda) (cons (cdr (car (cdr e))) (cdr (cdr e)))) a)))))
71
72         (set! env:macro
73               (lambda (name+entry)
74                 (cons
75                  (cons (car name+entry)
76                        (core:make-cell <cell:macro> (core:car (car name+entry)) (cdr name+entry)))
77                  (list))))
78
79         (set! cons*
80               (lambda (. rest)
81                 (if (null? (cdr rest)) (car rest)
82                     (cons (car rest) (core:apply cons* (cdr rest) (current-module))))))
83
84         (env:define
85          (env:macro
86           (sexp:define
87            (quote
88             (define-macro (define ARGS . BODY)
89               (cons* (quote env:define)
90                      (cons* (quote cons)
91                             (cons* (quote sexp:define)
92                                    (list (quote quote)
93                                          (cons (quote DEFINE) (cons ARGS BODY)))
94                                    (quote ((current-module))))
95                             (quote ((list))))
96                      (quote ((current-module))))))
97            (current-module))) (current-module))
98
99         (env:define
100          (env:macro
101           (sexp:define
102            (quote
103             (define-macro (define-macro ARGS . BODY)
104               (cons* (quote env:define)
105                      (list (quote env:macro)
106                            (cons* (quote sexp:define)
107                                   (list (quote quote)
108                                         (cons (quote DEFINE-MACRO) (cons ARGS BODY)))
109                                   (quote ((current-module)))))
110                      (quote ((current-module))))))
111            (current-module))) (current-module))))
112
113   (define <cell:character> 0)
114   (define <cell:keyword> 4)
115   (define <cell:string> 10)
116
117   (define (newline . rest) (core:display (list->string (list (integer->char 10)))))
118   (define (display x . rest) (if (null? rest) (core:display x)
119                                  (core:display-port x (car rest))))
120   
121   (define (list->symbol lst) (core:lookup-symbol lst))
122
123   (define (symbol->list s)
124     (core:car s))
125
126   (define (list->string lst)
127     (core:make-cell <cell:string> lst 0))
128
129   (define (integer->char x)
130     (core:make-cell <cell:character> 0 x))
131
132   (define (symbol->keyword s)
133     (core:make-cell <cell:keyword> (symbol->list s) 0))
134
135   (define-macro (defined? x)
136     (list (quote assq) x (quote (cdr (cdr (current-module))))))
137
138   (define-macro (cond . clauses)
139     (list (quote if) (pair? clauses)
140           (list (quote if) (car (car clauses))
141                 (if (pair? (cdr (car clauses)))
142                     (if (eq? (car (cdr (car clauses))) (quote =>))
143                         (append2 (cdr (cdr (car clauses))) (list (car (car clauses))))
144                         (list (cons (quote lambda) (cons (list) (car clauses)))))
145                     (list (cons (quote lambda) (cons (list) (car clauses)))))
146                 (if (pair? (cdr clauses))
147                     (cons (quote cond) (cdr clauses))))))
148
149   (define-macro (and . x)
150     (if (null? x) #t
151         (if (null? (cdr x)) (car x)
152             (list (quote if) (car x) (cons (quote and) (cdr x))
153                   #f))))
154
155   (define-macro (or . x)
156     (if (null? x) #f
157         (if (null? (cdr x)) (car x)
158             (list (list (quote lambda) (list (quote r))
159                         (list (quote if) (quote r) (quote r)
160                               (cons (quote or) (cdr x))))
161                   (car x)))))
162
163   (define (not x)
164     (if x #f #t))
165   
166   (define (map1 f lst)
167     (if (null? lst) (list)
168         (cons (f (car lst)) (map1 f (cdr lst)))))
169
170   (define (read)
171     (read-word (read-byte) (list) (current-module)))
172
173   (define (read-input-file)
174     (core:read-input-file-env (read-env (current-module)) (current-module)))
175
176   (if (not %c-reader)
177       (begin
178         (define (read-env a)
179           (read-word (read-byte) (list) a))
180
181         (define (read-input-file)
182           (define (helper x)
183             (if (null? x) x
184                 (cons x (helper (read)))))
185           (helper (read)))
186
187         (define (eat-whitespace c)
188           (cond
189            ((eq? c 32) (eat-whitespace (read-byte)))
190            ((eq? c 10) (eat-whitespace (read-byte)))
191            ((eq? c 9) (eat-whitespace (read-byte)))
192            ((eq? c 12) (eat-whitespace (read-byte)))
193            ((eq? c 13) (eat-whitespace (read-byte)))
194            ((eq? c 59) (begin (read-line-comment c)
195                               (eat-whitespace (read-byte))))
196            ((eq? c 35) (cond ((eq? (peek-byte) 33)
197                               (read-byte)
198                               (read-block-comment 33 (read-byte))
199                               (eat-whitespace (read-byte)))
200                              ((eq? (peek-byte) 59)
201                               (read-byte)
202                               (read-word (read-byte) (list) (list))
203                               (eat-whitespace (read-byte)))
204                              ((eq? (peek-byte) 124)
205                               (read-byte)
206                               (read-block-comment 124 (read-byte))
207                               (eat-whitespace (read-byte)))
208                              (#t (unread-byte 35))))
209            (#t (unread-byte c))))
210
211         (define (read-block-comment s c)
212           (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte)
213                             (read-block-comment s (read-byte)))
214               (read-block-comment s (read-byte))))
215
216         (define (read-line-comment c)
217           (if (eq? c 10) c
218               (read-line-comment (read-byte))))
219
220         (define (read-list a)
221           (eat-whitespace (read-byte))
222           (if (eq? (peek-byte) 41) (begin (read-byte) (list))
223               ((lambda (w)
224                  (if (eq? w *dot*) (car (read-list a))
225                      (cons w (read-list a))))
226                (read-word (read-byte) (list) a))))
227
228         (define (read-character)
229           (define (read-octal c p n)
230             (if (not (and (> p 47) (< p 56))) n
231                 (read-octal (read-byte) (peek-byte) (+ (ash n 3) (- p 48)))))
232
233           (define (read-name c p n)
234             (define (lookup-char n)
235               (cond ((assq n (quote ((*foe* . -1)
236                                      (lun . 0)
237                                      (mrala . 7)
238                                      (ecapskcab . 8)
239                                      (bat . 9)
240                                      (th . 9)
241                                      (enilwen . 10)
242                                      (batv . 11)
243                                      (egap . 12)
244                                      (nruter . 13)
245                                      (rc . 13)
246                                      (ecaps . 32)))) => cdr)
247                     (#t (error (quote char-not-supported) n))))
248             (if (not (or (eq? p 42) (and (> p 96) (< p 123)))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n))))
249                 (read-name (read-byte) (peek-byte) (cons (integer->char c) n))))
250
251           ((lambda (c p)
252              (cond ((and (> c 47) (< c 56) (> p 47) (< p 56))
253                     (integer->char (read-octal c p (- c 48))))
254                    ((and (or (= c 42) (and (> c 96) (< c 123)))
255                          (or (= p 42) (and (> p 96) (< p 123)))) (read-name c p (list)))
256                    (#t (integer->char c))))
257            (read-byte) (peek-byte)))
258
259         (define (read-hex)
260           (define (calc c)
261             (cond ((and (> c 64) (< c 71)) (+ (- c 65) 10))
262                   ((and (> c 96) (< c 103)) (+ (- c 97) 10))
263                   ((and (> c 47) (< c 58)) (- c 48))
264                   (#t 0)))
265           (define (read-hex c p s n)
266             (if (not (or (and (> p 64) (< p 71))
267                          (and (> p 96) (< p 103))
268                          (and (> p 47) (< p 58)))) (* s (+ (ash n 4) (calc c)))
269                          (read-hex (read-byte) (peek-byte) s (+ (ash n 4) (calc c)))))
270           ((lambda (c p)
271              (if (eq? c 45) (read-hex (read-byte) (peek-byte) -1 0)
272                  (read-hex c p 1 0)))
273            (read-byte) (peek-byte)))
274
275         (define (read-octal)
276           (define (read-octal c p s n)
277             (if (not (or (and (> p 47) (< p 56)))) (* s (+ (ash n 3) (- c 48)))
278                 (read-octal (read-byte) (peek-byte) s (+ (ash n 3) (- c 48)))))
279           ((lambda (c p)
280              (if (eq? c 45) (read-octal (read-byte) (peek-byte) -1 0)
281                  (read-octal c p 1 0)))
282            (read-byte) (peek-byte)))
283
284         (define (reader:read-string)
285           (define (append-char s c)
286             (append2 s (cons (integer->char c) (list))))
287           (define (reader:read-string c p s)
288             (cond
289              ((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
290               ((lambda (c)
291                  (reader:read-string (read-byte) (peek-byte) (append-char s c)))
292                (read-byte)))
293              ((and (eq? c 92) (eq? p 110))
294               (read-byte)
295               (reader:read-string (read-byte) (peek-byte) (append-char s 10)))
296              ((and (eq? c 92) (eq? p 116))
297               (read-byte)
298               (reader:read-string (read-byte) (peek-byte) (append-char s 9)))
299              ((eq? c 34) s)
300              ((eq? c -1) (error (quote EOF-in-string) (cons c s)))
301              (#t (reader:read-string (read-byte) (peek-byte) (append-char s c)))))
302           (list->string (reader:read-string (read-byte) (peek-byte) (list))))
303
304         (define (lookup w a)
305           (define (lookup-number c p s n)
306             (and (> c 47) (< c 58)
307                  (if (null? p) (* s (+ (* n 10) (- c 48)))
308                      (lookup-number (car p) (cdr p) s (+ (* n 10) (- c 48))))))
309           ((lambda (c p)
310              (or (cond ((and (> c 47) (< c 58)) (lookup-number c p 1 0))
311                        ((and (eq? c 45) (pair? p)) (lookup-number (car p) (cdr p) -1 0))
312                        (#t #f))
313                  (core:lookup-symbol (map1 integer->char w))))
314            (car w) (cdr w)))
315
316         (define (read-hash c w a)
317           (cond
318            ((eq? c 33) (begin (read-block-comment 33 (read-byte))
319                               (read-word (read-byte) w a)))
320            ((eq? c 124) (begin (read-block-comment 124 (read-byte))
321                                (read-word (read-byte) w a)))
322            ((eq? c 40) (list->vector (read-list a)))
323            ((eq? c 92) (read-character))
324            ((eq? c 111) (read-octal))
325            ((eq? c 120) (read-hex))
326            ((eq? c 44) (cond ((eq? (peek-byte) 64)
327                               (read-byte)
328                               (cons (quote unsyntax-splicing)
329                                     (cons (read-word (read-byte) w a) w)))
330                              (#t (cons (quote unsyntax)
331                                        (cons (read-word (read-byte) w a) w)))))
332            ((eq? c 39) (cons (quote syntax) (cons (read-word (read-byte) w a) w)))
333            ((eq? c 58) (symbol->keyword (read-word (read-byte) w a)))
334            ((eq? c 59) (begin (read-word (read-byte) w a)
335                               (read-word (read-byte) w a)))
336            ((eq? c 96) (cons (quote quasisyntax)
337                              (cons (read-word (read-byte) w a) w)))
338            (#t (read-word c (append2 w (cons 35 w)) a))))
339
340         (define (read-word c w a)
341           (cond
342            ((or (and (> c 96) (< c 123))
343                 (eq? c 45)
344                 (eq? c 63)
345                 (and (> c 47) (< c 58)))
346             (read-word (read-byte) (append2 w (cons c (list))) a))
347            ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
348            ((eq? c 40) (if (null? w) (read-list a)
349                            (begin (unread-byte c) (lookup w a))))
350            ((eq? c 41) (if (null? w) (quote *FOOBAR*)
351                            (begin (unread-byte c) (lookup w a))))
352            ((eq? c 34) (if (null? w) (reader:read-string)
353                            (begin (unread-byte c) (lookup w a))))
354            ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
355            ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a)))
356            ((eq? c 35) (read-hash (read-byte) w a))
357            ((eq? c 39) (if (null? w) (cons (quote quote)
358                                            (cons (read-word (read-byte) w a) (list)))
359                            (begin (unread-byte c) (lookup w a))))
360            ((eq? c 44) (cond
361                         ((eq? (peek-byte) 64)
362                          (begin (read-byte)
363                                 (cons
364                                  (quote unquote-splicing)
365                                  (cons (read-word (read-byte) w a) (list)))))
366                         (#t (cons (quote unquote)
367                                   (cons (read-word (read-byte) w a) (list))))))
368            ((eq? c 96) (cons (quote quasiquote) (cons (read-word (read-byte) w a) (list))))
369            ((eq? c 59) (read-line-comment c) (read-word 10 w a))
370            ((eq? c 9) (read-word 32 w a))
371            ((eq? c 12) (read-word 32 w a))
372            ((eq? c -1) (list))
373            (#t (read-word (read-byte) (append2 w (cons c (list))) a))))))
374
375   ((lambda (p)
376      (core:eval (cons (quote begin) p) (current-module)))
377    (read-input-file)))