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