mes: Allow tick as part of identifier.
[mes.git] / src / reader.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017,2018 Jan 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') return c;
46   return reader_read_line_comment (getchar ());
47 }
48
49 SCM reader_read_block_comment (int s, int c);
50 SCM read_hash (int c, SCM w, SCM a);
51 SCM reader_read_list (int c, SCM a);
52
53 SCM
54 reader_read_sexp_ (int c, SCM s, SCM a)
55 {
56   switch (c)
57     {
58     case ' ':
59       return reader_read_sexp_ ('\n', s, a);
60     case '\f':
61       return reader_read_sexp_ ('\n', s, a);
62     case '\t':
63       return reader_read_sexp_ ('\n', s, a);
64     case ';':
65       reader_read_line_comment (c);
66       return reader_read_sexp_ ('\n', s, a);
67     case '#':
68       return read_hash (getchar (), s, a);
69     case '`':
70       return cons (cell_symbol_quasiquote,
71                    cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
72     case ',':
73       if (peekchar () == '@')
74         {
75           getchar ();
76           return cons (cell_symbol_unquote_splicing,
77                        cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
78         }
79       return cons (cell_symbol_unquote,
80                    cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
81     default:
82       if (s == cell_nil)
83         switch (c)
84           {
85           case EOF:
86             return cell_nil;
87           case '\n':
88             return reader_read_sexp_ (getchar (), s, a);
89           case '(':
90             return reader_read_list (getchar (), a);
91           case ')':
92             ungetchar (c);
93             return cell_nil;
94           case '\'':
95             return cons (cell_symbol_quote,
96                          cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
97           case '"':
98             return reader_read_string ();
99           }
100       else
101         switch (c)
102           {
103           case EOF:
104             return reader_lookup_ (s, a);
105           case '\n':
106             if (CAR (s) == cell_dot && CDR (s) == cell_nil)
107               return cell_dot;
108             else
109               return reader_lookup_ (s, a);
110           case '(':
111             ungetchar (c);
112             return reader_lookup_ (s, a);
113           case  ')':
114             ungetchar (c);
115             return reader_lookup_ (s, a);
116           case '"':
117             ungetchar (c);
118             return reader_lookup_ (s, a);
119           }
120     }
121   return reader_read_sexp_ (getchar (),
122                             append2 (s, cons (MAKE_CHAR (c), cell_nil)), a);
123 }
124
125 int
126 eat_whitespace (int c)
127 {
128   while (c == ' ' || c == '\t' || c == '\n' || c == '\f') c = getchar ();
129   if (c == ';') return eat_whitespace (reader_read_line_comment (c));
130   if (c == '#' && (peekchar () == '!' || peekchar () == '|')) {c=getchar (); reader_read_block_comment (c, getchar ()); return eat_whitespace (getchar ());}
131   return c;
132 }
133
134 SCM
135 reader_read_list (int c, SCM a)
136 {
137   c = eat_whitespace (c);
138   if (c == ')') return cell_nil;
139   SCM s = reader_read_sexp_ (c, cell_nil, a);
140   if (s == cell_dot)
141     return car (reader_read_list (getchar (), a));
142   return cons (s, reader_read_list (getchar (), a));
143 }
144
145 SCM
146 read_env (SCM a)
147 {
148   return reader_read_sexp_ (getchar (), cell_nil, a);
149 }
150
151 SCM
152 reader_lookup_ (SCM s, SCM a)
153 {
154   if (isdigit (VALUE (car (s))) || (VALUE (car (s)) == '-' && cdr (s) != cell_nil)) {
155     SCM p = s;
156     int sign = 1;
157     if (VALUE (car (s)) == '-') {
158       sign = -1;
159       p = cdr (s);
160     }
161     int n = 0;
162     while (p != cell_nil && isdigit (VALUE (car (p)))) {
163       n *= 10;
164       n += VALUE (car (p)) - '0';
165       p = cdr (p);
166     }
167     if (p == cell_nil) return MAKE_NUMBER (n * sign);
168   }
169
170   return lookup_symbol_ (s);
171 }
172
173 SCM
174 reader_read_block_comment (int s, int c)
175 {
176   if (c == s && peekchar () == '#') return getchar ();
177   return reader_read_block_comment (s, getchar ());
178 }
179
180 SCM
181 read_hash (int c, SCM s, SCM a)
182 {
183   switch (c)
184     {
185     case '!':
186       reader_read_block_comment (c, getchar ());
187       return reader_read_sexp_ (getchar (), s, a);
188     case '|':
189       reader_read_block_comment (c, getchar ());
190       return reader_read_sexp_ (getchar (), s, a);
191     case 'f':
192       return cell_f;
193     case 't':
194       return cell_t;
195     case ',':
196       if (peekchar () == '@')
197         {
198           getchar ();
199           return cons (cell_symbol_unsyntax_splicing,
200                        cons (reader_read_sexp_ (getchar (), s, a),
201                              cell_nil));
202         }
203       return cons (cell_symbol_unsyntax,
204                    cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
205     case '\'':
206       return cons (cell_symbol_syntax,
207                    cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
208     case '`':
209       return cons (cell_symbol_quasisyntax,
210                    cons (reader_read_sexp_ (getchar (), s, a), cell_nil));
211     case ':':
212     return MAKE_KEYWORD (CAR (reader_read_sexp_ (getchar (), cell_nil, a)));
213     case 'o':
214       return reader_read_octal ();
215     case 'x':
216       return reader_read_hex ();
217     case '\\':
218       return reader_read_character ();
219     case '(':
220       return list_to_vector (reader_read_list (getchar (), a));
221     case ';':
222       reader_read_sexp_ (getchar (), s, a);
223       return reader_read_sexp_ (getchar (), s, a);
224     }
225   return reader_read_sexp_ (getchar (),
226                             append2 (s, cons (MAKE_CHAR (c), cell_nil)), a);
227 }
228
229 SCM
230 reader_read_sexp (SCM c, SCM s, SCM a)
231 {
232   return reader_read_sexp_ (VALUE (c), s, a);
233 }
234
235 SCM
236 reader_read_character ()
237 {
238   int c = getchar ();
239   if (c >= '0' && c <= '7'
240       && peekchar () >= '0' && peekchar () <= '7')
241     {
242       c = c - '0';
243       while (peekchar () >= '0' && peekchar () <= '7')
244         {
245           c <<= 3;
246           c += getchar () - '0';
247         }
248     }
249   else if (((c >= 'a' && c <= 'z')
250             || c == '*')
251            && ((peekchar () >= 'a' && peekchar () <= 'z')
252                || peekchar () == '*'))
253     {
254       char buf[10];
255       char *p = buf;
256       *p++ = c;
257       while ((peekchar () >= 'a' && peekchar () <= 'z')
258              || peekchar () == '*')
259         {
260           *p++ = getchar ();
261         }
262       *p = 0;
263       if (!strcmp (buf, "*eof*")) c = EOF;
264       else if (!strcmp (buf, "nul")) c = '\0';
265       else if (!strcmp (buf, "alarm")) c = '\a';
266       else if (!strcmp (buf, "backspace")) c = '\b';
267       else if (!strcmp (buf, "tab")) c = '\t';
268       else if (!strcmp (buf, "linefeed")) c = '\n';
269       else if (!strcmp (buf, "newline")) c = '\n';
270       else if (!strcmp (buf, "vtab")) c = '\v';
271       else if (!strcmp (buf, "page")) c = '\f';
272 #if __MESC__
273       //Nyacc bug
274       else if (!strcmp (buf, "return")) c = 13;
275       else if (!strcmp (buf, "esc")) c = 27;
276 #else
277       else if (!strcmp (buf, "return")) c = '\r';
278       //Nyacc crash else if (!strcmp (buf, "esc")) c = '\e';
279 #endif
280       else if (!strcmp (buf, "space")) c = ' ';
281
282 #if 1 // Nyacc uses old abbrevs
283       else if (!strcmp (buf, "bel")) c = '\a';
284       else if (!strcmp (buf, "bs")) c = '\b';
285       else if (!strcmp (buf, "ht")) c = '\t';
286       else if (!strcmp (buf, "vt")) c = '\v';
287
288 #if __MESC__
289       //Nyacc bug
290       else if (!strcmp (buf, "cr")) c = 13;
291 #else
292       else if (!strcmp (buf, "cr")) c = '\r';
293 #endif
294 #endif // Nyacc uses old abbrevs
295
296       else
297         {
298           eputs ("char not supported: ");
299           eputs (buf);
300           eputs ("\n");
301 #if !__MESC__
302           assert (!"char not supported");
303 #endif
304         }
305     }
306   return MAKE_CHAR (c);
307 }
308
309 SCM
310 reader_read_octal ()
311 {
312   int n = 0;
313   int c = peekchar ();
314   int s = 1;
315   if (c == '-') {s = -1;getchar (); c = peekchar ();}
316   while (c >= '0' && c <= '7')
317     {
318       n <<= 3;
319       n+= c - '0';
320       getchar ();
321       c = peekchar ();
322     }
323   return MAKE_NUMBER (s*n);
324 }
325
326 SCM
327 reader_read_hex ()
328 {
329   int n = 0;
330   int c = peekchar ();
331   int s = 1;
332   if (c == '-') {s = -1;getchar (); c = peekchar ();}
333   while ((c >= '0' && c <= '9')
334          || (c >= 'A' && c <= 'F')
335          || (c >= 'a' && c <= 'f'))
336     {
337       n <<= 4;
338       if (c >= 'a') n += c - 'a' + 10;
339       else if (c >= 'A') n += c - 'A' + 10;
340       else n+= c - '0';
341       getchar ();
342       c = peekchar ();
343     }
344   return MAKE_NUMBER (s*n);
345 }
346
347 SCM
348 append_char (SCM x, int i)
349 {
350   return append2 (x, cons (MAKE_CHAR (i), cell_nil));
351 }
352
353 SCM
354 reader_read_string ()
355 {
356   SCM p = cell_nil;
357   int c = getchar ();
358   while (1) {
359     if (c == '"') break;
360     if (c == '\\' && peekchar () == '\\') p = append_char (p, getchar ());
361     else if (c == '\\' && peekchar () == '"') p = append_char (p, getchar ());
362     else if (c == '\\' && peekchar () == 'n') {getchar (); p = append_char (p, '\n');}
363     else if (c == '\\' && peekchar () == 't') {getchar (); p = append_char (p, '\t');}
364 #if !__MESC__
365     else if (c == EOF) assert (!"EOF in string");
366 #endif
367     else p = append_char (p, c);
368     c = getchar ();
369   }
370   return MAKE_STRING (p);
371 }
372
373 int g_tiny = 0;
374
375 int
376 dump ()
377 {
378   r1 = g_symbols;
379   gc_push_frame ();
380   gc ();
381   gc_peek_frame ();
382   char *p = (char*)g_cells;
383   putchar ('M');
384   putchar ('E');
385   putchar ('S');
386   putchar (g_stack >> 8);
387   putchar (g_stack % 256);
388   eputs ("dumping\n");
389   if (g_debug > 1)
390     {
391       eputs ("program r2=");
392       display_error_ (r2);
393       eputs ("\n");
394     }
395
396   for (int i=0; i<g_free * sizeof (struct scm); i++)
397     putchar (*p++);
398   return 0;
399 }