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