Support non-nested #| |# comment.
[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                                   (cond ((eq? (peek-byte) 33)
78                                          (read-byte)
79                                          (read-block-comment 33 (read-byte))
80                                          (eat-whitespace))
81                                         ((eq? (peek-byte) 124)
82                                          (read-byte)
83                                          (read-block-comment 124 (read-byte))
84                                          (eat-whitespace))
85                                         (#t (unread-byte 35)))
86 ))))
87
88   (define (read-block-comment s c)
89     (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte)
90                       (read-block-comment s (read-byte)))
91         (read-block-comment s (read-byte))))
92
93   ;; (define (read-hex c)
94   ;;   (if (eq? c 10) c
95   ;;       (read-line-comment (read-byte))))
96
97   (define (read-line-comment c)
98     (if (eq? c 10) c
99         (read-line-comment (read-byte))))
100
101   (define (read-list a)
102     (eat-whitespace)
103     (if (eq? (peek-byte) 41) (begin (read-byte) (list))
104         ((lambda (w)
105            (if (eq? w *dot*) (car (read-list a))
106                (cons w (read-list a))))
107          (read-word (read-byte) (list) a))))
108
109   ;;(define (read-string))
110
111   (define (lookup-char c a)
112     (lookup (cons (integer->char c) (list)) a))
113
114   (define (read-word c w a)
115     (cond
116       ((eq? c -1) (list))
117       ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)
118                       (lookup w a)))
119       ((eq? c 12) (read-word 10 w a))
120       ((eq? c 32) (read-word 10 w a))
121       ((eq? c 34) (if (null? w) (read-string)
122                       (begin (unread-byte c) (lookup w a))))
123       ((eq? c 35) (cond
124                    ((eq? (peek-byte) 33) (begin (read-byte)
125                                                 (read-block-comment 33 (read-byte))
126                                                 (read-word (read-byte) w a)))
127                    ((eq? (peek-byte) 124) (begin (read-byte)
128                                                  (read-block-comment 124 (read-byte))
129                                                  (read-word (read-byte) w a)))
130                    ((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
131                    ((eq? (peek-byte) 92) (read-byte) (read-character))
132                    ((eq? (peek-byte) 120) (read-byte) (read-hex))
133                    ((eq? (peek-byte) 44)
134                     (read-byte)
135                     (cond ((eq? (peek-byte) 64)
136                            (read-byte)
137                            (cons (lookup (symbol->list (quote unsyntax-splicing)) a)
138                                  (cons (read-word (read-byte) w a) (list))))
139                           (#t
140                            (cons (lookup (symbol->list (quote unsyntax)) a)
141                                  (cons (read-word (read-byte) w a) (list))))))
142                    ((eq? (peek-byte) 39) (read-byte)
143                     (cons (lookup (cons (integer->char 35) (cons (integer->char 39) (list))) a)
144                           (cons (read-word (read-byte) w a) (list))))
145                    ((eq? (peek-byte) 59) (read-byte)
146                     (read-word (read-byte) w a)
147                     (read-word (read-byte) w a))
148                    ((eq? (peek-byte) 96) (read-byte)
149                     (cons (lookup (cons (integer->char 35) (cons (integer->char 96) (list))) a)
150                           (cons (read-word (read-byte) w a) (list))))
151                    (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
152       ((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
153                                       (cons (read-word (read-byte) w a) (list)))
154                       (begin (unread-byte c) (lookup w a))))
155       ((eq? c 40) (if (null? w) (read-list a)
156                       (begin (unread-byte c) (lookup w a))))
157       ((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
158                                       (cons (read-word (read-byte) w a) (list)))
159                       (begin (unread-byte c) (lookup w a))))
160       ((eq? c 44) (cond
161                    ((eq? (peek-byte) 64) (begin (read-byte)
162                                                 (cons
163                                                  (lookup (symbol->list (quote unquote-splicing)) a)
164                                                  (cons (read-word (read-byte) w a) (list)))))
165                    (#t (cons (lookup-char c a) (cons (read-word (read-byte) w a)
166                                                         (list))))))
167       ((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
168       ((eq? c 59) (read-line-comment c) (read-word 10 w a))
169       (#t (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
170
171   ((lambda (p)
172      ;;(display (quote scheme-program=)) (display p) (newline)
173      (begin-env p (current-module)))
174    (read-input-file)))