core+mini-mes: Replace manual snippets by snarfed includes.
[mes.git] / lib.c
1 /* -*-comment-start: "//";comment-end:""-*-
2  * Mes --- Maxwell Equations of Software
3  * Copyright © 2016 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 SCM
22 xassq (SCM x, SCM a) ///for speed in core only
23 {
24   while (a != cell_nil && x != CDAR (a)) a = CDR (a);
25   return a != cell_nil ? CAR (a) : cell_f;
26 }
27
28 SCM
29 length (SCM x)
30 {
31   int n = 0;
32   while (x != cell_nil)
33     {
34       n++;
35       if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
36       x = cdr (x);
37     }
38   return MAKE_NUMBER (n);
39 }
40
41 SCM
42 list (SCM x) ///((arity . n))
43 {
44   return x;
45 }
46
47 SCM
48 exit_ (SCM x) ///((name . "exit"))
49 {
50   assert (TYPE (x) == TNUMBER);
51   exit (VALUE (x));
52 }
53
54 SCM
55 append (SCM x) ///((arity . n))
56 {
57   if (x == cell_nil) return cell_nil;
58   if (cdr (x) == cell_nil) return car (x);
59   return append2 (car (x), append (cdr (x)));
60 }
61
62 //MINI_MES
63 // char const*
64 // string_to_cstring (SCM s)
65 // {
66 //   static char buf[1024];
67 //   char *p = buf;
68 //   s = STRING (s);
69 //   while (s != cell_nil)
70 //     {
71 //       *p++ = VALUE (car (s));
72 //       s = cdr (s);
73 //     }
74 //   *p = 0;
75 //   return buf;
76 // }
77
78 SCM
79 error (SCM key, SCM x)
80 {
81   SCM throw;
82   if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
83     return apply (throw, cons (key, cons (x, cell_nil)), r0);
84   assert (!"error");
85 }
86
87 SCM
88 assert_defined (SCM x, SCM e)
89 {
90   if (e == cell_undefined) return error (cell_symbol_unbound_variable, x);
91   return e;
92 }
93
94 SCM
95 check_formals (SCM f, SCM formals, SCM args)
96 {
97   int flen = (TYPE (formals) == TNUMBER) ? VALUE (formals) : VALUE (length (formals));
98   int alen = VALUE (length (args));
99   if (alen != flen && alen != -1 && flen != -1)
100     {
101       char buf[1024];
102       sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
103       SCM e = MAKE_STRING (cstring_to_list (buf));
104       return error (cell_symbol_wrong_number_of_args, cons (e, f));
105     }
106   return cell_unspecified;
107 }
108
109 SCM
110 check_apply (SCM f, SCM e)
111 {
112   char const* type = 0;
113   if (f == cell_f || f == cell_t) type = "bool";
114   if (f == cell_nil) type = "nil";
115   if (f == cell_unspecified) type = "*unspecified*";
116   if (f == cell_undefined) type = "*undefined*";
117   if (TYPE (f) == TCHAR) type = "char";
118   if (TYPE (f) == TNUMBER) type = "number";
119   if (TYPE (f) == TSTRING) type = "string";
120
121   if (type)
122     {
123       char buf[1024];
124       sprintf (buf, "cannot apply: %s:", type);
125       fprintf (stderr, " [");
126       stderr_ (e);
127       fprintf (stderr, "]\n");
128       SCM e = MAKE_STRING (cstring_to_list (buf));
129       return error (cell_symbol_wrong_type_arg, cons (e, f));
130     }
131   return cell_unspecified;
132 }
133
134 char const*
135 itoa (int x)
136 {
137   static char buf[10];
138   char *p = buf+9;
139   *p-- = 0;
140
141   int sign = x < 0;
142   if (sign)
143     x = -x;
144   
145   do
146     {
147       *p-- = '0' + (x % 10);
148       x = x / 10;
149     } while (x);
150
151   if (sign)
152     *p-- = '-';
153
154   return p+1;
155 }
156
157 FILE *g_stdin;
158 int
159 dump ()
160 {
161   fputs ("program r2=", stderr);
162   stderr_ (r2);
163   fputs ("\n", stderr);
164
165   r1 = g_symbols;
166   gc_push_frame ();
167   gc ();
168   gc_peek_frame ();
169   char *p = (char*)g_cells;
170   fputc ('M', stdout);
171   fputc ('E', stdout);
172   fputc ('S', stdout);
173   fputc (g_stack >> 8, stdout);
174   fputc (g_stack % 256, stdout);
175   if (getenv ("MES_HACK"))
176     {
177       TYPE (9) = 0x2d2d2d2d;
178       CAR (9) = 0x2d2d2d2d;
179       CDR (9) = 0x3e3e3e3e;
180
181       TYPE (10) = TPAIR;
182       CAR (10) = 11;
183       CDR (10) = 12;
184
185       TYPE (11) = TCHAR;
186       CAR (11) = 0x58585858;
187       CDR (11) = 65;
188
189       TYPE (12) = TPAIR;
190       CAR (12) = 13;
191       CDR (12) = 1;
192
193       TYPE (13) = TCHAR;
194       CAR (11) = 0x58585858;
195       CDR (13) = 66;
196
197       TYPE (14) = 0x3c3c3c3c;
198       CAR (14) = 0x2d2d2d2d;
199       CDR (14) = 0x2d2d2d2d;
200
201       g_free = 15;
202     }
203   for (int i=0; i<g_free * sizeof(struct scm); i++)
204     fputc (*p++, stdout);
205   return 0;
206 }
207
208 SCM
209 load_env (SCM a) ///((internal))
210 {
211   r0 = a;
212   if (getenv ("MES_MINI"))
213     g_stdin = fopen ("mini-0.mes", "r");
214   else
215     {
216       g_stdin = fopen ("module/mes/read-0.mes", "r");
217       g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mes", "r");
218     }
219   if (!g_function) r0 = mes_builtins (r0);
220   r2 = read_input_file_env (r0);
221   g_stdin = stdin;
222   return r2;
223 }
224
225 SCM
226 bload_env (SCM a) ///((internal))
227 {
228 #if MES_MINI
229   g_stdin = fopen ("mini-0.mo", "r");
230 #else
231   g_stdin = fopen ("module/mes/read-0.mo", "r");
232   g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r");
233 #endif
234
235   char *p = (char*)g_cells;
236   assert (getchar () == 'M');
237   assert (getchar () == 'E');
238   assert (getchar () == 'S');
239   g_stack = getchar () << 8;
240   g_stack += getchar ();
241   int c = getchar ();
242   while (c != EOF)
243     {
244       *p++ = c;
245       c = getchar ();
246     }
247   g_free = (p-(char*)g_cells) / sizeof (struct scm);
248   gc_peek_frame ();
249   g_symbols = r1;
250   g_stdin = stdin;
251   r0 = mes_builtins (r0);
252   return r2;
253 }