test: Enable vector read test.
[mes.git] / lib.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016,2017 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 //MINI_MES
22 // SCM
23 // length (SCM x)
24 // {
25 //   int n = 0;
26 //   while (x != cell_nil)
27 //     {
28 //       n++;
29 //       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
30 //       x = cdr (x);
31 //     }
32 //   return MAKE_NUMBER (n);
33 // }
34
35 SCM fdisplay_ (SCM,FILE*);
36
37 int g_depth;
38
39 SCM
40 display_helper (SCM x, int cont, char* sep, FILE *fd)
41 {
42   fputs (sep, fd);
43   if (g_depth == 0) return cell_unspecified;
44   g_depth = g_depth - 1;
45
46   switch (TYPE (x))
47     {
48     case TCHAR:
49       {
50         fputs ("#\\", fd);
51         putc (VALUE (x), fd);
52         break;
53       }
54     case TFUNCTION:
55       {
56         fputs ("#<procedure ", fd);
57         char *p = "?";
58         if (FUNCTION (x).name != 0)
59           p = FUNCTION (x).name;
60         fputs (p, fd);
61         fputs ("[", fd);
62         fputs (itoa (CDR (x)), fd);
63         fputs (",", fd);
64         fputs (itoa (x), fd);
65         fputs ("]>", fd);
66         break;
67       }
68     case TMACRO:
69       {
70         fputs ("#<macro ", fd);
71         display_helper (cdr (x), cont, "", fd);
72         fputs (">", fd);
73         break;
74       }
75     case TNUMBER:
76       {
77         fputs (itoa (VALUE (x)), fd);
78         break;
79       }
80     case TPAIR:
81       {
82         if (!cont) fputs ("(", fd);
83         if (x && x != cell_nil) fdisplay_ (CAR (x), fd);
84         if (CDR (x) && TYPE (CDR (x)) == TPAIR)
85           display_helper (CDR (x), 1, " ", fd);
86         else if (CDR (x) && CDR (x) != cell_nil)
87           {
88             if (TYPE (CDR (x)) != TPAIR)
89               fputs (" . ", fd);
90             fdisplay_ (CDR (x), fd);
91           }
92         if (!cont) fputs (")", fd);
93         break;
94       }
95     case TSPECIAL:
96 #if __NYACC__
97       // FIXME
98       //{}
99       {
100         SCM t = CAR (x);
101         while (t && t != cell_nil)
102           {
103             putc (VALUE (CAR (t)), fd);
104             t = CDR (t);
105           }
106         break;
107       }
108 #endif
109     case TSTRING:
110 #if __NYACC__
111       // FIXME
112       {
113         SCM t = CAR (x);
114         while (t && t != cell_nil)
115           {
116             putc (VALUE (CAR (t)), fd);
117             t = CDR (t);
118           }
119         break;
120       }
121 #endif
122     case TSYMBOL:
123       {
124         SCM t = CAR (x);
125         while (t && t != cell_nil)
126           {
127             putc (VALUE (CAR (t)), fd);
128             t = CDR (t);
129           }
130         break;
131       }
132     default:
133       {
134         fputs ("<", fd);
135         fputs (itoa (TYPE (x)), fd);
136         fputs (":", fd);
137         fputs (itoa (x), fd);
138         fputs (">", fd);
139         break;
140       }
141     }
142   return 0;
143 }
144
145 SCM
146 display_ (SCM x)
147 {
148   g_depth = 5;
149   return display_helper (x, 0, "", stdout);
150 }
151
152 SCM
153 display_error_ (SCM x)
154 {
155   g_depth = 5;
156   return display_helper (x, 0, "", stderr);
157 }
158
159 SCM
160 fdisplay_ (SCM x, FILE *fd) ///((internal))
161 {
162   g_depth = 5;
163   return display_helper (x, 0, "", fd);
164 }
165
166 SCM
167 exit_ (SCM x) ///((name . "exit"))
168 {
169   assert (TYPE (x) == TNUMBER);
170   exit (VALUE (x));
171 }
172
173 SCM
174 append (SCM x) ///((arity . n))
175 {
176   if (x == cell_nil) return cell_nil;
177   if (cdr (x) == cell_nil) return car (x);
178   return append2 (car (x), append (cdr (x)));
179 }
180
181 //MINI_MES
182 // char const*
183 // string_to_cstring (SCM s)
184 // {
185 //   static char buf[1024];
186 //   char *p = buf;
187 //   s = STRING (s);
188 //   while (s != cell_nil)
189 //     {
190 //       *p++ = VALUE (car (s));
191 //       s = cdr (s);
192 //     }
193 //   *p = 0;
194 //   return buf;
195 // }
196
197 // SCM
198 // error (SCM key, SCM x)
199 // {
200 //   SCM throw;
201 //   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
202 //     return apply (throw, cons (key, cons (x, cell_nil)), r0);
203 //   assert (!"error");
204 // }
205
206 SCM
207 assert_defined (SCM x, SCM e) ///((internal))
208 {
209   if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
210   return e;
211 }
212
213 SCM
214 check_formals (SCM f, SCM formals, SCM args) ///((internal))
215 {
216   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
217   int alen = VALUE (length (args));
218   if (alen != flen && alen != -1 && flen != -1)
219     {
220       char buf[1024];
221       sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
222       SCM e = MAKE_STRING (cstring_to_list (buf));
223       return error (cell_symbol_wrong_number_of_args, cons (e, f));
224     }
225   return cell_unspecified;
226 }
227
228 SCM
229 check_apply (SCM f, SCM e) ///((internal))
230 {
231   char const* type = 0;
232   if (f == cell_f || f == cell_t) type = "bool";
233   if (f == cell_nil) type = "nil";
234   if (f == cell_unspecified) type = "*unspecified*";
235   if (f == cell_undefined) type = "*undefined*";
236   if (TYPE (f) == TCHAR) type = "char";
237   if (TYPE (f) == TNUMBER) type = "number";
238   if (TYPE (f) == TSTRING) type = "string";
239
240   if (type)
241     {
242       char buf[1024];
243       sprintf (buf, "cannot apply: %s:", type);
244       fprintf (stderr, " [");
245       display_error_ (e);
246       fprintf (stderr, "]\n");
247       SCM e = MAKE_STRING (cstring_to_list (buf));
248       return error (cell_symbol_wrong_type_arg, cons (e, f));
249     }
250   return cell_unspecified;
251 }
252
253 char const*
254 itoa (int x)
255 {
256   static char buf[10];
257   char *p = buf+9;
258   *p-- = 0;
259
260   int sign = x < 0;
261   if (sign)
262     x = -x;
263   
264   do
265     {
266       *p-- = '0' + (x % 10);
267       x = x / 10;
268     } while (x);
269
270   if (sign)
271     *p-- = '-';
272
273   return p+1;
274 }
275
276 //FILE *g_stdin;
277 int
278 dump ()
279 {
280   fputs ("program r2=", stderr);
281   display_error_ (r2);
282   fputs ("\n", stderr);
283
284   r1 = g_symbols;
285   gc_push_frame ();
286   gc ();
287   gc_peek_frame ();
288   char *p = (char*)g_cells;
289   fputc ('M', stdout);
290   fputc ('E', stdout);
291   fputc ('S', stdout);
292   fputc (g_stack >> 8, stdout);
293   fputc (g_stack % 256, stdout);
294   // See HACKING, simple crafted dump for tiny-mes.c
295   if (getenv ("MES_TINY"))
296     {
297       TYPE (9) = 0x2d2d2d2d;
298       CAR (9) = 0x2d2d2d2d;
299       CDR (9) = 0x3e3e3e3e;
300
301       TYPE (10) = TPAIR;
302       CAR (10) = 11;
303       CDR (10) = 12;
304
305       TYPE (11) = TCHAR;
306       CAR (11) = 0x58585858;
307       CDR (11) = 65;
308
309       TYPE (12) = TPAIR;
310       CAR (12) = 13;
311       CDR (12) = 1;
312
313       TYPE (13) = TCHAR;
314       CAR (11) = 0x58585858;
315       CDR (13) = 66;
316
317       TYPE (14) = 0x3c3c3c3c;
318       CAR (14) = 0x2d2d2d2d;
319       CDR (14) = 0x2d2d2d2d;
320
321       g_free = 15;
322     }
323   for (int i=0; i<g_free * sizeof(struct scm); i++)
324     fputc (*p++, stdout);
325   return 0;
326 }
327
328 SCM
329 load_env (SCM a) ///((internal))
330 {
331   r0 = a;
332   g_stdin = fopen ("module/mes/read-0.mes", "r");
333   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r");
334   if (!g_function) r0 = mes_builtins (r0);
335   r2 = read_input_file_env (r0);
336   g_stdin = stdin;
337   return r2;
338 }
339
340 SCM
341 bload_env (SCM a) ///((internal))
342 {
343 #if MES_MINI
344   g_stdin = fopen ("module/mes/read-0-32.mo", "r");
345 #else
346   g_stdin = fopen ("module/mes/read-0.mo", "r");
347   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
348 #endif
349
350   char *p = (char*)g_cells;
351   assert (getchar () == 'M');
352   assert (getchar () == 'E');
353   assert (getchar () == 'S');
354   g_stack = getchar () << 8;
355   g_stack += getchar ();
356   int c = getchar ();
357   while (c != EOF)
358     {
359       *p++ = c;
360       c = getchar ();
361     }
362   g_free = (p-(char*)g_cells) / sizeof (struct scm);
363   gc_peek_frame ();
364   g_symbols = r1;
365   g_stdin = stdin;
366   r0 = mes_builtins (r0);
367   return r2;
368 }
369
370 SCM
371 xassq (SCM x, SCM a) ///for speed in core only
372 {
373   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
374   return a != cell_nil ? CAR (a) : cell_f;
375 }