1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /*
28 * This file contains the support routines for mapping primitive names
29 * to numbers within the microcode. Primitives are written in C
30 * and available in Scheme, but not always present in all versions of
31 * the interpreter. Thus, these objects are always referenced
32 * externally by name and converted to numeric references only for the
33 * duration of a single Scheme session.
34 */
35
36 #include "scheme.h"
37 #include "prims.h"
38 #include "os.h"
39 #include "usrdef.h"
40 #include "prename.h"
41 #include "syscall.h"
42 #include "avltree.h"
43 #include "cmpgc.h"
44 #include <ctype.h>
45
46 #ifndef UPDATE_PRIMITIVE_TABLE_HOOK
47 # define UPDATE_PRIMITIVE_TABLE_HOOK(low, high) do { } while (0)
48 #endif
49
50 #ifndef GROW_PRIMITIVE_TABLE_HOOK
51 # define GROW_PRIMITIVE_TABLE_HOOK(size) true
52 #endif
53
54 static prim_renumber_t * make_prim_renumber_1 (unsigned long);
55 static void free_prim_renumber (void *);
56 static SCHEME_OBJECT * make_table_entry (unsigned long, SCHEME_OBJECT *);
57 static unsigned long table_entry_length (unsigned long);
58
59
60 /* Exported variables: */
61
62 unsigned long MAX_PRIMITIVE = 0;
63
64 primitive_procedure_t * Primitive_Procedure_Table = 0;
65
66 int * Primitive_Arity_Table = 0;
67
68 int * Primitive_Count_Table = 0;
69
70 const char ** Primitive_Name_Table = 0;
71
72 const char ** Primitive_Documentation_Table = 0;
73
74 SCHEME_OBJECT * load_renumber_table = 0;
75
76 /* Common utilities. */
77
78 int
strcmp_ci(const char * s1,const char * s2)79 strcmp_ci (const char * s1, const char * s2)
80 {
81 const unsigned char * p1 = ((unsigned char *) s1);
82 const unsigned char * p2 = ((unsigned char *) s2);
83 while (true)
84 {
85 int c1 = (*p1++);
86 int c2 = (*p2++);
87 if (c1 == '\0')
88 return ((c2 == '\0') ? 0 : (-1));
89 if (c2 == '\0')
90 return (1);
91 c1 = (toupper (c1));
92 c2 = (toupper (c2));
93 if (c1 < c2)
94 return (-1);
95 if (c1 > c2)
96 return (1);
97 }
98 }
99
100 SCHEME_OBJECT
Prim_unimplemented(void)101 Prim_unimplemented (void)
102 {
103 PRIMITIVE_HEADER (-1);
104
105 signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
106 /*NOTREACHED*/
107 PRIMITIVE_RETURN (UNSPECIFIC);
108 }
109
110 static void
initialization_error(const char * reason,const char * item)111 initialization_error (const char * reason, const char * item)
112 {
113 outf_fatal ("initialize_primitives: Error %s %s.\n", reason, item);
114 termination_init_error ();
115 }
116
117 static unsigned long prim_table_size = 0;
118
119 #define COPY_TABLE(table, static_table, elt_t, static_elt_t) do \
120 { \
121 if (table == 0) \
122 { \
123 static_elt_t * from = (& (static_table [0])); \
124 static_elt_t * from_end \
125 = (& (static_table [MAX_STATIC_PRIMITIVE + 1])); \
126 elt_t * to; \
127 \
128 table = (OS_malloc (new_size * (sizeof (elt_t)))); \
129 to = ((elt_t *) table); \
130 while (from < from_end) \
131 (*to++) = ((elt_t) (*from++)); \
132 } \
133 else \
134 table = (OS_realloc (table, (new_size * (sizeof (elt_t))))); \
135 } while (0)
136
137 static void
grow_primitive_tables(void)138 grow_primitive_tables (void)
139 {
140 unsigned long new_size = (MAX_PRIMITIVE + (MAX_PRIMITIVE / 10));
141 COPY_TABLE (Primitive_Arity_Table, Static_Primitive_Arity_Table, int, int);
142 COPY_TABLE (Primitive_Count_Table, Static_Primitive_Count_Table, int, int);
143 COPY_TABLE (Primitive_Name_Table,
144 Static_Primitive_Name_Table,
145 char *,
146 const char *);
147 COPY_TABLE (Primitive_Documentation_Table,
148 Static_Primitive_Documentation_Table,
149 char *,
150 const char *);
151 COPY_TABLE (Primitive_Procedure_Table,
152 Static_Primitive_Procedure_Table,
153 primitive_procedure_t,
154 primitive_procedure_t);
155 prim_table_size = new_size;
156 UPDATE_PRIMITIVE_TABLE_HOOK (0, MAX_PRIMITIVE);
157 }
158
159 static tree_node prim_procedure_tree = ((tree_node) NULL);
160
161 void
initialize_primitives(void)162 initialize_primitives (void)
163 {
164 unsigned long counter;
165
166 /* MAX_STATIC_PRIMITIVE is the index of the last primitive */
167
168 MAX_PRIMITIVE = (MAX_STATIC_PRIMITIVE + 1);
169 grow_primitive_tables ();
170
171 tree_error_message = ((char *) NULL);
172 prim_procedure_tree = (tree_build (MAX_PRIMITIVE, Primitive_Name_Table, 0));
173 if (tree_error_message != ((char *) NULL))
174 {
175 outf_fatal (tree_error_message, tree_error_noise);
176 initialization_error ("building", "prim_procedure_tree");
177 }
178
179 for (counter = 0; counter < N_PRIMITIVE_ALIASES; counter++)
180 {
181 unsigned long index;
182 tree_node new;
183 tree_node orig = (tree_lookup (prim_procedure_tree,
184 primitive_aliases[counter].name));
185
186 if (orig != ((tree_node) NULL))
187 index = orig->value;
188 else
189 {
190 SCHEME_OBJECT old = (make_primitive (primitive_aliases[counter].name,
191 UNKNOWN_PRIMITIVE_ARITY));
192
193 if (old == SHARP_F)
194 {
195 outf_fatal ("Error declaring unknown primitive %s.\n",
196 primitive_aliases[counter].name);
197 initialization_error ("aliasing", primitive_aliases[counter].alias);
198 }
199 index = (PRIMITIVE_NUMBER (old));
200 }
201
202 new = (tree_insert (prim_procedure_tree,
203 primitive_aliases[counter].alias,
204 index));
205 if (tree_error_message != ((char *) NULL))
206 {
207 outf_fatal (tree_error_message, tree_error_noise);
208 initialization_error ("aliasing", primitive_aliases[counter].alias);
209 }
210 prim_procedure_tree = new;
211 }
212 return;
213 }
214
215 static SCHEME_OBJECT
declare_primitive_internal(bool override_p,const char * name,primitive_procedure_t code,int nargs_lo,int nargs_hi,const char * docstr)216 declare_primitive_internal (bool override_p,
217 const char * name,
218 primitive_procedure_t code,
219 int nargs_lo,
220 int nargs_hi,
221 const char * docstr)
222 /* nargs_lo ignored, for now */
223 {
224 unsigned long index;
225 SCHEME_OBJECT primitive;
226 const char * ndocstr = docstr;
227 tree_node prim = (tree_lookup (prim_procedure_tree, name));
228
229 if (prim != ((tree_node) NULL))
230 {
231 index = prim->value;
232 primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
233 if ((((PRIMITIVE_ARITY (primitive)) != nargs_hi)
234 && ((PRIMITIVE_ARITY (primitive)) != UNKNOWN_PRIMITIVE_ARITY))
235 || ((IMPLEMENTED_PRIMITIVE_P (primitive)) && (! override_p)))
236 return (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (primitive)));
237 if (docstr == 0)
238 ndocstr = (Primitive_Documentation_Table[index]);
239 }
240 else
241 {
242 if (MAX_PRIMITIVE == prim_table_size)
243 grow_primitive_tables ();
244
245 /* Allocate a new primitive index, and insert in data base. */
246
247 index = MAX_PRIMITIVE;
248 prim = (tree_insert (prim_procedure_tree, name, index));
249 if (tree_error_message != ((char *) NULL))
250 {
251 outf_error (tree_error_message, tree_error_noise);
252 tree_error_message = ((char *) NULL);
253 return (SHARP_F);
254 }
255 prim_procedure_tree = prim;
256
257 MAX_PRIMITIVE += 1;
258 primitive = (MAKE_PRIMITIVE_OBJECT (index));
259 Primitive_Name_Table[index] = name;
260 }
261
262 Primitive_Procedure_Table[index] = code;
263 Primitive_Arity_Table[index] = nargs_hi;
264 Primitive_Count_Table[index] = (nargs_hi * (sizeof (SCHEME_OBJECT)));
265 Primitive_Documentation_Table[index] = ndocstr;
266 UPDATE_PRIMITIVE_TABLE_HOOK (index, (index + 1));
267 return (primitive);
268 }
269
270 /* declare_primitive installs a new primitive in the system.
271 It returns:
272 - A primitive object if it succeeds.
273 - SHARP_F if there was a problem trying to install it (e.g. out of memory).
274 - A fixnum whose value is the number of the pre-existing primitive
275 that it would replace.
276 Note that even if a primitive is returned, its number may not
277 be the previous value of MAX_PRIMITIVE, since the system may
278 have pre-existent references to the previously-unimplemented primitive.
279 */
280
281 SCHEME_OBJECT
declare_primitive(const char * name,primitive_procedure_t code,int nargs_lo,int nargs_hi,const char * docstr)282 declare_primitive (const char * name,
283 primitive_procedure_t code,
284 int nargs_lo,
285 int nargs_hi,
286 const char * docstr)
287 {
288 return (declare_primitive_internal (false, name, code,
289 nargs_lo, nargs_hi, docstr));
290 }
291
292 /* install_primitive is similar to declare_primitive, but will
293 replace a pre-existing primitive if the arities are consistent.
294 If they are not, it returns a fixnum whose value is the index
295 of the pre-existing primitive.
296 */
297
298 SCHEME_OBJECT
install_primitive(const char * name,primitive_procedure_t code,int nargs_lo,int nargs_hi,const char * docstr)299 install_primitive (const char * name,
300 primitive_procedure_t code,
301 int nargs_lo,
302 int nargs_hi,
303 const char * docstr)
304 {
305 return (declare_primitive_internal (true, name, code,
306 nargs_lo, nargs_hi, docstr));
307 }
308
309 SCHEME_OBJECT
make_primitive(const char * name,int arity)310 make_primitive (const char * name, int arity)
311 {
312 tree_node prim;
313 char * cname;
314 SCHEME_OBJECT result;
315
316 /* Make sure to copy the name if we will be keeping it. */
317 prim = (tree_lookup (prim_procedure_tree, name));
318 if (prim != 0)
319 cname = ((char *) (prim->name));
320 else
321 {
322 cname = (OS_malloc ((strlen (name)) + 1));
323 strcpy (cname, name);
324 }
325 result = (declare_primitive (cname, Prim_unimplemented, arity, arity, 0));
326 return
327 ((result == SHARP_F)
328 ? SHARP_F
329 : (OBJECT_NEW_TYPE (TC_PRIMITIVE, result)));
330 }
331
332 SCHEME_OBJECT
find_primitive_cname(const char * name,bool intern_p,bool allow_p,int arity)333 find_primitive_cname (const char * name, bool intern_p, bool allow_p, int arity)
334 {
335 tree_node prim = (tree_lookup (prim_procedure_tree, name));
336 if (prim != 0)
337 {
338 SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value));
339
340 if ((!allow_p) && (!IMPLEMENTED_PRIMITIVE_P (primitive)))
341 return (SHARP_F);
342
343 if ((arity == UNKNOWN_PRIMITIVE_ARITY)
344 || (arity == (PRIMITIVE_ARITY (primitive))))
345 return (primitive);
346
347 if ((PRIMITIVE_ARITY (primitive)) == UNKNOWN_PRIMITIVE_ARITY)
348 {
349 /* We've just learned the arity of the primitive. */
350 (Primitive_Arity_Table[PRIMITIVE_NUMBER (primitive)]) = arity;
351 return (primitive);
352 }
353
354 /* Arity mismatch, notify the runtime system. */
355 return (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive)));
356 }
357
358 if (!intern_p)
359 return (SHARP_F);
360
361 {
362 size_t n_bytes = ((strlen (name)) + 1);
363 char * cname = (OS_malloc (n_bytes));
364 memcpy (cname, name, n_bytes);
365 {
366 SCHEME_OBJECT primitive
367 = (declare_primitive (cname,
368 Prim_unimplemented,
369 ((arity < 0) ? 0 : arity),
370 arity,
371 0));
372 if (primitive == SHARP_F)
373 error_in_system_call (syserr_not_enough_space, syscall_malloc);
374 return (primitive);
375 }
376 }
377 }
378
379 SCHEME_OBJECT
find_primitive(SCHEME_OBJECT sname,bool intern_p,bool allow_p,int arity)380 find_primitive (SCHEME_OBJECT sname, bool intern_p, bool allow_p, int arity)
381 {
382 return (find_primitive_cname (STRING_POINTER (sname),
383 intern_p, allow_p, arity));
384 }
385
386 /* These are used by fasdump to renumber primitives on the way out.
387 Only those primitives actually referenced by the object being
388 dumped are described in the output. The primitives being dumped
389 are renumbered in the output to a contiguous range starting at 0. */
390
391 prim_renumber_t *
make_prim_renumber(void)392 make_prim_renumber (void)
393 {
394 return (make_prim_renumber_1 (MAX_PRIMITIVE));
395 }
396
397 static prim_renumber_t *
make_prim_renumber_1(unsigned long n_entries)398 make_prim_renumber_1 (unsigned long n_entries)
399 {
400 prim_renumber_t * pr = (OS_malloc (sizeof (prim_renumber_t)));
401 (pr->internal) = (OS_malloc (n_entries * (sizeof (unsigned long))));
402 (pr->external) = (OS_malloc (n_entries * (sizeof (unsigned long))));
403 (pr->next_code) = 0;
404 {
405 unsigned long i;
406 for (i = 0; (i < n_entries); i += 1)
407 {
408 ((pr->internal) [i]) = ULONG_MAX;
409 ((pr->external) [i]) = ULONG_MAX;
410 }
411 }
412 transaction_record_action (tat_always, free_prim_renumber, pr);
413 return (pr);
414 }
415
416 static void
free_prim_renumber(void * vpr)417 free_prim_renumber (void * vpr)
418 {
419 prim_renumber_t * pr = vpr;
420 OS_free (pr->internal);
421 OS_free (pr->external);
422 OS_free (pr);
423 }
424
425 SCHEME_OBJECT
renumber_primitive(SCHEME_OBJECT primitive,prim_renumber_t * pr)426 renumber_primitive (SCHEME_OBJECT primitive, prim_renumber_t * pr)
427 {
428 unsigned long old = (OBJECT_DATUM (primitive));
429 unsigned long new = ((pr->internal) [old]);
430 if (new == ULONG_MAX)
431 {
432 new = ((pr->next_code)++);
433 ((pr->internal) [old]) = new;
434 ((pr->external) [new]) = old;
435 }
436 return (OBJECT_NEW_DATUM (primitive, new));
437 }
438
439 unsigned long
renumbered_primitives_export_length(prim_renumber_t * pr)440 renumbered_primitives_export_length (prim_renumber_t * pr)
441 {
442 unsigned long result = 0;
443 unsigned long i;
444
445 for (i = 0; (i < (pr->next_code)); i += 1)
446 result += (table_entry_length ((pr->external) [i]));
447 return (result);
448 }
449
450 void
export_renumbered_primitives(SCHEME_OBJECT * start,prim_renumber_t * pr)451 export_renumbered_primitives (SCHEME_OBJECT * start, prim_renumber_t * pr)
452 {
453 unsigned long i;
454 for (i = 0; (i < (pr->next_code)); i += 1)
455 start = (make_table_entry (((pr->external) [i]), start));
456 }
457
458 /* Like above, but export the whole table. */
459
460 unsigned long
primitive_table_export_length(void)461 primitive_table_export_length (void)
462 {
463 unsigned long result = 0;
464 unsigned long i;
465
466 for (i = 0; (i < MAX_PRIMITIVE); i += 1)
467 result += (table_entry_length (i));
468 return (result);
469 }
470
471 void
export_primitive_table(SCHEME_OBJECT * start)472 export_primitive_table (SCHEME_OBJECT * start)
473 {
474 unsigned long i;
475 for (i = 0; (i < MAX_PRIMITIVE); i += 1)
476 start = (make_table_entry (i, start));
477 }
478
479 static SCHEME_OBJECT *
make_table_entry(unsigned long code,SCHEME_OBJECT * start)480 make_table_entry (unsigned long code, SCHEME_OBJECT * start)
481 {
482 static const char * null_string = "\0";
483 const char * source
484 = (((Primitive_Name_Table[code]) == 0)
485 ? null_string
486 : (Primitive_Name_Table[code]));
487 unsigned long n_chars = (strlen (source));
488 unsigned long n_words = (STRING_LENGTH_TO_GC_LENGTH (n_chars));
489
490 (*start++) = (LONG_TO_FIXNUM (Primitive_Arity_Table[code]));
491 (*start++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, n_words));
492 (*start) = (MAKE_OBJECT (0, n_chars));
493 memcpy ((start + 1), source, (n_chars + 1));
494 return (start + n_words);
495 }
496
497 static unsigned long
table_entry_length(unsigned long code)498 table_entry_length (unsigned long code)
499 {
500 return
501 ((STRING_LENGTH_TO_GC_LENGTH (((Primitive_Name_Table[code]) == 0)
502 ? 0
503 : (strlen (Primitive_Name_Table[code]))))
504 + 2);
505 }
506
507 void
import_primitive_table(SCHEME_OBJECT * entries,unsigned long n_entries,SCHEME_OBJECT * primitives)508 import_primitive_table (SCHEME_OBJECT * entries,
509 unsigned long n_entries,
510 SCHEME_OBJECT * primitives)
511 {
512 unsigned long i;
513 for (i = 0; (i < n_entries); i += 1)
514 {
515 long arity = (FIXNUM_TO_LONG (*entries++));
516 SCHEME_OBJECT prim
517 = (find_primitive
518 ((MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, entries)),
519 true, true, arity));
520
521 if (!PRIMITIVE_P (prim))
522 signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES);
523
524 (*primitives++) = prim;
525 entries += (1 + (OBJECT_DATUM (*entries)));
526 }
527 }
528