Support => in cond.
[mes.git] / module / mes / read-0.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2016 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 from Scheme.  Use
24 ;;;    ./mes --dump < module/mes/read-0.mes > read-0.mo
25 ;;; to read, garbage collect, and dump this reader; then
26 ;;;    ./mes --load < tests/gc-3.test
27 ;;; to use this reader to read and run the minimal gc-3.test
28 ;;; TODO: complete this reader, remove reader from C.
29
30 ;;; Code:
31
32 (begin
33
34   ;; (define car (make-function 'car 0))
35   ;; (define cdr (make-function 'cdr 1))
36   ;; (define cons (make-function 'cons 1))
37
38   ;; TODO:
39   ;; * use case/cond, expand
40   ;; * etc int/char?
41   ;; * lookup in Scheme
42   ;; * read characters, quote, strings
43
44   (define (read)
45     (read-word (read-byte) (list) (current-module)))
46
47   (define (read-env a)
48     (read-word (read-byte) (list) a))
49
50   (define (read-input-file)
51     (define (helper x)
52       (if (null? x) x
53           (cons x (helper (read)))))
54     (helper (read)))
55
56   (define-macro (cond . clauses)
57     (list 'if (pair? clauses)
58           (list 'if (car (car clauses))
59                 (if (pair? (cdar clauses))
60                     (if (eq? (cadar clauses) '=>)
61                         (append2 (cddar clauses) (list (caar clauses)))
62                         (list (cons 'lambda (cons '() (car clauses)))))
63                     (list (cons 'lambda (cons '() (car clauses)))))
64               (if (pair? (cdr clauses))
65                   (cons 'cond (cdr clauses))))))
66   
67   (define (eat-whitespace)
68     (cond
69      ((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
70      ((eq? (peek-byte) 10) (read-byte) (eat-whitespace))
71      ((eq? (peek-byte) 12) (read-byte) (eat-whitespace))
72      ((eq? (peek-byte) 13) (read-byte) (eat-whitespace))
73      ((eq? (peek-byte) 32) (read-byte) (eat-whitespace))
74      ((eq? (peek-byte) 59) (begin (read-line-comment (read-byte))
75                                   (eat-whitespace)))
76      ((eq? (peek-byte) 35) (begin (read-byte)
77                                   (if (eq? (peek-byte) 33) (begin (read-byte)
78                                                                   (read-block-comment (read-byte))
79                                                                   (eat-whitespace))
80                                       (unread-byte 35))))))
81
82   (define (read-block-comment c)
83     (if (eq? c 33) (if (eq? (peek-byte) 35) (read-byte)
84                        (read-block-comment (read-byte)))
85         (read-block-comment (read-byte))))
86
87   ;; (define (read-hex c)
88   ;;   (if (eq? c 10) c
89   ;;       (read-line-comment (read-byte))))
90
91   (define (read-line-comment c)
92     (if (eq? c 10) c
93         (read-line-comment (read-byte))))
94
95   (define (read-list a)
96     (eat-whitespace)
97     (if (eq? (peek-byte) 41) (begin (read-byte) (list))
98         ((lambda (w)
99            (if (eq? w *dot*) (car (read-list a))
100                (cons w (read-list a))))
101          (read-word (read-byte) (list) a))))
102
103   ;;(define (read-string))
104
105   (define (lookup-char c a)
106     (lookup (cons (integer->char c) (list)) a))
107
108   (define (read-word c w a)
109     (cond
110       ((eq? c -1) (list))
111       ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)
112                       (lookup w a)))
113       ((eq? c 12) (read-word 10 w a))
114       ((eq? c 32) (read-word 10 w a))
115       ((eq? c 34) (if (null? w) (read-string)
116                       (begin (unread-byte c) (lookup w a))))
117       ((eq? c 35) (cond
118                    ((eq? (peek-byte) 33) (begin (read-byte)
119                                                 (read-block-comment (read-byte))
120                                                 (read-word (read-byte) w a)))
121                    ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
122                    ((eq? (peek-byte) 92) (read-byte) (read-character))
123                    ((eq? (peek-byte) 120) (read-byte) (read-hex))
124                    ((eq? (peek-byte) 44)
125                     (read-byte)
126                     (cond ((eq? (peek-byte) 64)
127                            (read-byte)
128                            (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
129                                  (cons (read-word (read-byte) w a) (list))))
130                           (#t
131                            (cons (lookup (symbol->list (quote unsyntax)) a)
132                                  (cons (read-word (read-byte) w a) (list))))))
133                    ((eq? (peek-byte) 39) (read-byte)
134                     (cons (lookup (cons (integer->char 35) (cons (integer->char 39) (list))) a)
135                           (cons (read-word (read-byte) w a) (list))))
136                    ((eq? (peek-byte) 96) (read-byte)
137                     (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
138                           (cons (read-word (read-byte) w a) (list))))
139                    (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
140       ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
141                                       (cons (read-word (read-byte) w a) (list)))
142                       (begin (unread-byte c) (lookup w a))))
143       ((eq? c 40) (if (null? w) (read-list a)
144                       (begin (unread-byte c) (lookup w a))))
145       ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
146                                       (cons (read-word (read-byte) w a) (list)))
147                       (begin (unread-byte c) (lookup w a))))
148       ((eq? c 44) (cond
149                    ((eq? (peek-byte) 64) (begin (read-byte)
150                                                 (cons
151                                                  (lookup (symbol->list (quote unquote-splicing)) a)
152                                                  (cons (read-word (read-byte) w a) (list)))))
153                    (#t (cons (lookup-char c a) (cons (read-word (read-byte) w a)
154                                                         (list))))))
155       ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
156       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
157       (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
158
159   ((lambda (p)
160      ;;(display (quote scheme-program=)) (display p) (newline)
161      (begin-env p (current-module)))
162    (read-input-file)))