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