build: Resurrect --with-cheating.
[mes.git] / src / lib.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 "mes/lib.h"
22 #include "mes/mes.h"
23
24 #include <assert.h>
25 #include <stdlib.h>
26
27 int g_depth;
28
29 SCM
30 display_helper (SCM x, int cont, char *sep, int fd, int write_p)
31 {
32   fdputs (sep, fd);
33   if (g_depth == 0)
34     return cell_unspecified;
35   g_depth = g_depth - 1;
36
37   int t = TYPE (x);
38   if (t == TCHAR)
39     {
40       if (!write_p)
41         fdputc (VALUE (x), fd);
42       else
43         {
44           fdputs ("#", fd);
45           long v = VALUE (x);
46           if (v == '\0')
47             fdputs ("\\nul", fd);
48           else if (v == '\a')
49             fdputs ("\\alarm", fd);
50           else if (v == '\b')
51             fdputs ("\\backspace", fd);
52           else if (v == '\t')
53             fdputs ("\\tab", fd);
54           else if (v == '\n')
55             fdputs ("\\newline", fd);
56           else if (v == '\v')
57             fdputs ("\\vtab", fd);
58           else if (v == '\f')
59             fdputs ("\\page", fd);
60           //Nyacc bug
61           // else if (v == '\r') fdputs ("return", fd);
62           else if (v == 13)
63             fdputs ("\\return", fd);
64           else if (v == ' ')
65             fdputs ("\\space", fd);
66           else
67             {
68               if (v >= 32 && v <= 127)
69                 fdputc ('\\', fd);
70               fdputc (VALUE (x), fd);
71             }
72         }
73     }
74   else if (t == TCLOSURE)
75     {
76       fdputs ("#<closure ", fd);
77       SCM circ = CADR (x);
78       SCM name = CADR (circ);
79       SCM args = CAR (CDDR (x));
80       display_helper (CAR (name), 0, "", fd, 0);
81       fdputc (' ', fd);
82       display_helper (args, 0, "", fd, 0);
83       fdputs (">", fd);
84     }
85   else if (t == TMACRO)
86     {
87       fdputs ("#<macro ", fd);
88       display_helper (CDR (x), cont, "", fd, 0);
89       fdputs (">", fd);
90     }
91   else if (t == TVARIABLE)
92     {
93       fdputs ("#<variable ", fd);
94       display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
95       fdputs (">", fd);
96     }
97   else if (t == TNUMBER)
98     {
99       fdputs (itoa (VALUE (x)), fd);
100     }
101   else if (t == TPAIR)
102     {
103       if (!cont)
104         fdputs ("(", fd);
105       if (CAR (x) == cell_circular && CADR (x) != cell_closure)
106         {
107           fdputs ("(*circ* . ", fd);
108           int i = 0;
109           x = CDR (x);
110           while (x != cell_nil && i++ < 10)
111             {
112               fdisplay_ (CAAR (x), fd, write_p);
113               fdputs (" ", fd);
114               x = CDR (x);
115             }
116           fdputs (" ...)", fd);
117         }
118       else
119         {
120           if (x && x != cell_nil)
121             fdisplay_ (CAR (x), fd, write_p);
122           if (CDR (x) && TYPE (CDR (x)) == TPAIR)
123             display_helper (CDR (x), 1, " ", fd, write_p);
124           else if (CDR (x) && CDR (x) != cell_nil)
125             {
126               if (TYPE (CDR (x)) != TPAIR)
127                 fdputs (" . ", fd);
128               fdisplay_ (CDR (x), fd, write_p);
129             }
130         }
131       if (!cont)
132         fdputs (")", fd);
133     }
134   else if (t == TKEYWORD || t == TPORT || t == TSPECIAL || t == TSTRING || t == TSYMBOL)
135     {
136       if (t == TPORT)
137         {
138           fdputs ("#<port ", fd);
139           fdputs (itoa (PORT (x)), fd);
140           fdputs (" ", fd);
141           x = STRING (x);
142         }
143       if (t == TKEYWORD)
144         fdputs ("#:", fd);
145       if ((write_p && t == TSTRING) || t == TPORT)
146         fdputc ('"', fd);
147       char const *s = CSTRING (x);
148 #if 0
149       s += START (x);
150       size_t length = LEN (x);
151 #else
152       size_t length = LENGTH (x);
153 #endif
154       for (size_t i = 0; i < length; i++)
155         {
156           long v = write_p ? s[i] : -1;
157           if (v == '\0')
158             fdputs ("\\0", fd);
159           else if (v == '\a')
160             fdputs ("\\a", fd);
161           else if (v == '\b')
162             fdputs ("\\b", fd);
163           else if (v == '\t')
164             fdputs ("\\t", fd);
165           else if (v == '\v')
166             fdputs ("\\v", fd);
167           else if (v == '\n')
168             fdputs ("\\n", fd);
169           else if (v == '\f')
170             fdputs ("\\f", fd);
171 #if 1                           //__MESC__
172           //Nyacc bug
173           else if (v == 13)
174             fdputs ("\\r", fd);
175           else if (v == 27)
176             fdputs ("\\e", fd);
177 #else
178           //else if (v == '\r') fdputs ("\\r", fd);
179           //Nyacc crash
180           //else if (v == '\e') fdputs ("\\e", fd);
181 #endif
182           else if (v == '\\')
183             fdputs ("\\\\", fd);
184           else if (v == '"')
185             fdputs ("\\\"", fd);
186           else
187             fdputc (s[i], fd);
188         }
189       if ((write_p && t == TSTRING) || t == TPORT)
190         fdputc ('"', fd);
191       if (t == TPORT)
192         fdputs (">", fd);
193     }
194   else if (t == TREF)
195     fdisplay_ (REF (x), fd, write_p);
196   else if (t == TSTRUCT)
197     {
198       //SCM printer = STRUCT (x) + 1;
199       SCM printer = struct_ref_ (x, STRUCT_PRINTER);
200       if (TYPE (printer) == TREF)
201         printer = REF (printer);
202       if (TYPE (printer) == TCLOSURE || builtin_p (printer) == cell_t)
203         apply (printer, cons (x, cell_nil), r0);
204       else
205         {
206           fdputs ("#<", fd);
207           fdisplay_ (STRUCT (x), fd, write_p);
208           SCM t = CAR (x);
209           long size = LENGTH (x);
210           for (long i = 2; i < size; i++)
211             {
212               fdputc (' ', fd);
213               fdisplay_ (STRUCT (x) + i, fd, write_p);
214             }
215           fdputc ('>', fd);
216         }
217     }
218   else if (t == TVECTOR)
219     {
220       fdputs ("#(", fd);
221       SCM t = CAR (x);
222       for (long i = 0; i < LENGTH (x); i++)
223         {
224           if (i)
225             fdputc (' ', fd);
226           fdisplay_ (VECTOR (x) + i, fd, write_p);
227         }
228       fdputc (')', fd);
229     }
230   else
231     {
232       fdputs ("<", fd);
233       fdputs (itoa (t), fd);
234       fdputs (":", fd);
235       fdputs (itoa (x), fd);
236       fdputs (">", fd);
237     }
238   return 0;
239 }
240
241 SCM
242 display_ (SCM x)
243 {
244   g_depth = 5;
245   return display_helper (x, 0, "", __stdout, 0);
246 }
247
248 SCM
249 display_error_ (SCM x)
250 {
251   g_depth = 5;
252   return display_helper (x, 0, "", __stderr, 0);
253 }
254
255 SCM
256 display_port_ (SCM x, SCM p)
257 {
258   assert (TYPE (p) == TNUMBER);
259   return fdisplay_ (x, VALUE (p), 0);
260 }
261
262 SCM
263 write_ (SCM x)
264 {
265   g_depth = 5;
266   return display_helper (x, 0, "", __stdout, 1);
267 }
268
269 SCM
270 write_error_ (SCM x)
271 {
272   g_depth = 5;
273   return display_helper (x, 0, "", __stderr, 1);
274 }
275
276 SCM
277 write_port_ (SCM x, SCM p)
278 {
279   assert (TYPE (p) == TNUMBER);
280   return fdisplay_ (x, VALUE (p), 1);
281 }
282
283 SCM
284 fdisplay_ (SCM x, int fd, int write_p)  ///((internal))
285 {
286   g_depth = 5;
287   return display_helper (x, 0, "", fd, write_p);
288 }
289
290 SCM
291 exit_ (SCM x)                   ///((name . "exit"))
292 {
293   assert (TYPE (x) == TNUMBER);
294   exit (VALUE (x));
295 }
296
297 SCM
298 frame_printer (SCM frame)
299 {
300   fdputs ("#<", __stdout);
301   display_ (struct_ref_ (frame, 2));
302   fdputc (' ', __stdout);
303   fdputs ("procedure: ", __stdout);
304   display_ (struct_ref_ (frame, 3));
305   fdputc ('>', __stdout);
306 }
307
308 SCM
309 make_frame_type ()              ///((internal))
310 {
311   SCM record_type = cell_symbol_record_type;    // FIXME
312   SCM fields = cell_nil;
313   fields = cons (cell_symbol_procedure, fields);
314   fields = cons (fields, cell_nil);
315   fields = cons (cell_symbol_frame, fields);
316   return make_struct (record_type, fields, cell_unspecified);
317 }
318
319 SCM
320 make_frame (SCM stack, long index)
321 {
322   SCM frame_type = make_frame_type ();
323   long array_index = (STACK_SIZE - (index * FRAME_SIZE));
324   SCM procedure = g_stack_array[array_index + FRAME_PROCEDURE];
325   if (!procedure)
326     procedure = cell_f;
327   SCM values = cell_nil;
328   values = cons (procedure, values);
329   values = cons (cell_symbol_frame, values);
330   return make_struct (frame_type, values, cstring_to_symbol ("frame-printer"));
331 }
332
333 SCM
334 make_stack_type ()              ///((internal))
335 {
336   SCM record_type = cell_symbol_record_type;    // FIXME
337   SCM fields = cell_nil;
338   fields = cons (cstring_to_symbol ("frames"), fields);
339   fields = cons (fields, cell_nil);
340   fields = cons (cell_symbol_stack, fields);
341   return make_struct (record_type, fields, cell_unspecified);
342 }
343
344 SCM
345 make_stack (SCM stack)          ///((arity . n))
346 {
347   SCM stack_type = make_stack_type ();
348   long size = (STACK_SIZE - g_stack) / FRAME_SIZE;
349   SCM frames = make_vector__ (size);
350   for (long i = 0; i < size; i++)
351     {
352       SCM frame = make_frame (stack, i);
353       vector_set_x_ (frames, i, frame);
354     }
355   SCM values = cell_nil;
356   values = cons (frames, values);
357   values = cons (cell_symbol_stack, values);
358   return make_struct (stack_type, values, cell_unspecified);
359 }
360
361 SCM
362 stack_length (SCM stack)
363 {
364   SCM frames = struct_ref_ (stack, 3);
365   return vector_length (frames);
366 }
367
368 SCM
369 stack_ref (SCM stack, SCM index)
370 {
371   SCM frames = struct_ref_ (stack, 3);
372   return vector_ref (frames, index);
373 }
374
375 SCM
376 xassq (SCM x, SCM a)            ///for speed in core only
377 {
378   while (a != cell_nil && x != CDAR (a))
379     a = CDR (a);
380   return a != cell_nil ? CAR (a) : cell_f;
381 }
382
383 SCM
384 memq (SCM x, SCM a)
385 {
386   int t = TYPE (x);
387   if (t == TCHAR || t == TNUMBER)
388     {
389       SCM v = VALUE (x);
390       while (a != cell_nil && v != VALUE (CAR (a)))
391         a = CDR (a);
392     }
393   else if (t == TKEYWORD)
394     {
395       while (a != cell_nil && (TYPE (CAR (a)) != TKEYWORD || string_equal_p (x, CAR (a)) == cell_f))
396         a = CDR (a);
397     }
398   else
399     while (a != cell_nil && x != CAR (a))
400       a = CDR (a);
401   return a != cell_nil ? a : cell_f;
402 }
403
404 SCM
405 equal2_p (SCM a, SCM b)
406 {
407 equal2:
408   if (a == b)
409     return cell_t;
410   if (TYPE (a) == TPAIR && TYPE (b) == TPAIR)
411     {
412       if (equal2_p (CAR (a), CAR (b)) == cell_t)
413         {
414           a = CDR (a);
415           b = CDR (b);
416           goto equal2;
417         }
418       return cell_f;
419     }
420   if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
421     return string_equal_p (a, b);
422   if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
423     {
424       if (LENGTH (a) != LENGTH (b))
425         return cell_f;
426       for (long i = 0; i < LENGTH (a); i++)
427         {
428           SCM ai = VECTOR (a) + i;
429           SCM bi = VECTOR (b) + i;
430           if (TYPE (ai) == TREF)
431             ai = REF (ai);
432           if (TYPE (bi) == TREF)
433             bi = REF (bi);
434           if (equal2_p (ai, bi) == cell_f)
435             return cell_f;
436         }
437       return cell_t;
438     }
439   return eq_p (a, b);
440 }
441
442 SCM
443 last_pair (SCM x)
444 {
445   while (x != cell_nil && CDR (x) != cell_nil)
446     x = CDR (x);
447   return x;
448 }
449
450 SCM
451 pair_p (SCM x)
452 {
453   return TYPE (x) == TPAIR ? cell_t : cell_f;
454 }