core: Fix gc_up_arena for x86_64.
[mes.git] / src / reader.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4  *
5  * This file is part of Mes.
6  *
7  * 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  * 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 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 (getchar ());
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 = getchar ();
75   else if (c == '-' && isdigit (peekchar ()))
76     {
77       negative_p = 1;
78       c = getchar ();
79     }
80   while (isdigit (c))
81     {
82       buf[i++] = c;
83       n *= 10;
84       n += c - '0';
85       c = getchar ();
86     }
87   if (reader_end_of_word_p (c))
88     {
89       ungetchar (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 = getchar ();
98     }
99   ungetchar (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_ (getchar (), a);
119     case '(':
120       return reader_read_list (getchar (), a);
121     case  ')':
122       return cell_nil;
123     case '#':
124       return reader_read_hash (getchar (), a);
125     case '`':
126       return cons (cell_symbol_quasiquote,
127                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
128     case ',':
129       if (peekchar () == '@')
130         {
131           getchar ();
132           return cons (cell_symbol_unquote_splicing,
133                        cons (reader_read_sexp_ (getchar (), a), cell_nil));
134         }
135       return cons (cell_symbol_unquote,
136                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
137     case '\'':
138       return cons (cell_symbol_quote,
139                    cons (reader_read_sexp_ (getchar (), 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 = getchar ();
155   if (c == ';')
156     return reader_eat_whitespace (reader_read_line_comment (c));
157   if (c == '#' && (peekchar () == '!' || peekchar () == '|'))
158     {
159       c=getchar ();
160       reader_read_block_comment (c, getchar ());
161       return reader_eat_whitespace (getchar ());
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 (getchar (), a));
178   return cons (s, reader_read_list (getchar (), a));
179 }
180
181 SCM
182 read_env (SCM a)
183 {
184   return reader_read_sexp_ (getchar (), a);
185 }
186
187 SCM
188 reader_read_block_comment (int s, int c)
189 {
190   if (c == s && peekchar () == '#') return getchar ();
191   return reader_read_block_comment (s, getchar ());
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, getchar ());
201       return reader_read_sexp_ (getchar (), a);
202     case '|':
203       reader_read_block_comment (c, getchar ());
204       return reader_read_sexp_ (getchar (), a);
205     case 'f':
206       return cell_f;
207     case 't':
208       return cell_t;
209     case ',':
210       if (peekchar () == '@')
211         {
212           getchar ();
213           return cons (cell_symbol_unsyntax_splicing,
214                        cons (reader_read_sexp_ (getchar (), a),
215                              cell_nil));
216         }
217       return cons (cell_symbol_unsyntax,
218                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
219     case '\'':
220       return cons (cell_symbol_syntax,
221                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
222     case '`':
223       return cons (cell_symbol_quasisyntax,
224                    cons (reader_read_sexp_ (getchar (), a), cell_nil));
225     case ':':
226     return MAKE_KEYWORD (CAR (reader_read_sexp_ (getchar (), a)));
227     case 'o':
228       return reader_read_octal ();
229     case 'x':
230       return reader_read_hex ();
231     case '\\':
232       return reader_read_character ();
233     case '(':
234       return list_to_vector (reader_read_list (getchar (), a));
235     case ';':
236       reader_read_sexp_ (getchar (), a);
237       return reader_read_sexp_ (getchar (), a);
238     }
239   return reader_read_sexp_ (getchar (), a);
240 }
241
242 SCM
243 reader_read_sexp (SCM c, SCM s, SCM a)
244 {
245   return reader_read_sexp_ (VALUE (c), a);
246 }
247
248 SCM
249 reader_read_character ()
250 {
251   int c = getchar ();
252   if (c >= '0' && c <= '7'
253       && peekchar () >= '0' && peekchar () <= '7')
254     {
255       c = c - '0';
256       while (peekchar () >= '0' && peekchar () <= '7')
257         {
258           c <<= 3;
259           c += getchar () - '0';
260         }
261     }
262   else if (((c >= 'a' && c <= 'z')
263             || c == '*')
264            && ((peekchar () >= 'a' && peekchar () <= 'z')
265                || peekchar () == '*'))
266     {
267       char buf[10];
268       char *p = buf;
269       *p++ = c;
270       while ((peekchar () >= 'a' && peekchar () <= 'z')
271              || peekchar () == '*')
272         {
273           *p++ = getchar ();
274         }
275       *p = 0;
276       if (!strcmp (buf, "*eof*")) c = EOF;
277       else if (!strcmp (buf, "nul")) c = '\0';
278       else if (!strcmp (buf, "alarm")) c = '\a';
279       else if (!strcmp (buf, "backspace")) c = '\b';
280       else if (!strcmp (buf, "tab")) c = '\t';
281       else if (!strcmp (buf, "linefeed")) c = '\n';
282       else if (!strcmp (buf, "newline")) c = '\n';
283       else if (!strcmp (buf, "vtab")) c = '\v';
284       else if (!strcmp (buf, "page")) c = '\f';
285 #if 1 //__MESC__
286       //Nyacc bug
287       else if (!strcmp (buf, "return")) c = 13;
288       else if (!strcmp (buf, "esc")) c = 27;
289 #else
290       else if (!strcmp (buf, "return")) c = '\r';
291       //Nyacc crash else if (!strcmp (buf, "esc")) c = '\e';
292 #endif
293       else if (!strcmp (buf, "space")) c = ' ';
294
295 #if 1 // Nyacc uses old abbrevs
296       else if (!strcmp (buf, "bel")) c = '\a';
297       else if (!strcmp (buf, "bs")) c = '\b';
298       else if (!strcmp (buf, "ht")) c = '\t';
299       else if (!strcmp (buf, "vt")) c = '\v';
300
301 #if 1 //__MESC__
302       //Nyacc bug
303       else if (!strcmp (buf, "cr")) c = 13;
304 #else
305       else if (!strcmp (buf, "cr")) c = '\r';
306 #endif
307 #endif // Nyacc uses old abbrevs
308
309       else
310         {
311           eputs ("char not supported: ");
312           eputs (buf);
313           eputs ("\n");
314 #if !__MESC__
315           assert (!"char not supported");
316 #endif
317         }
318     }
319   return MAKE_CHAR (c);
320 }
321
322 SCM
323 reader_read_octal ()
324 {
325   int n = 0;
326   int c = peekchar ();
327   int s = 1;
328   if (c == '-') {s = -1;getchar (); c = peekchar ();}
329   while (c >= '0' && c <= '7')
330     {
331       n <<= 3;
332       n+= c - '0';
333       getchar ();
334       c = peekchar ();
335     }
336   return MAKE_NUMBER (s*n);
337 }
338
339 SCM
340 reader_read_hex ()
341 {
342   int n = 0;
343   int c = peekchar ();
344   int s = 1;
345   if (c == '-') {s = -1;getchar (); c = peekchar ();}
346   while ((c >= '0' && c <= '9')
347          || (c >= 'A' && c <= 'F')
348          || (c >= 'a' && c <= 'f'))
349     {
350       n <<= 4;
351       if (c >= 'a') n += c - 'a' + 10;
352       else if (c >= 'A') n += c - 'A' + 10;
353       else n+= c - '0';
354       getchar ();
355       c = peekchar ();
356     }
357   return MAKE_NUMBER (s*n);
358 }
359
360 SCM
361 reader_read_string ()
362 {
363   char buf[1024];
364   SCM lst = cell_nil;
365   int i = 0;
366   int c = getchar ();
367   while (1)
368     {
369       if (c == '"' || i > 1022)
370         {
371           buf[i] = 0;
372           lst = append2 (lst, string_to_list (buf, i));
373           i = 0;
374           if (c == '"')
375             break;
376         }
377       if (c == '\\')
378         {
379           int p = peekchar ();
380           if (p == '\\' || p == '"')
381             buf[i++] = getchar ();
382           else if (p == '0')
383             {
384               getchar ();
385               buf[i++] = '\0';
386             }
387           else if (p == 'a')
388             {
389               getchar ();
390               buf[i++] = '\a';
391             }
392           else if (p == 'b')
393             {
394               getchar ();
395               buf[i++] = '\b';
396             }
397           else if (p == 't')
398             {
399               getchar ();
400               buf[i++] = '\t';
401             }
402           else if (p == 'n')
403             {
404               getchar ();
405               buf[i++] = '\n';
406             }
407           else if (p == 'v')
408             {
409               getchar ();
410               buf[i++] = '\v';
411             }
412           else if (p == 'f')
413             {
414               getchar ();
415               buf[i++] = '\f';
416             }
417           else if (p == 'r')
418             {
419               getchar ();
420               //Nyacc bug
421               //buf[i++] = '\r';
422               buf[i++] = 13;
423             }
424           else if (p == 'e')
425             {
426               getchar ();
427               //buf[i++] = '\e';
428               buf[i++] = 27;
429             }
430         }
431 #if 0 // !__MESC__
432       else if (c == EOF)
433         assert (!"EOF in string");
434 #endif
435       else
436         buf[i++] = c;
437     c = getchar ();
438   }
439   return MAKE_STRING (lst);
440 }
441
442 int
443 dump ()
444 {
445   r1 = g_symbols;
446   gc_push_frame ();
447   gc ();
448   gc_peek_frame ();
449   char *p = (char*)g_cells;
450   putchar ('M');
451   putchar ('E');
452   putchar ('S');
453   putchar (g_stack >> 8);
454   putchar (g_stack % 256);
455   eputs ("dumping\n");
456   if (g_debug > 1)
457     {
458       eputs ("program r2=");
459       display_error_ (r2);
460       eputs ("\n");
461     }
462
463   for (int i=0; i<g_free * sizeof (struct scm); i++)
464     putchar (*p++);
465   return 0;
466 }