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