build: Resurrect --with-cheating.
[mes.git] / src / reader.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * GNU Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  * Copyright © 2018 Jeremiah Orians <jeremiah@pdp10.guru>
5  *
6  * This file is part of GNU Mes.
7  *
8  * GNU 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  * GNU 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20  */
21
22 #include "mes/lib.h"
23 #include "mes/mes.h"
24
25 #include <assert.h>
26 #include <ctype.h>
27 #include <stdio.h>
28 #include <string.h>
29
30 SCM
31 read_input_file_env_ (SCM e, SCM a)
32 {
33   if (e == cell_nil)
34     return e;
35   return cons (e, read_input_file_env_ (read_env (a), a));
36 }
37
38 SCM
39 read_input_file_env (SCM a)
40 {
41   //r0 = a;
42   //return read_input_file_env_ (read_env (r0), r0);
43   return read_input_file_env_ (read_env (cell_nil), cell_nil);
44 }
45
46 int
47 reader_read_line_comment (int c)
48 {
49   while (c != EOF)
50     {
51       if (c == '\n')
52         return c;
53       c = readchar ();
54     }
55   error (cell_symbol_system_error, MAKE_STRING0 ("reader_read_line_comment"));
56 }
57
58 SCM reader_read_block_comment (int s, int c);
59 SCM reader_read_hash (int c, SCM a);
60 SCM reader_read_list (int c, SCM a);
61
62 int
63 reader_identifier_p (int c)
64 {
65   return (c > ' ' && c <= '~' && c != '"' && c != ';' && c != '(' && c != ')' && c != EOF);
66 }
67
68 int
69 reader_end_of_word_p (int c)
70 {
71   return (c == '"' || c == ';' || c == '(' || c == ')' || isspace (c) || c == EOF);
72 }
73
74 SCM
75 reader_read_identifier_or_number (int c)
76 {
77   int i = 0;
78   long n = 0;
79   int negative_p = 0;
80   if (c == '+' && isdigit (peekchar ()))
81     c = readchar ();
82   else if (c == '-' && isdigit (peekchar ()))
83     {
84       negative_p = 1;
85       c = readchar ();
86     }
87   while (isdigit (c))
88     {
89       g_buf[i++] = c;
90       n *= 10;
91       n += c - '0';
92       c = readchar ();
93     }
94   if (reader_end_of_word_p (c))
95     {
96       unreadchar (c);
97       if (negative_p)
98         n = 0 - n;
99       return MAKE_NUMBER (n);
100     }
101   /* Fallthrough: Note that `4a', `+1b' are identifiers */
102   while (!reader_end_of_word_p (c))
103     {
104       g_buf[i++] = c;
105       c = readchar ();
106     }
107   unreadchar (c);
108   g_buf[i] = 0;
109   return cstring_to_symbol (g_buf);
110 }
111
112 SCM
113 reader_read_sexp_ (int c, SCM a)
114 {
115 reset_reader:
116   if (c == EOF)
117     return cell_nil;
118   if (c == ';')
119     {
120       c = reader_read_line_comment (c);
121       goto reset_reader;
122     }
123   if ((c == ' ') || (c == '\t') || (c == '\n') || (c == '\f'))
124     {
125       c = readchar ();
126       goto reset_reader;
127     }
128   if (c == '(')
129     return reader_read_list (readchar (), a);
130   if (c == ')')
131     return cell_nil;
132   if (c == '#')
133     return reader_read_hash (readchar (), a);
134   if (c == '`')
135     return cons (cell_symbol_quasiquote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
136   if (c == ',')
137     {
138       if (peekchar () == '@')
139         {
140           readchar ();
141           return cons (cell_symbol_unquote_splicing, cons (reader_read_sexp_ (readchar (), a), cell_nil));
142         }
143       return cons (cell_symbol_unquote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
144     }
145   if (c == '\'')
146     return cons (cell_symbol_quote, cons (reader_read_sexp_ (readchar (), a), cell_nil));
147   if (c == '"')
148     return reader_read_string ();
149   if (c == '.' && (!reader_identifier_p (peekchar ())))
150     return cell_dot;
151   return reader_read_identifier_or_number (c);
152 }
153
154 int
155 reader_eat_whitespace (int c)
156 {
157   while (isspace (c))
158     c = readchar ();
159   if (c == ';')
160     return reader_eat_whitespace (reader_read_line_comment (c));
161   if (c == '#' && (peekchar () == '!' || peekchar () == '|'))
162     {
163       c = readchar ();
164       reader_read_block_comment (c, readchar ());
165       return reader_eat_whitespace (readchar ());
166     }
167   return c;
168 }
169
170 SCM
171 reader_read_list (int c, SCM a)
172 {
173   c = reader_eat_whitespace (c);
174   if (c == ')')
175     return cell_nil;
176   if (c == EOF)
177     error (cell_symbol_not_a_pair, MAKE_STRING0 ("EOF in list"));
178   //return cell_nil;
179   SCM s = reader_read_sexp_ (c, a);
180   if (s == cell_dot)
181     return CAR (reader_read_list (readchar (), a));
182   return cons (s, reader_read_list (readchar (), a));
183 }
184
185 SCM
186 read_env (SCM a)
187 {
188   return reader_read_sexp_ (readchar (), a);
189 }
190
191 SCM
192 reader_read_block_comment (int s, int c)
193 {
194   if (c == s && peekchar () == '#')
195     return readchar ();
196   return reader_read_block_comment (s, readchar ());
197 }
198
199 SCM
200 reader_read_hash (int c, SCM a)
201 {
202   if (c == '!')
203     {
204       reader_read_block_comment (c, readchar ());
205       return reader_read_sexp_ (readchar (), a);
206     }
207   if (c == '|')
208     {
209       reader_read_block_comment (c, readchar ());
210       return reader_read_sexp_ (readchar (), a);
211     }
212   if (c == 'f')
213     return cell_f;
214   if (c == 't')
215     return cell_t;
216   if (c == ',')
217     {
218       if (peekchar () == '@')
219         {
220           readchar ();
221           return cons (cell_symbol_unsyntax_splicing, cons (reader_read_sexp_ (readchar (), a), cell_nil));
222         }
223
224       return cons (cell_symbol_unsyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
225     }
226   if (c == '\'')
227     return cons (cell_symbol_syntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
228   if (c == '`')
229     return cons (cell_symbol_quasisyntax, cons (reader_read_sexp_ (readchar (), a), cell_nil));
230   if (c == ':')
231     {
232       SCM x = reader_read_identifier_or_number (readchar ());
233       SCM msg = MAKE_STRING0 ("keyword perifx ':' not followed by a symbol: ");
234       if (TYPE (x) == TNUMBER)
235         error (cell_symbol_system_error, cons (msg, x));
236       return symbol_to_keyword (x);
237     }
238   if (c == 'b')
239     return reader_read_binary ();
240   if (c == 'o')
241     return reader_read_octal ();
242   if (c == 'x')
243     return reader_read_hex ();
244   if (c == '\\')
245     return reader_read_character ();
246   if (c == '(')
247     return list_to_vector (reader_read_list (readchar (), a));
248   if (c == ';')
249     {
250       reader_read_sexp_ (readchar (), a);
251       return reader_read_sexp_ (readchar (), a);
252     }
253   return reader_read_sexp_ (readchar (), a);
254 }
255
256 SCM
257 reader_read_sexp (SCM c, SCM s, SCM a)
258 {
259   return reader_read_sexp_ (VALUE (c), a);
260 }
261
262 SCM
263 reader_read_character ()
264 {
265   int c = readchar ();
266   int p = peekchar ();
267   int i = 0;
268   if (c >= '0' && c <= '7' && p >= '0' && p <= '7')
269     {
270       c = c - '0';
271       while (p >= '0' && p <= '7')
272         {
273           c <<= 3;
274           c += readchar () - '0';
275           p = peekchar ();
276         }
277     }
278   else if (c == 'x' && ((p >= '0' && p <= '9') || (p >= 'a' && p <= 'f') || (p >= 'F' && p <= 'F')))
279     {
280       c = VALUE (reader_read_hex ());
281       eputs ("reading hex c=");
282       eputs (itoa (c));
283       eputs ("\n");
284     }
285   else if (((c >= 'a' && c <= 'z') || c == '*') && ((p >= 'a' && p <= 'z') || p == '*'))
286     {
287       char buf[10];
288       buf[i] = c;
289       i = i + 1;
290       while ((p >= 'a' && p <= 'z') || p == '*')
291         {
292           buf[i] = readchar ();
293           i = i + 1;
294           p = peekchar ();
295         }
296       buf[i] = 0;
297       if (!strcmp (buf, "*eof*"))
298         c = EOF;
299       else if (!strcmp (buf, "nul"))
300         c = '\0';
301       else if (!strcmp (buf, "alarm"))
302         c = '\a';
303       else if (!strcmp (buf, "backspace"))
304         c = '\b';
305       else if (!strcmp (buf, "tab"))
306         c = '\t';
307       else if (!strcmp (buf, "linefeed"))
308         c = '\n';
309       else if (!strcmp (buf, "newline"))
310         c = '\n';
311       else if (!strcmp (buf, "vtab"))
312         c = '\v';
313       else if (!strcmp (buf, "page"))
314         c = '\f';
315 #if 1                           //__MESC__
316       //Nyacc bug
317       else if (!strcmp (buf, "return"))
318         c = 13;
319       else if (!strcmp (buf, "esc"))
320         c = 27;
321 #else
322       else if (!strcmp (buf, "return"))
323         c = '\r';
324       //Nyacc crash else if (!strcmp (buf, "esc")) c = '\e';
325 #endif
326       else if (!strcmp (buf, "space"))
327         c = ' ';
328
329 #if 1                           // Nyacc uses old abbrevs
330       else if (!strcmp (buf, "bel"))
331         c = '\a';
332       else if (!strcmp (buf, "bs"))
333         c = '\b';
334       else if (!strcmp (buf, "ht"))
335         c = '\t';
336       else if (!strcmp (buf, "vt"))
337         c = '\v';
338
339 #if 1                           //__MESC__
340       //Nyacc bug
341       else if (!strcmp (buf, "cr"))
342         c = 13;
343 #else
344       else if (!strcmp (buf, "cr"))
345         c = '\r';
346 #endif
347 #endif // Nyacc uses old abbrevs
348
349       else
350         {
351           eputs ("char not supported: ");
352           eputs (buf);
353           eputs ("\n");
354           error (cell_symbol_system_error, MAKE_STRING0 ("char not supported"));
355         }
356     }
357   return MAKE_CHAR (c);
358 }
359
360 SCM
361 reader_read_binary ()
362 {
363   long n = 0;
364   int c = peekchar ();
365   int negative_p = 0;
366   if (c == '-')
367     {
368       negative_p = 1;
369       readchar ();
370       c = peekchar ();
371     }
372   while (c == '0' || c == '1')
373     {
374       n = n << 1;
375       n = n + c - '0';
376       readchar ();
377       c = peekchar ();
378     }
379   if (negative_p)
380     n = 0 - n;
381   return MAKE_NUMBER (n);
382 }
383
384 SCM
385 reader_read_octal ()
386 {
387   long n = 0;
388   int c = peekchar ();
389   int negative_p = 0;
390   if (c == '-')
391     {
392       negative_p = 1;
393       readchar ();
394       c = peekchar ();
395     }
396   while (c >= '0' && c <= '7')
397     {
398       n = n << 3;
399       n = n + c - '0';
400       readchar ();
401       c = peekchar ();
402     }
403   if (negative_p)
404     n = 0 - n;
405   return MAKE_NUMBER (n);
406 }
407
408 SCM
409 reader_read_hex ()
410 {
411   long n = 0;
412   int c = peekchar ();
413   int negative_p = 0;
414   if (c == '-')
415     {
416       negative_p = 1;
417       readchar ();
418       c = peekchar ();
419     }
420   while ((c >= '0' && c <= '9') || (c >= 'A' && c <= 'F') || (c >= 'a' && c <= 'f'))
421     {
422       n = n << 4;
423       if (c >= 'a')
424         n = n + c - 'a' + 10;
425       else if (c >= 'A')
426         n = n + c - 'A' + 10;
427       else
428         n = n + c - '0';
429       readchar ();
430       c = peekchar ();
431     }
432   if (negative_p)
433     n = 0 - n;
434   return MAKE_NUMBER (n);
435 }
436
437 SCM
438 reader_read_string ()
439 {
440   size_t i = 0;
441   int c;
442   do
443     {
444       if (i > MAX_STRING)
445         assert_max_string (i, "reader_read_string", g_buf);
446       c = readchar ();
447       if (c == '"')
448         break;
449       if (c == '\\')
450         {
451           c = readchar ();
452           if (c == '\\' || c == '"')
453             ;
454           else if (c == '0')
455             c = '\0';
456           else if (c == 'a')
457             c = '\a';
458           else if (c == 'b')
459             c = '\b';
460           else if (c == 't')
461             c = '\t';
462           else if (c == 'n')
463             c = '\n';
464           else if (c == 'v')
465             c = '\v';
466           else if (c == 'f')
467             c = '\f';
468           else if (c == 'r')
469             // Nyacc bug
470             // c = '\r';
471             c = 13;
472           else if (c == 'e')
473             // Nyacc bug
474             // c = '\e';
475             c = 27;
476           else if (c == 'x')
477             c = VALUE (reader_read_hex ());
478         }
479       g_buf[i++] = c;
480     }
481   while (1);
482   g_buf[i] = 0;
483   return make_string (g_buf, i);
484 }