1 /* prim.c: Built-in primitives, Define_Primitive().
2 *
3 * $Id$
4 *
5 * Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
6 * Copyright 2002, 2003 Sam Hocevar <sam@hocevar.net>, Paris
7 *
8 * This software was derived from Elk 1.2, which was Copyright 1987, 1988,
9 * 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
10 * by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
11 * between TELES and Nixdorf Microprocessor Engineering, Berlin).
12 *
13 * Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
14 * owners or individual owners of copyright in this software, grant to any
15 * person or company a worldwide, royalty free, license to
16 *
17 * i) copy this software,
18 * ii) prepare derivative works based on this software,
19 * iii) distribute copies of this software or derivative works,
20 * iv) perform this software, or
21 * v) display this software,
22 *
23 * provided that this notice is not removed and that neither Oliver Laumann
24 * nor Teles nor Nixdorf are deemed to have made any representations as to
25 * the suitability of this software for any purpose nor are held responsible
26 * for any defects of this software.
27 *
28 * THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
29 */
30
31 #include "config.h"
32
33 #include "kernel.h"
34
35 extern void Memoize_Frame (Object);
36
37 struct Prim_Init {
38 Object (*fun)();
39 char *name;
40 int minargs, maxargs;
41 enum discipline disc;
42 } Primitives[] = {
43
44 /* autoload.c:
45 */
46 { P_Autoload, "autoload", 2, 2, EVAL },
47
48 /* bool.c:
49 */
50 { P_Booleanp, "boolean?", 1, 1, EVAL },
51 { P_Not, "not", 1, 1, EVAL },
52 { P_Eq, "eq?", 2, 2, EVAL },
53 { P_Eqv, "eqv?", 2, 2, EVAL },
54 { P_Equal, "equal?", 2, 2, EVAL },
55 { P_Empty_List_Is_False, "empty-list-is-false-for-backward-compatibility",
56 1, 1, EVAL },
57
58 /* char.c:
59 */
60 { P_Charp, "char?", 1, 1, EVAL },
61 { P_Char_To_Integer, "char->integer", 1, 1, EVAL },
62 { P_Integer_To_Char, "integer->char", 1, 1, EVAL },
63 { P_Char_Upper_Casep, "char-upper-case?", 1, 1, EVAL },
64 { P_Char_Lower_Casep, "char-lower-case?", 1, 1, EVAL },
65 { P_Char_Alphabeticp, "char-alphabetic?", 1, 1, EVAL },
66 { P_Char_Numericp, "char-numeric?", 1, 1, EVAL },
67 { P_Char_Whitespacep, "char-whitespace?", 1, 1, EVAL },
68 { P_Char_Upcase, "char-upcase", 1, 1, EVAL },
69 { P_Char_Downcase, "char-downcase", 1, 1, EVAL },
70 { P_Char_Eq, "char=?", 2, 2, EVAL },
71 { P_Char_Less, "char<?", 2, 2, EVAL },
72 { P_Char_Greater, "char>?", 2, 2, EVAL },
73 { P_Char_Eq_Less, "char<=?", 2, 2, EVAL },
74 { P_Char_Eq_Greater, "char>=?", 2, 2, EVAL },
75 { P_Char_CI_Eq, "char-ci=?", 2, 2, EVAL },
76 { P_Char_CI_Less, "char-ci<?", 2, 2, EVAL },
77 { P_Char_CI_Greater, "char-ci>?", 2, 2, EVAL },
78 { P_Char_CI_Eq_Less, "char-ci<=?", 2, 2, EVAL },
79 { P_Char_CI_Eq_Greater,"char-ci>=?", 2, 2, EVAL },
80
81 /* cont.c:
82 */
83 { P_Control_Pointp, "control-point?", 1, 1, EVAL },
84 { P_Call_With_Current_Continuation,
85 "call-with-current-continuation", 1, 1, EVAL },
86 { P_Dynamic_Wind, "dynamic-wind", 3, 3, EVAL },
87 { P_Control_Point_Environment,
88 "control-point-environment", 1, 1, EVAL },
89
90 /* debug.c:
91 */
92 { P_Backtrace_List, "backtrace-list", 0, 1, VARARGS },
93
94 /* dump.c:
95 */
96 #ifdef CAN_DUMP
97 { P_Dump, "dump", 1, 1, EVAL },
98 #endif
99
100 /* env.c:
101 */
102 { P_Environmentp, "environment?", 1, 1, EVAL },
103 { P_The_Environment, "the-environment", 0, 0, EVAL },
104 { P_Global_Environment,"global-environment", 0, 0, EVAL },
105 { P_Define, "define", 1, MANY, NOEVAL },
106 { P_Define_Macro, "define-macro", 1, MANY, NOEVAL },
107 { P_Set, "set!", 2, 2, NOEVAL },
108 { P_Environment_To_List,
109 "environment->list", 1, 1, EVAL },
110 { P_Boundp, "bound?", 1, 1, EVAL },
111
112 /* error.c:
113 */
114 { P_Error, "error", 2, MANY, VARARGS },
115 { P_Reset, "reset", 0, 0, EVAL },
116
117 /* exception.c:
118 */
119 { P_Disable_Interrupts,"disable-interrupts", 0, 0, EVAL },
120 { P_Enable_Interrupts, "enable-interrupts", 0, 0, EVAL },
121
122 /* feature.c:
123 */
124 { P_Features, "features", 0, 0, EVAL },
125 { P_Featurep, "feature?", 1, 1, EVAL },
126 { P_Provide, "provide", 1, 1, EVAL },
127 { P_Require, "require", 1, 3, VARARGS },
128
129 /* heap.c:
130 */
131 { P_Collect, "collect", 0, 0, EVAL },
132 { P_Garbage_Collect_Status, "garbage-collect-status", 0, 2, VARARGS },
133 #ifdef GENERATIONAL_GC
134 { P_Collect_Incremental, "collect-incremental", 0, 0, EVAL },
135 #endif
136
137
138 /* io.c:
139 */
140 { P_Port_File_Name, "port-file-name", 1, 1, EVAL },
141 { P_Port_Line_Number, "port-line-number", 1, 1, EVAL },
142 { P_Eof_Objectp, "eof-object?", 1, 1, EVAL },
143 { P_Current_Input_Port,
144 "current-input-port", 0, 0, EVAL },
145 { P_Current_Output_Port,
146 "current-output-port", 0, 0, EVAL },
147 { P_Input_Portp, "input-port?", 1, 1, EVAL },
148 { P_Output_Portp, "output-port?", 1, 1, EVAL },
149 { P_Open_Input_File, "open-input-file", 1, 1, EVAL },
150 { P_Open_Output_File, "open-output-file", 1, 1, EVAL },
151 { P_Open_Input_Output_File, "open-input-output-file", 1, 1, EVAL },
152 { P_Close_Input_Port, "close-input-port", 1, 1, EVAL },
153 { P_Close_Output_Port, "close-output-port", 1, 1, EVAL },
154 { P_With_Input_From_File, "with-input-from-file", 2, 2, EVAL },
155 { P_With_Output_To_File, "with-output-to-file", 2, 2, EVAL },
156 { P_Call_With_Input_File, "call-with-input-file", 2, 2, EVAL },
157 { P_Call_With_Output_File, "call-with-output-file", 2, 2, EVAL },
158 { P_Open_Input_String, "open-input-string", 1, 1, EVAL },
159 { P_Open_Output_String,"open-output-string", 0, 0, EVAL },
160 { P_Tilde_Expand, "tilde-expand", 1, 1, EVAL },
161 { P_File_Existsp, "file-exists?", 1, 1, EVAL },
162
163 /* load.c:
164 */
165 { P_Load, "load", 1, 2, VARARGS },
166
167 /* list.c:
168 */
169 { P_Cons, "cons", 2, 2, EVAL },
170 { P_Car, "car", 1, 1, EVAL },
171 { P_Cdr, "cdr", 1, 1, EVAL },
172 { P_Caar, "caar", 1, 1, EVAL },
173 { P_Cadr, "cadr", 1, 1, EVAL },
174 { P_Cdar, "cdar", 1, 1, EVAL },
175 { P_Cddr, "cddr", 1, 1, EVAL },
176
177 { P_Caaar, "caaar", 1, 1, EVAL },
178 { P_Caadr, "caadr", 1, 1, EVAL },
179 { P_Cadar, "cadar", 1, 1, EVAL },
180 { P_Caddr, "caddr", 1, 1, EVAL },
181 { P_Cdaar, "cdaar", 1, 1, EVAL },
182 { P_Cdadr, "cdadr", 1, 1, EVAL },
183 { P_Cddar, "cddar", 1, 1, EVAL },
184 { P_Cdddr, "cdddr", 1, 1, EVAL },
185
186 { P_Caaaar, "caaaar", 1, 1, EVAL },
187 { P_Caaadr, "caaadr", 1, 1, EVAL },
188 { P_Caadar, "caadar", 1, 1, EVAL },
189 { P_Caaddr, "caaddr", 1, 1, EVAL },
190 { P_Cadaar, "cadaar", 1, 1, EVAL },
191 { P_Cadadr, "cadadr", 1, 1, EVAL },
192 { P_Caddar, "caddar", 1, 1, EVAL },
193 { P_Cadddr, "cadddr", 1, 1, EVAL },
194 { P_Cdaaar, "cdaaar", 1, 1, EVAL },
195 { P_Cdaadr, "cdaadr", 1, 1, EVAL },
196 { P_Cdadar, "cdadar", 1, 1, EVAL },
197 { P_Cdaddr, "cdaddr", 1, 1, EVAL },
198 { P_Cddaar, "cddaar", 1, 1, EVAL },
199 { P_Cddadr, "cddadr", 1, 1, EVAL },
200 { P_Cdddar, "cdddar", 1, 1, EVAL },
201 { P_Cddddr, "cddddr", 1, 1, EVAL },
202
203 { P_Cxr, "cxr", 2, 2, EVAL },
204 { P_Nullp, "null?", 1, 1, EVAL },
205 { P_Pairp, "pair?", 1, 1, EVAL },
206 { P_Listp, "list?", 1, 1, EVAL },
207 { P_Set_Car, "set-car!", 2, 2, EVAL },
208 { P_Set_Cdr, "set-cdr!", 2, 2, EVAL },
209 { P_Assq, "assq", 2, 2, EVAL },
210 { P_Assv, "assv", 2, 2, EVAL },
211 { P_Assoc, "assoc", 2, 2, EVAL },
212 { P_Memq, "memq", 2, 2, EVAL },
213 { P_Memv, "memv", 2, 2, EVAL },
214 { P_Member, "member", 2, 2, EVAL },
215 { P_Make_List, "make-list", 2, 2, EVAL },
216 { P_List, "list", 0, MANY, VARARGS },
217 { P_Length, "length", 1, 1, EVAL },
218 { P_Append, "append", 0, MANY, VARARGS },
219 { P_Append_Set, "append!", 0, MANY, VARARGS },
220 { P_Last_Pair, "last-pair", 1, 1, EVAL },
221 { P_Reverse, "reverse", 1, 1, EVAL },
222 { P_Reverse_Set, "reverse!", 1, 1, EVAL },
223 { P_List_Tail, "list-tail", 2, 2, EVAL },
224 { P_List_Ref, "list-ref", 2, 2, EVAL },
225
226 /* main.c:
227 */
228 { P_Command_Line_Args, "command-line-args", 0, 0, EVAL },
229 { P_Exit, "exit", 0, 1, VARARGS },
230
231 /* math.c:
232 */
233 { P_Number_To_String, "number->string", 1, 2, VARARGS },
234 { P_Numberp, "number?", 1, 1, EVAL },
235 { P_Complexp, "complex?", 1, 1, EVAL },
236 { P_Realp, "real?", 1, 1, EVAL },
237 { P_Rationalp, "rational?", 1, 1, EVAL },
238 { P_Integerp, "integer?", 1, 1, EVAL },
239 { P_Zerop, "zero?", 1, 1, EVAL },
240 { P_Positivep, "positive?", 1, 1, EVAL },
241 { P_Negativep, "negative?", 1, 1, EVAL },
242 { P_Oddp, "odd?", 1, 1, EVAL },
243 { P_Evenp, "even?", 1, 1, EVAL },
244 { P_Exactp, "exact?", 1, 1, EVAL },
245 { P_Inexactp, "inexact?", 1, 1, EVAL },
246 { P_Exact_To_Inexact, "exact->inexact", 1, 1, EVAL },
247 { P_Inexact_To_Exact, "inexact->exact", 1, 1, EVAL },
248 { P_Generic_Less, "<", 1, MANY, VARARGS },
249 { P_Generic_Greater, ">", 1, MANY, VARARGS },
250 { P_Generic_Equal, "=", 1, MANY, VARARGS },
251 { P_Generic_Eq_Less, "<=", 1, MANY, VARARGS },
252 { P_Generic_Eq_Greater,">=", 1, MANY, VARARGS },
253 { P_Inc, "1+", 1, 1, EVAL },
254 { P_Dec, "-1+", 1, 1, EVAL },
255 { P_Dec, "1-", 1, 1, EVAL },
256 { P_Generic_Plus, "+", 0, MANY, VARARGS },
257 { P_Generic_Minus, "-", 1, MANY, VARARGS },
258 { P_Generic_Multiply, "*", 0, MANY, VARARGS },
259 { P_Generic_Divide, "/", 1, MANY, VARARGS },
260 { P_Abs, "abs", 1, 1, EVAL },
261 { P_Quotient, "quotient", 2, 2, EVAL },
262 { P_Remainder, "remainder", 2, 2, EVAL },
263 { P_Modulo, "modulo", 2, 2, EVAL },
264 { P_Gcd, "gcd", 0, MANY, VARARGS },
265 { P_Lcm, "lcm", 0, MANY, VARARGS },
266 { P_Floor, "floor", 1, 1, EVAL },
267 { P_Ceiling, "ceiling", 1, 1, EVAL },
268 { P_Truncate, "truncate", 1, 1, EVAL },
269 { P_Round, "round", 1, 1, EVAL },
270 { P_Sqrt, "sqrt", 1, 1, EVAL },
271 { P_Exp, "exp", 1, 1, EVAL },
272 { P_Pow, "pow", 2, 2, EVAL },
273 { P_Log, "log", 1, 1, EVAL },
274 { P_Sin, "sin", 1, 1, EVAL },
275 { P_Cos, "cos", 1, 1, EVAL },
276 { P_Tan, "tan", 1, 1, EVAL },
277 { P_Asin, "asin", 1, 1, EVAL },
278 { P_Acos, "acos", 1, 1, EVAL },
279 { P_Atan, "atan", 1, 2, VARARGS },
280 { P_Min, "min", 1, MANY, VARARGS },
281 { P_Max, "max", 1, MANY, VARARGS },
282 { P_Random, "random", 0, 0, EVAL },
283 { P_Srandom, "srandom", 1, 1, EVAL },
284
285 /* prim.c:
286 */
287
288 /* print.c:
289 */
290 { P_Write, "write", 1, 2, VARARGS },
291 { P_Display, "display", 1, 2, VARARGS },
292 { P_Write_Char, "write-char", 1, 2, VARARGS },
293 { P_Newline, "newline", 0, 1, VARARGS },
294 { P_Print, "print", 1, 2, VARARGS },
295 { P_Clear_Output_Port, "clear-output-port", 0, 1, VARARGS },
296 { P_Flush_Output_Port, "flush-output-port", 0, 1, VARARGS },
297 { P_Get_Output_String, "get-output-string", 1, 1, EVAL },
298 { P_Format, "format", 2, MANY, VARARGS },
299
300 /* proc.c:
301 */
302 { P_Procedurep, "procedure?", 1, 1, EVAL },
303 { P_Primitivep, "primitive?", 1, 1, EVAL },
304 { P_Primitive_To_String,
305 "primitive->string", 1, 1, EVAL },
306 { P_Compoundp, "compound?", 1, 1, EVAL },
307 { P_Compound_To_String,
308 "compound->string", 1, 1, EVAL },
309 { P_Macrop, "macro?", 1, 1, EVAL },
310 { P_Macro_To_String, "macro->string", 1, 1, EVAL },
311 { P_Eval, "eval", 1, 2, VARARGS },
312 { P_Apply, "apply", 2, MANY, VARARGS },
313 { P_Lambda, "lambda", 2, MANY, NOEVAL },
314 { P_Procedure_Environment,
315 "procedure-environment", 1, 1, EVAL },
316 { P_Procedure_Lambda, "procedure-lambda", 1, 1, EVAL },
317 { P_Map, "map", 2, MANY, VARARGS },
318 { P_For_Each, "for-each", 2, MANY, VARARGS },
319 { P_Macro, "macro", 2, MANY, NOEVAL },
320 { P_Macro_Body, "macro-body", 1, 1, EVAL },
321 { P_Macro_Expand, "macro-expand", 1, 1, EVAL },
322
323 /* promise.c:
324 */
325 { P_Delay, "delay", 1, 1, NOEVAL },
326 { P_Force, "force", 1, 1, EVAL },
327 { P_Promisep, "promise?", 1, 1, EVAL },
328 { P_Promise_Environment,
329 "promise-environment", 1, 1, EVAL },
330
331 /* read.c:
332 */
333 { P_Clear_Input_Port, "clear-input-port", 0, 1, VARARGS },
334 { P_Read, "read", 0, 1, VARARGS },
335 { P_Read_Char, "read-char", 0, 1, VARARGS },
336 { P_Read_String, "read-string", 0, 1, VARARGS },
337 { P_Unread_Char, "unread-char", 1, 2, VARARGS },
338 { P_Peek_Char, "peek-char", 0, 1, VARARGS },
339 { P_Char_Readyp, "char-ready?", 0, 1, VARARGS },
340
341 /* special.c:
342 */
343 { P_Quote, "quote", 1, 1, NOEVAL },
344 { P_Quasiquote, "quasiquote", 1, 1, NOEVAL },
345 { P_Begin, "begin", 0, MANY, NOEVAL },
346 { P_Begin1, "begin1", 0, MANY, NOEVAL },
347 { P_If, "if", 2, MANY, NOEVAL },
348 { P_Case, "case", 2, MANY, NOEVAL },
349 { P_Cond, "cond", 0, MANY, NOEVAL },
350 { P_Do, "do", 2, MANY, NOEVAL },
351 { P_Let, "let", 2, MANY, NOEVAL },
352 { P_Letseq, "let*", 2, MANY, NOEVAL },
353 { P_Letrec, "letrec", 2, MANY, NOEVAL },
354 { P_Fluid_Let, "fluid-let", 2, MANY, NOEVAL },
355 { P_And, "and", 0, MANY, NOEVAL },
356 { P_Or, "or", 0, MANY, NOEVAL },
357
358 /* string.c:
359 */
360 { P_String, "string", 0, MANY, VARARGS },
361 { P_Stringp, "string?", 1, 1, EVAL },
362 { P_Make_String, "make-string", 1, 2, VARARGS },
363 { P_String_Length, "string-length", 1, 1, EVAL },
364 { P_String_To_Number, "string->number", 1, 2, VARARGS },
365 { P_String_Ref, "string-ref", 2, 2, EVAL },
366 { P_String_Set, "string-set!", 3, 3, EVAL },
367 { P_Substring, "substring", 3, 3, EVAL },
368 { P_String_Copy, "string-copy", 1, 1, EVAL },
369 { P_String_Append, "string-append", 0, MANY, VARARGS },
370 { P_List_To_String, "list->string", 1, 1, EVAL },
371 { P_String_To_List, "string->list", 1, 1, EVAL },
372 { P_String_Fill, "string-fill!", 2, 2, EVAL },
373 { P_Substring_Fill, "substring-fill!", 4, 4, EVAL },
374 { P_String_Eq, "string=?", 2, 2, EVAL },
375 { P_String_Less, "string<?", 2, 2, EVAL },
376 { P_String_Greater, "string>?", 2, 2, EVAL },
377 { P_String_Eq_Less, "string<=?", 2, 2, EVAL },
378 { P_String_Eq_Greater, "string>=?", 2, 2, EVAL },
379 { P_String_CI_Eq, "string-ci=?", 2, 2, EVAL },
380 { P_String_CI_Less, "string-ci<?", 2, 2, EVAL },
381 { P_String_CI_Greater, "string-ci>?", 2, 2, EVAL },
382 { P_String_CI_Eq_Less, "string-ci<=?", 2, 2, EVAL },
383 { P_String_CI_Eq_Greater,
384 "string-ci>=?", 2, 2, EVAL },
385 { P_Substringp, "substring?", 2, 2, EVAL },
386 { P_CI_Substringp, "substring-ci?", 2, 2, EVAL },
387
388 /* symbol.c:
389 */
390 { P_String_To_Symbol, "string->symbol", 1, 1, EVAL },
391 { P_Oblist, "oblist", 0, 0, EVAL },
392 { P_Symbolp, "symbol?", 1, 1, EVAL },
393 { P_Symbol_To_String, "symbol->string", 1, 1, EVAL },
394 { P_Put, "put", 2, 3, VARARGS },
395 { P_Get, "get", 2, 2, EVAL },
396 { P_Symbol_Plist, "symbol-plist", 1, 1, EVAL },
397
398 /* type.c:
399 */
400 { P_Type, "type", 1, 1, EVAL },
401
402 /* vector.c:
403 */
404 { P_Vectorp, "vector?", 1, 1, EVAL },
405 { P_Make_Vector, "make-vector", 1, 2, VARARGS },
406 { P_Vector, "vector", 0, MANY, VARARGS },
407 { P_Vector_Length, "vector-length", 1, 1, EVAL },
408 { P_Vector_Ref, "vector-ref", 2, 2, EVAL },
409 { P_Vector_Set, "vector-set!", 3, 3, EVAL },
410 { P_Vector_To_List, "vector->list", 1, 1, EVAL },
411 { P_List_To_Vector, "list->vector", 1, 1, EVAL },
412 { P_Vector_Fill, "vector-fill!", 2, 2, EVAL },
413 { P_Vector_Copy, "vector-copy", 1, 1, EVAL },
414
415 { 0 }
416 };
417
418 /* The C-compiler can't initialize unions, thus the primitive procedures
419 * must be created during run-time (the problem actually is that one can't
420 * provide an intializer for the "tag" component of an S_Primitive).
421 */
422
Init_Prim()423 void Init_Prim () {
424 register struct Prim_Init *p;
425 Object frame, prim, sym;
426
427 for (frame = Car (The_Environment), p = Primitives; p->fun; p++) {
428 prim = Make_Primitive (p->fun, p->name, p->minargs, p->maxargs,
429 p->disc);
430 sym = Intern (p->name);
431 frame = Add_Binding (frame, sym, prim);
432 }
433 Car (The_Environment) = frame;
434 Memoize_Frame (frame);
435 }
436
Define_Primitive(Object (* fun)(),char const * name,int min,int max,enum discipline disc)437 void Define_Primitive (Object (*fun)(), char const *name, int min, int max,
438 enum discipline disc) {
439 Object prim, sym, frame;
440 GC_Node2;
441
442 Set_Error_Tag ("define-primitive");
443 prim = Make_Primitive (fun, name, min, max, disc);
444 sym = Null;
445 GC_Link2 (prim, sym);
446 sym = Intern (name);
447 if (disc == EVAL && min != max)
448 Primitive_Error ("~s: number of arguments must be fixed", sym);
449 frame = Add_Binding (Car (The_Environment), sym, prim);
450 SYMBOL(sym)->value = prim;
451 Car (The_Environment) = frame;
452 GC_Unlink;
453 }
454