build: Update Guix build and install.
[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 const *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 //MINI_MES
174 // char const*
175 // string_to_cstring (SCM s)
176 // {
177 //   static char buf[1024];
178 //   char *p = buf;
179 //   s = STRING (s);
180 //   while (s != cell_nil)
181 //     {
182 //       *p++ = VALUE (car (s));
183 //       s = cdr (s);
184 //     }
185 //   *p = 0;
186 //   return buf;
187 // }
188
189 // SCM
190 // error (SCM key, SCM x)
191 // {
192 //   SCM throw;
193 //   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
194 //     return apply (throw, cons (key, cons (x, cell_nil)), r0);
195 //   assert (!"error");
196 // }
197
198 SCM
199 assert_defined (SCM x, SCM e) ///((internal))
200 {
201   if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
202   return e;
203 }
204
205 SCM
206 check_formals (SCM f, SCM formals, SCM args) ///((internal))
207 {
208   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
209   int alen = VALUE (length (args));
210   if (alen != flen && alen != -1 && flen != -1)
211     {
212       char buf[1024];
213       sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
214       SCM e = MAKE_STRING (cstring_to_list (buf));
215       return error (cell_symbol_wrong_number_of_args, cons (e, f));
216     }
217   return cell_unspecified;
218 }
219
220 SCM
221 check_apply (SCM f, SCM e) ///((internal))
222 {
223   char const* type = 0;
224   if (f == cell_f || f == cell_t) type = "bool";
225   if (f == cell_nil) type = "nil";
226   if (f == cell_unspecified) type = "*unspecified*";
227   if (f == cell_undefined) type = "*undefined*";
228   if (TYPE (f) == TCHAR) type = "char";
229   if (TYPE (f) == TNUMBER) type = "number";
230   if (TYPE (f) == TSTRING) type = "string";
231
232   if (type)
233     {
234       char buf[1024];
235       sprintf (buf, "cannot apply: %s:", type);
236       fprintf (stderr, " [");
237       display_error_ (e);
238       fprintf (stderr, "]\n");
239       SCM e = MAKE_STRING (cstring_to_list (buf));
240       return error (cell_symbol_wrong_type_arg, cons (e, f));
241     }
242   return cell_unspecified;
243 }
244
245 char const*
246 itoa (int x)
247 {
248   static char buf[10];
249   char *p = buf+9;
250   *p-- = 0;
251
252   int sign = x < 0;
253   if (sign)
254     x = -x;
255   
256   do
257     {
258       *p-- = '0' + (x % 10);
259       x = x / 10;
260     } while (x);
261
262   if (sign)
263     *p-- = '-';
264
265   return p+1;
266 }
267
268 //FILE *g_stdin;
269 int
270 dump ()
271 {
272   fputs ("program r2=", stderr);
273   display_error_ (r2);
274   fputs ("\n", stderr);
275
276   r1 = g_symbols;
277   gc_push_frame ();
278   gc ();
279   gc_peek_frame ();
280   char *p = (char*)g_cells;
281   fputc ('M', stdout);
282   fputc ('E', stdout);
283   fputc ('S', stdout);
284   fputc (g_stack >> 8, stdout);
285   fputc (g_stack % 256, stdout);
286   // See HACKING, simple crafted dump for tiny-mes.c
287   if (getenv ("MES_TINY"))
288     {
289       TYPE (9) = 0x2d2d2d2d;
290       CAR (9) = 0x2d2d2d2d;
291       CDR (9) = 0x3e3e3e3e;
292
293       TYPE (10) = TPAIR;
294       CAR (10) = 11;
295       CDR (10) = 12;
296
297       TYPE (11) = TCHAR;
298       CAR (11) = 0x58585858;
299       CDR (11) = 65;
300
301       TYPE (12) = TPAIR;
302       CAR (12) = 13;
303       CDR (12) = 1;
304
305       TYPE (13) = TCHAR;
306       CAR (11) = 0x58585858;
307       CDR (13) = 66;
308
309       TYPE (14) = 0x3c3c3c3c;
310       CAR (14) = 0x2d2d2d2d;
311       CDR (14) = 0x2d2d2d2d;
312
313       g_free = 15;
314     }
315   for (int i=0; i<g_free * sizeof(struct scm); i++)
316     fputc (*p++, stdout);
317   return 0;
318 }
319
320 SCM
321 load_env (SCM a) ///((internal))
322 {
323   r0 = a;
324   g_stdin = open ("module/mes/read-0.mes", O_RDONLY);
325   g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mes", O_RDONLY);
326   if (!g_function) r0 = mes_builtins (r0);
327   r2 = read_input_file_env (r0);
328   g_stdin = STDIN;
329   return r2;
330 }
331
332 SCM
333 bload_env (SCM a) ///((internal))
334 {
335 #if MES_MINI
336   g_stdin = fopen ("module/mes/read-0-32.mo", O_RDONLY);
337 #else
338   g_stdin = open ("module/mes/read-0.mo", O_RDONLY);
339   g_stdin = g_stdin >= 0 ? g_stdin : open (MODULEDIR "mes/read-0.mo", O_RDONLY);
340 #endif
341
342   char *p = (char*)g_cells;
343   assert (getchar () == 'M');
344   assert (getchar () == 'E');
345   assert (getchar () == 'S');
346   g_stack = getchar () << 8;
347   g_stack += getchar ();
348   int c = getchar ();
349   while (c != EOF)
350     {
351       *p++ = c;
352       c = getchar ();
353     }
354   g_free = (p-(char*)g_cells) / sizeof (struct scm);
355   gc_peek_frame ();
356   g_symbols = r1;
357   g_stdin = STDIN;
358   r0 = mes_builtins (r0);
359   return r2;
360 }
361
362 SCM
363 xassq (SCM x, SCM a) ///for speed in core only
364 {
365   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
366   return a != cell_nil ? CAR (a) : cell_f;
367 }