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