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