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