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