1 #include <stdio.h>
2 #include <string.h>
3 #include <ctype.h>
4 #include <stdlib.h>
5 #include <math.h>
6 #include <float.h>
7 #include <time.h>
8 #include <dlfcn.h>
9 #include <limits.h>
10 #include <unistd.h>
11 #include "eisl.h"
12 #include "mem.h"
13 #include "fmt.h"
14 #include "except.h"
15 #include "str.h"
16 #include "text.h"
17
18 #define BININT_LEN 64
19
20 static void *hmod;
21
22 void
initsubr(void)23 initsubr(void)
24 {
25 // constant
26 bindconst("*PI*", makeflt(M_PI));
27 bindconst("*MOST-POSITIVE-FLOAT*", makeflt(DBL_MAX));
28 bindconst("*MOST-NEGATIVE-FLOAT*", makeflt(-DBL_MAX));
29
30 // function
31 defsubr("-", f_minus);
32 defsubr("*", f_mult);
33 defsubr("/=", f_notnumeqp);
34 defsubr("+", f_plus);
35 defsubr("<", f_smaller);
36 defsubr("<=", f_eqsmaller);
37 defsubr("=", f_numeqp);
38 defsubr(">", f_greater);
39 defsubr(">=", f_eqgreater);
40 defsubr("ABS", f_abs);
41 defsubr("APPEND", f_append);
42 defsubr("APPLY", f_apply);
43 defsubr("AREF", f_aref);
44 defsubr("ARITHMETIC-ERROR-OPERANDS", f_arithmetic_error_operands);
45 defsubr("ARITHMETIC-ERROR-OPERATION", f_arithmetic_error_operation);
46 defsubr("ARRAY-DIMENSIONS", f_array_dimensions);
47 defsubr("ASSOC", f_assoc);
48 defsubr("ATAN", f_atan);
49 defsubr("ATAN2", f_atan2);
50 defsubr("ATANH", f_atanh);
51 defsubr("ATOM", f_atomp);
52 defsubr("BASIC-ARRAY-P", f_basic_array_p);
53 defsubr("BASIC-ARRAY*-P", f_basic_array_star_p);
54 defsubr("BASIC-VECTOR-P", f_basic_vector_p);
55 defsubr("CALL-NEXT-METHOD", f_call_next_method);
56 defsubr("CAR", f_car);
57 defsubr("CDR", f_cdr);
58 defsubr("CEILING", f_ceiling);
59 defsubr("CERROR", f_cerror);
60 defsubr("CHAR-INDEX", f_char_index);
61 defsubr("CHAR/=", f_char_noteqp);
62 defsubr("CHAR<", f_char_smallerp);
63 defsubr("CHAR<=", f_char_eqsmallerp);
64 defsubr("CHAR=", f_char_eqp);
65 defsubr("CHAR>", f_char_greaterp);
66 defsubr("CHAR>=", f_char_eqgreaterp);
67 defsubr("CHARACTERP", f_characterp);
68 defsubr("CLASS-OF", f_class_of);
69 defsubr("CLOSE", f_close);
70 defsubr("CONDITION-CONTINUABLE", f_condition_continuable);
71 defsubr("CONS", f_cons);
72 defsubr("CONSP", f_consp);
73 defsubr("CONTINUE-CONDITION", f_continue_condition);
74 defsubr("COS", f_cos);
75 defsubr("COSH", f_cosh);
76 defsubr("CREATE-ARRAY", f_create_array);
77 defsubr("CREATE-LIST", f_create_list);
78 defsubr("CREATE-STRING-INPUT-STREAM", f_create_string_input_stream);
79 defsubr("CREATE-STRING-OUTPUT-STREAM", f_create_string_output_stream);
80 defsubr("CREATE-STRING", f_create_string);
81 defsubr("CREATE-VECTOR", f_create_vector);
82 defsubr("CREATE*", f_create_star);
83 defsubr("DIV", f_div);
84 defsubr("DOMAIN-ERROR-OBJECT", f_domain_error_object);
85 defsubr("DOMAIN-ERROR-EXPECTED-CLASS", f_domain_error_expected_class);
86 defsubr("ELT", f_elt);
87 defsubr("EQ", f_eq);
88 defsubr("EQL", f_eql);
89 defsubr("EQUAL", f_equal);
90 defsubr("ERROR-OUTPUT", f_error_output);
91 defsubr("ERROR", f_error);
92 defsubr("EVAL", f_eval);
93 defsubr("EXP", f_exp);
94 defsubr("EXPT", f_expt);
95 defsubr("FILE-LENGTH", f_file_length);
96 defsubr("FILE-POSITION", f_file_position);
97 defsubr("FINISH-OUTPUT", f_finish_output);
98 defsubr("FLOAT", f_float);
99 defsubr("FLOATP", f_floatp);
100 defsubr("FLOOR", f_floor);
101 defsubr("FORMAT-CHAR", f_format_char);
102 defsubr("FORMAT-FRESH-LINE", f_format_fresh_line);
103 defsubr("FORMAT-FLOAT", f_format_float);
104 defsubr("FORMAT-INTEGER", f_format_integer);
105 defsubr("FORMAT-OBJECT", f_format_object);
106 defsubr("FORMAT-TAB", f_format_tab);
107 defsubr("FORMAT", f_format);
108 defsubr("FUNCALL", f_funcall);
109 defsubr("FUNCTIONP", f_functionp);
110 defsubr("GAREF", f_garef);
111 defsubr("GBC", f_gbc);
112 defsubr("GCD", f_gcd);
113 defsubr("GENERAL-ARRAY*-P", f_general_array_star_p);
114 defsubr("GENERAL-VECTOR-P", f_general_vector_p);
115 defsubr("GENERIC-FUNCTION-P", f_generic_function_p);
116 defsubr("GENSYM", f_gensym);
117 defsubr("GET-INTERNAL-RUN-TIME", f_get_internal_run_time);
118 defsubr("GET-INTERNAL-REAL-TIME", f_get_internal_real_time);
119 defsubr("GET-OUTPUT-STREAM-STRING", f_get_output_stream_string);
120 defsubr("GET-UNIVERSAL-TIME", f_get_universal_time);
121 defsubr("HDMP", f_heapdump);
122 defsubr("IDENTITY", f_identity);
123 defsubr("IMPORT", f_import);
124 defsubr("INITIALIZE-OBJECT*", f_initialize_object_star);
125 defsubr("INPUT-STREAM-P", f_input_stream_p);
126 defsubr("INSTANCEP", f_instancep);
127 defsubr("INTEGERP", f_integerp);
128 defsubr("INTERNAL-TIME-UNITS-PER-SECOND",
129 f_internal_time_units_per_second);
130 defsubr("ISQRT", f_isqrt);
131 defsubr("LCM", f_lcm);
132 defsubr("LENGTH", f_length);
133 defsubr("LIST", f_list);
134 defsubr("LISTP", f_listp);
135 defsubr("LOAD", f_load);
136 defsubr("LOG", f_log);
137 defsubr("MAP-INTO", f_map_into);
138 defsubr("MAPC", f_mapc);
139 defsubr("MAPCAR", f_mapcar);
140 defsubr("MAPCAN", f_mapcan);
141 defsubr("MAPCON", f_mapcon);
142 defsubr("MAPL", f_mapl);
143 defsubr("MAPLIST", f_maplist);
144 defsubr("MAX", f_max);
145 defsubr("MEMBER", f_member);
146 defsubr("MIN", f_min);
147 defsubr("MOD", f_mod);
148 defsubr("NEXT-METHOD-P", f_next_method_p);
149 defsubr("NOT", f_not);
150 defsubr("NREVERSE", f_nreverse);
151 defsubr("NULL", f_nullp);
152 defsubr("NUMBERP", f_numberp);
153 defsubr("OPEN-INPUT-FILE", f_open_input_file);
154 defsubr("OPEN-IO-FILE", f_open_io_file);
155 defsubr("OPEN-OUTPUT-FILE", f_open_output_file);
156 defsubr("OPEN-STREAM-P", f_open_stream_p);
157 defsubr("OUTPUT-STREAM-P", f_output_stream_p);
158 defsubr("PARSE-ERROR-STRING", f_parse_error_string);
159 defsubr("PARSE-ERROR-EXPECTED-CLASS", f_parse_error_expected_class);
160 defsubr("PARSE-NUMBER", f_parse_number);
161 defsubr("PREVIEW-CHAR", f_preview_char);
162 defsubr("PRIN1", f_prin1);
163 defsubr("PRINT", f_print);
164 defsubr("PROBE-FILE", f_probe_file);
165 defsubr("PROPERTY", f_property);
166 defsubr("QUIT", f_quit);
167 defsubr("QUOTIENT", f_quotient);
168 defsubr("READ-BYTE", f_read_byte);
169 defsubr("READ-CHAR", f_read_char);
170 defsubr("READ-LINE", f_read_line);
171 defsubr("READ", f_read);
172 defsubr("RECIPROCAL", f_reciprocal);
173 defsubr("REMOVE-PROPERTY", f_remove_property);
174 defsubr("REVERSE", f_reverse);
175 defsubr("ROUND", f_round);
176 defsubr("SET-AREF", f_set_aref);
177 defsubr("SET-CAR", f_set_car);
178 defsubr("SET-CDR", f_set_cdr);
179 defsubr("SET-ELT", f_set_elt);
180 defsubr("SET-FILE-POSITION", f_set_file_position);
181 defsubr("SET-GAREF", f_set_garef);
182 defsubr("SET-PROPERTY", f_set_property);
183 defsubr("SET-SLOT-VALUE", f_set_slot_value);
184 defsubr("SIGNAL-CONDITION", f_signal_condition);
185 defsubr("SIMPLE-ERROR-FORMAT-ARGUMENTS",
186 f_simple_error_format_arguments);
187 defsubr("SIMPLE-ERROR-FORMAT-STRING", f_simple_error_format_string);
188 defsubr("SIN", f_sin);
189 defsubr("SINH", f_sinh);
190 defsubr("SLOT-VALUE", f_slot_value);
191 defsubr("SQRT", f_sqrt);
192 defsubr("STANDARD-INPUT", f_standard_input);
193 defsubr("STANDARD-OUTPUT", f_standard_output);
194 defsubr("STREAM-ERROR-STREAM", f_stream_error_stream);
195 defsubr("STREAMP", f_streamp);
196 defsubr("STREAM-READY-P", f_stream_ready_p);
197 defsubr("STRING-APPEND", f_string_append);
198 defsubr("STRING-INDEX", f_string_index);
199 defsubr("STRING/=", f_string_noteqp);
200 defsubr("STRING<", f_string_smallerp);
201 defsubr("STRING<=", f_string_eqsmallerp);
202 defsubr("STRING=", f_string_eqp);
203 defsubr("STRING>", f_string_greaterp);
204 defsubr("STRING>=", f_string_eqgreaterp);
205 defsubr("STRINGP", f_stringp);
206 defsubr("SUBCLASSP", f_subclassp);
207 defsubr("SUBSEQ", f_subseq);
208 defsubr("SYMBOLP", f_symbolp);
209 defsubr("TAN", f_tan);
210 defsubr("TANH", f_tanh);
211 defsubr("TRUNCATE", f_truncate);
212 defsubr("UNDEFINED-ENTITY-NAME", f_undefined_entity_name);
213 defsubr("UNDEFINED-ENTITY-NAMESPACE", f_undefined_entity_namespace);
214 defsubr("VECTOR", f_vector);
215 defsubr("WRITE-BYTE", f_write_byte);
216
217 // inner extended functions
218 defsubr("EISL-DUMMYP", f_dummyp);
219 }
220
221
222 typedef void (*initdeftfunc_t)(tfunc);
223 typedef void (*voidfunc_t)(void);
224
225 typedef int (*initfunc0)(int, fn0);
226 typedef int (*initfunc1)(int, fn1);
227 typedef int (*initfunc2)(int, fn2);
228 typedef int (*initfunc3)(int, fn3);
229 typedef int (*initfunc4)(int, fn4);
230 typedef int (*initfunc5)(int, fn5);
231 typedef int (*initfunc6)(int, fn6);
232 typedef int (*initfunc7)(int, fn7);
233 typedef int (*initfunc8)(int, fn8);
234
235 void
dynamic_link(int x)236 dynamic_link(int x)
237 {
238 char *str;
239 initfunc0 init_f0;
240 initfunc1 init_f1;
241 initfunc2 init_f2;
242 initfunc3 init_f3;
243 initfunc4 init_f4;
244 initfunc5 init_f5;
245 initfunc6 init_f6;
246 initfunc7 init_f7;
247 initfunc8 init_f8;
248 initdeftfunc_t init_deftfunc;
249 voidfunc_t init_tfunctions,
250 init_declare;
251
252 if (Str_chr(GET_NAME(x), 1, 0, '/') != 0) {
253 str = Str_dup(GET_NAME(x), 1, 0, 1);
254 } else {
255 str = Str_cat("./", 1, 0, GET_NAME(x), 1, 0);
256 }
257
258 hmod = dlopen(str, RTLD_LAZY);
259
260 FREE(str);
261 if (hmod == NULL)
262 error(ILLEGAL_ARGS, "load", x);
263
264 init_f0 = (initfunc0) dlsym(hmod, "init0");
265 init_f1 = (initfunc1) dlsym(hmod, "init1");
266 init_f2 = (initfunc2) dlsym(hmod, "init2");
267 init_f3 = (initfunc3) dlsym(hmod, "init3");
268 init_f4 = (initfunc4) dlsym(hmod, "init4");
269 init_f5 = (initfunc5) dlsym(hmod, "init5");
270 init_f6 = (initfunc6) dlsym(hmod, "init6");
271 init_f7 = (initfunc7) dlsym(hmod, "init7");
272 init_f8 = (initfunc8) dlsym(hmod, "init8");
273 init_deftfunc = (initdeftfunc_t) dlsym(hmod, "init_deftfunc");
274 init_tfunctions = (voidfunc_t) dlsym(hmod, "init_tfunctions");
275 init_declare = (voidfunc_t) dlsym(hmod, "init_declare");
276
277
278 // argument-0 type
279 init_f0(CHECKGBC_IDX, checkgbc);
280 init_f0(GBC_IDX, gbc);
281 init_f0(FRESHCELL_IDX, freshcell);
282 init_f0(FREECELL_IDX, freecell);
283 init_f0(GBCSW_IDX, gbcsw);
284 init_f0(GETWP_IDX, getwp);
285 init_f0(ARGPOP_IDX, argpop);
286 init_f0(SHELTERPOP_IDX, shelterpop);
287 init_f0(POP_IDX, pop);
288 init_f0(GETDYNPT_IDX, get_dynpt);
289
290 // argument-1 type
291 init_f1(CAR_IDX, car);
292 init_f1(CDR_IDX, cdr);
293 init_f1(CADR_IDX, cadr);
294 init_f1(CADDR_IDX, caddr);
295 init_f1(CAAR_IDX, caar);
296 init_f1(CADAR_IDX, cadar);
297 init_f1(LIST1_IDX, list1);
298 init_f1(EVAL_IDX, eval);
299 init_f1(AUX_IDX, get_aux);
300 init_f1(LENGTH_IDX, fast_length);
301 init_f1(SUBRP_IDX, subrp);
302 init_f1(FSUBRP_IDX, fsubrp);
303 init_f1(FUNCTIONP_IDX, functionp);
304 init_f1(MACROP_IDX, macrop);
305 init_f1(INTEGERP_IDX, integerp);
306 init_f1(LONGNUMP_IDX, longnump);
307 init_f1(BIGNUMP_IDX, bignump);
308 init_f1(GETINT_IDX, get_int);
309 init_f1(MAKEINT_IDX, makeint);
310 init_f1(MAKEINTLONG_IDX, makeintlong);
311 init_f1(VECTOR_IDX, vector);
312 init_f1(FASTCAR_IDX, fast_car);
313 init_f1(FASTCDR_IDX, fast_cdr);
314 init_f1(FINDENV_IDX, findenv);
315 init_f1(FINDDYN_IDX, finddyn);
316 init_f1(ARGPUSH_IDX, argpush);
317 init_f1(SHELTERPUSH_IDX, shelterpush);
318 init_f1(PUSH_IDX, push);
319 init_f1(GETOPT_IDX, get_opt);
320 init_f1(GETPROP_IDX, get_prop);
321 init_f1(SETDYNPT_IDX, set_dynpt);
322 init_f1(SETCATCHSYMBOLS_IDX, set_catch_symbols);
323
324 // argument-2 type
325 init_f2(CONS_IDX, cons);
326 init_f2(NTH_IDX, nth);
327 init_f2(SETCAR_IDX, set_car);
328 init_f2(SETCDR_IDX, set_cdr);
329 init_f2(SETAUX_IDX, set_aux);
330 init_f2(SETOPT_IDX, set_opt);
331 init_f2(CALLSUBR_IDX, callsubr);
332 init_f2(LIST2_IDX, list2);
333 init_f2(NTHCDR_IDX, nth_cdr);
334 init_f2(APPLY_IDX, apply);
335 init_f2(PLUS_IDX, plus);
336 init_f2(MINUS_IDX, minus);
337 init_f2(MULT_IDX, mult);
338 init_f2(QUOTIENT_IDX, quotient);
339 init_f2(REMAINDER_IDX, s_remainder);
340 init_f2(DIVIDE_IDX, divide);
341 init_f2(EQP_IDX, eqp);
342 init_f2(EQLP_IDX, eqlp);
343 init_f2(NUMEQP_IDX, numeqp);
344 init_f2(SMALLERP_IDX, smallerp);
345 init_f2(EQSMALLERP_IDX, eqsmallerp);
346 init_f2(GREATERP_IDX, greaterp);
347 init_f2(EQGREATERP_IDX, eqgreaterp);
348 init_f2(MEMBER_IDX, member);
349 init_f2(CONVERT_IDX, convert);
350 init_f2(ARRAY_IDX, array);
351 init_f2(SETDYNENV_IDX, setdynenv);
352 init_f2(ADDDYNENV_IDX, adddynenv);
353 init_f2(SETDYNAMIC_IDX, set_dynamic);
354 init_f2(SETPROP_IDX, set_prop);
355 init_f2(ADAPTP_IDX, a_adaptp);
356 init_f2(MATCHP_IDX, a_matchp);
357 init_f2(ILOSERR_IDX, ILOSerror);
358
359
360
361 // argument-1 string type
362 init_f3(MAKESTR_IDX, (fn3) makestr);
363 init_f3(MAKESYM_IDX, (fn3) makesym);
364 init_f3(MAKECHAR_IDX, (fn3) makechar);
365 init_f3(MAKESTRFLT_IDX, (fn3) makestrflt);
366 init_f3(MAKEBIG_IDX, makebigx);
367 init_f3(MAKESTRLONG_IDX, (fn3) makestrlong);
368 init_f3(MAKEFASTSTRLONG_IDX, (fn3) makefaststrlong);
369
370 // argument-1 long long int type
371 init_f4(GETLONG_IDX, get_long);
372
373 // argument-3 type
374 init_f5(STRINGSET_IDX, string_set);
375 init_f5(ARRAYSET_IDX, array_set);
376 init_f5(MEMBER1_IDX, member1);
377
378 // string output type
379 init_f6(GETNAME_IDX, get_name);
380
381 // float output type
382 init_f7(GETFLT_IDX, get_flt);
383
384 // float input type
385 init_f8(MAKEDOUBLEFLT_IDX, makedoubleflt);
386
387 init_deftfunc((tfunc) defsubr);
388 init_tfunctions();
389 init_declare();
390
391 return;
392 }
393
394
395
396
397 void
initgeneric(void)398 initgeneric(void)
399 {
400 int lamlis,
401 body;
402
403 lamlis = list3(makesym("x"), makesym(":REST"), makesym("y"));
404 body =
405 list3(makesym(":METHOD"),
406 list3(makesym("x"), makesym(":REST"), makesym("y")),
407 list4(makesym("LET"),
408 list1(list2
409 (makesym("obj"),
410 list3(makesym("CREATE*"), makesym("x"), NIL))),
411 list3(makesym("INITIALIZE-OBJECT"), makesym("obj"),
412 makesym("y")), makesym("obj")));
413 eval(list4(makesym("DEFGENERIC"), makesym("CREATE"), lamlis, body));
414 /*
415 * (defgeneric create(x :rest y) (:method (x :rest y) (let ((obj (create* x
416 * '()))) (initialize-object obj y) obj)))
417 *
418 */
419
420 lamlis = list2(makesym("x"), makesym("y"));
421 body = list3(makesym(":METHOD"), list2(makesym("x"), makesym("y")),
422 list3(makesym("INITIALIZE-OBJECT*"), makesym("x"),
423 makesym("y")));
424 eval(list4
425 (makesym("DEFGENERIC*"), makesym("INITIALIZE-OBJECT"), lamlis,
426 body));
427 /*
428 * (defgeneric* initialize-object(x y) (:method (x y)
429 * (initialize-object* x y)))
430 */
431
432 lamlis = list2(makesym("x"), makesym("y"));
433 body = NIL;
434 eval(list4
435 (makesym("DEFGENERIC*"), makesym("REPORT-CONDITION"), lamlis,
436 body));
437 /*
438 * (defgeneric report-condition (x y))
439 */
440 }
441
442
443 // arithmetic function
444 int
f_plus(int arglist)445 f_plus(int arglist)
446 {
447 int res;
448
449 if (nullp(arglist))
450 res = makeint(0);
451 else {
452 res = car(arglist);
453 if (!numberp(res))
454 error(NOT_NUM, "+", res);
455 arglist = cdr(arglist);
456 }
457 while (!(IS_NIL(arglist))) {
458 int arg;
459
460 arg = car(arglist);
461 if (!numberp(arg) && !vectorp(arg) && !arrayp(arg))
462 error(NOT_NUM, "+", arg);
463
464 if (floatp(res) && positivep(res)
465 && GET_FLT(exact_to_inexact(res)) >= DBL_MAX && positivep(arg))
466 error(FLT_OVERF, "+", arg);
467 if (floatp(res) && negativep(res)
468 && GET_FLT(exact_to_inexact(res)) <= -DBL_MAX
469 && negativep(arg))
470 error(FLT_OVERF, "+", arg);
471
472 arglist = cdr(arglist);
473 res = plus(res, arg);
474 }
475 return (res);
476 }
477
478 int
f_minus(int arglist)479 f_minus(int arglist)
480 {
481 int res,
482 n;
483
484 res = car(arglist);
485 if ((n = length(arglist)) == 0)
486 error(WRONG_ARGS, "-", arglist);
487 if (n == 1)
488 return (mult(res, makeint(-1)));
489
490 arglist = cdr(arglist);
491 while (!(IS_NIL(arglist))) {
492 int arg;
493
494 arg = car(arglist);
495 if (!numberp(arg) && !vectorp(arg) && !arrayp(arg))
496 error(NOT_NUM, "-", arg);
497
498 if (floatp(res) && positivep(res)
499 && GET_FLT(exact_to_inexact(res)) >= DBL_MAX && negativep(arg))
500 error(FLT_OVERF, "+", arg);
501 if (floatp(res) && negativep(res)
502 && GET_FLT(exact_to_inexact(res)) <= -DBL_MAX
503 && positivep(arg))
504 error(FLT_OVERF, "+", arg);
505 arglist = cdr(arglist);
506 res = minus(res, arg);
507 }
508 return (res);
509 }
510
511 int
f_mult(int arglist)512 f_mult(int arglist)
513 {
514 int res;
515
516 if (nullp(arglist))
517 res = makeint(1);
518 else {
519 res = car(arglist);
520 arglist = cdr(arglist);
521 }
522 while (!(IS_NIL(arglist))) {
523 int arg;
524 double val;
525
526 arg = car(arglist);
527 if (!numberp(arg) && !arrayp(arg) && !vectorp(arg))
528 error(NOT_NUM, "*", arg);
529
530 if (floatp(res) && fabs(GET_FLT(exact_to_inexact(res))) >= DBL_MAX
531 && fabs(GET_FLT(exact_to_inexact(arg))) > 1.0)
532 error(FLT_OVERF, "*", arg);
533 if (floatp(res)
534 && (val = fabs(GET_FLT(exact_to_inexact(res)))) != 0.0
535 && val > 1.0
536 && fabs(GET_FLT(exact_to_inexact(arg))) >= DBL_MAX)
537 error(FLT_OVERF, "*", arg);
538 if (floatp(arg) && fabs(GET_FLT(exact_to_inexact(arg))) >= DBL_MAX
539 && fabs(GET_FLT(exact_to_inexact(res))) > 1.0)
540 error(FLT_OVERF, "*", arg);
541 if (floatp(arg)
542 && (val = fabs(GET_FLT(exact_to_inexact(arg)))) != 0.0
543 && val > 1.0
544 && fabs(GET_FLT(exact_to_inexact(res))) >= DBL_MAX)
545 error(FLT_OVERF, "*", arg);
546 if ((val = fabs(GET_FLT(exact_to_inexact(res)))) != 0.0
547 && val <= DBL_EPSILON
548 && (val = fabs(GET_FLT(exact_to_inexact(arg)))) != 0.0
549 && val <= DBL_EPSILON)
550 error(FLT_UNDERF, "*", arg);
551
552 arglist = cdr(arglist);
553 res = mult(res, arg);
554 }
555 return (res);
556 }
557
558 int
f_quotient(int arglist)559 f_quotient(int arglist)
560 {
561 int res;
562
563 res = car(arglist);
564 arglist = cdr(arglist);
565
566
567 while (!(IS_NIL(arglist))) {
568 int arg;
569 double val;
570
571 arg = car(arglist);
572 if (!numberp(arg))
573 error(NOT_NUM, "quotient", arg);
574 if (zerop(arg))
575 error(DIV_ZERO, "quotient", arg);
576
577 if (fabs(GET_FLT(exact_to_inexact(res))) >= DBL_MAX
578 && fabs(GET_FLT(exact_to_inexact(arg))) < 1.0)
579 error(FLT_OVERF, "quotient", list2(arg, res));
580 if ((val = fabs(GET_FLT(exact_to_inexact(res)))) != 0.0
581 && val <= 1.0
582 && fabs(GET_FLT(exact_to_inexact(arg))) >= DBL_MAX)
583 error(FLT_UNDERF, "quotient", list2(arg, res));
584
585 arglist = cdr(arglist);
586 res = quotient(res, arg);
587
588 }
589 return (res);
590 }
591
592 int
f_smaller(int arglist)593 f_smaller(int arglist)
594 {
595 int arg1,
596 arg2;
597
598 arg1 = car(arglist);
599 arg2 = cadr(arglist);
600 if (length(arglist) != 2)
601 error(WRONG_ARGS, "<", arglist);
602 if (!numberp(arg1))
603 error(NOT_NUM, "<", arg1);
604 if (!numberp(arg2))
605 error(NOT_NUM, "<", arg2);
606
607 if (smallerp(arg1, arg2))
608 return (T);
609 else
610 return (NIL);
611 }
612
613 int
f_eqsmaller(int arglist)614 f_eqsmaller(int arglist)
615 {
616 int arg1,
617 arg2;
618
619 arg1 = car(arglist);
620 arg2 = cadr(arglist);
621 if (length(arglist) != 2)
622 error(WRONG_ARGS, "<=", arglist);
623 if (!numberp(arg1))
624 error(NOT_NUM, "<=", arg1);
625 if (!numberp(arg2))
626 error(NOT_NUM, "<=", arg2);
627
628 if (eqsmallerp(arg1, arg2))
629 return (T);
630 else
631 return (NIL);
632 }
633
634 int
f_greater(int arglist)635 f_greater(int arglist)
636 {
637 int arg1,
638 arg2;
639
640 arg1 = car(arglist);
641 arg2 = cadr(arglist);
642 if (length(arglist) != 2)
643 error(WRONG_ARGS, ">", arglist);
644 if (!numberp(arg1))
645 error(NOT_NUM, ">", arg1);
646 if (!numberp(arg2))
647 error(NOT_NUM, ">", arg2);
648
649 if (greaterp(arg1, arg2))
650 return (T);
651 else
652 return (NIL);
653 }
654
655
656 int
f_eqgreater(int arglist)657 f_eqgreater(int arglist)
658 {
659 int arg1,
660 arg2;
661
662 arg1 = car(arglist);
663 arg2 = cadr(arglist);
664 if (length(arglist) != 2)
665 error(WRONG_ARGS, ">=", arglist);
666 if (length(arglist) != 2)
667 error(WRONG_ARGS, ">=", arglist);
668 if (!numberp(arg1))
669 error(NOT_NUM, ">=", arg1);
670 if (!numberp(arg2))
671 error(NOT_NUM, ">=", arg2);
672
673 if (eqgreaterp(arg1, arg2))
674 return (T);
675 else
676 return (NIL);
677 }
678
679 int
f_sin(int arglist)680 f_sin(int arglist)
681 {
682 int arg1;
683 double val;
684
685 arg1 = car(arglist);
686 if (length(arglist) != 1)
687 error(WRONG_ARGS, "sin", arglist);
688 if (!numberp(arg1))
689 error(NOT_NUM, "sin", arg1);
690 val = sin(GET_FLT(exact_to_inexact(arg1)));
691 return (makeflt(val));
692 }
693
694 int
f_cos(int arglist)695 f_cos(int arglist)
696 {
697 int arg1;
698 double val;
699
700 arg1 = car(arglist);
701 if (length(arglist) != 1)
702 error(WRONG_ARGS, "cos", arglist);
703 if (!numberp(arg1))
704 error(NOT_NUM, "cos", arg1);
705 val = cos(GET_FLT(exact_to_inexact(arg1)));
706 return (makeflt(val));
707 }
708
709 int
f_tan(int arglist)710 f_tan(int arglist)
711 {
712 int arg1;
713 double val;
714
715 arg1 = car(arglist);
716 if (length(arglist) != 1)
717 error(WRONG_ARGS, "tan", arglist);
718 if (!numberp(arg1))
719 error(NOT_NUM, "tan", arg1);
720 val = tan(GET_FLT(exact_to_inexact(arg1)));
721 return (makeflt(val));
722 }
723
724 int
f_atan(int arglist)725 f_atan(int arglist)
726 {
727 int arg1;
728 double val;
729
730 arg1 = car(arglist);
731 if (length(arglist) != 1)
732 error(WRONG_ARGS, "atan", arglist);
733 if (!numberp(arg1))
734 error(NOT_NUM, "atan", arg1);
735 val = atan(GET_FLT(exact_to_inexact(arg1)));
736 return (makeflt(val));
737 }
738
739 int
f_sinh(int arglist)740 f_sinh(int arglist)
741 {
742 int arg1;
743 double val;
744
745 arg1 = car(arglist);
746 if (length(arglist) != 1)
747 error(WRONG_ARGS, "sinh", arglist);
748 if (!numberp(arg1))
749 error(NOT_NUM, "sinh", arg1);
750 val = GET_FLT(exact_to_inexact(arg1));
751 if (val >= 10000000000.0)
752 error(FLT_OVERF, "sinh", arg1);
753 if (val <= -10000000000.0)
754 error(FLT_UNDERF, "sinh", arg1);
755 val = sinh(val);
756 return (makeflt(val));
757 }
758
759 int
f_cosh(int arglist)760 f_cosh(int arglist)
761 {
762 int arg1;
763 double val;
764
765 arg1 = car(arglist);
766 if (length(arglist) != 1)
767 error(WRONG_ARGS, "cosh", arglist);
768 if (!numberp(arg1))
769 error(NOT_NUM, "cosh", arg1);
770
771 val = GET_FLT(exact_to_inexact(arg1));
772 if (val >= 10000000000.0)
773 error(FLT_OVERF, "cosh", arg1);
774 if (val <= -10000000000.0)
775 error(FLT_UNDERF, "cosh", arg1);
776 val = cosh(val);
777 return (makeflt(val));
778 }
779
780 int
f_tanh(int arglist)781 f_tanh(int arglist)
782 {
783 int arg1;
784 double val;
785
786 arg1 = car(arglist);
787 if (length(arglist) != 1)
788 error(WRONG_ARGS, "tanh", arglist);
789 if (!numberp(arg1))
790 error(NOT_NUM, "tanh", arg1);
791
792 val = GET_FLT(exact_to_inexact(arg1));
793 if (val >= 10000000000.0)
794 error(FLT_OVERF, "tanh", arg1);
795 if (val <= -10000000000.0)
796 error(FLT_UNDERF, "tanh", arg1);
797 val = tanh(val);
798 return (makeflt(val));
799 }
800
801 int
f_atanh(int arglist)802 f_atanh(int arglist)
803 {
804 int arg1;
805 double val;
806
807 arg1 = car(arglist);
808 if (length(arglist) != 1)
809 error(WRONG_ARGS, "atanh", arglist);
810 if (!numberp(arg1))
811 error(NOT_NUM, "atanh", arg1);
812 val = GET_FLT(exact_to_inexact(arg1));
813 if (val >= 1.0 || val <= -1.0)
814 error(FLT_OUT_OF_DOMAIN, "atanh", arg1);
815 val = atanh(val);
816 return (makeflt(val));
817 }
818
819 int
f_floor(int arglist)820 f_floor(int arglist)
821 {
822 int arg1;
823
824 arg1 = car(arglist);
825 if (length(arglist) != 1)
826 error(WRONG_ARGS, "floor", arglist);
827 if (!numberp(arg1))
828 error(NOT_NUM, "floor", arg1);
829
830
831 if (floatp(arg1)) {
832 double x;
833
834 x = floor(GET_FLT(arg1));
835 if (x <= 999999999 && x >= -999999999)
836 return (makeint((int) x));
837 else if (x <= 999999999999999999 && x >= -999999999999999999)
838 return (makelong((long long int) x));
839 else
840 return (makeflt(x));
841 } else
842 return (arg1);
843 }
844
845 int
f_ceiling(int arglist)846 f_ceiling(int arglist)
847 {
848 int arg1;
849
850 arg1 = car(arglist);
851 if (length(arglist) != 1)
852 error(WRONG_ARGS, "ceiling", arglist);
853 if (!numberp(arg1))
854 error(NOT_NUM, "ceiling", arg1);
855
856 if (floatp(arg1)) {
857 double x;
858
859 x = GET_FLT(arg1);
860 if (x <= 999999999.0 && x >= -999999999.0)
861 return (makeint((int) ceil(x)));
862 else
863 return (makelong((long long int) (ceil(x))));
864 } else
865 return (arg1);
866 }
867
868 int
f_truncate(int arglist)869 f_truncate(int arglist)
870 {
871 int arg1;
872
873 arg1 = car(arglist);
874 if (length(arglist) != 1)
875 error(WRONG_ARGS, "truncate", arglist);
876 if (!numberp(arg1))
877 error(NOT_NUM, "truncate", arg1);
878
879 if (floatp(arg1)) {
880 double x;
881
882 x = GET_FLT(arg1);
883 if (x >= 0 && x <= 999999999.0)
884 return (makeint((int) floor(x)));
885 else if (x > 999999999.0)
886 return (makelong((long long int) floor(x)));
887 else if (x < 0 && x >= -999999999.0)
888 return (makeint((int) ceil(x)));
889 else
890 return (makelong((long long int) ceil(x)));
891 } else
892 return (arg1);
893 }
894
895
896 int
f_round(int arglist)897 f_round(int arglist)
898 {
899 int arg1;
900
901 arg1 = car(arglist);
902 if (length(arglist) != 1)
903 error(WRONG_ARGS, "round", arglist);
904 if (!numberp(arg1))
905 error(NOT_NUM, "round", arg1);
906
907 if (floatp(arg1)) {
908 double x,
909 f,
910 c;
911
912 x = GET_FLT(arg1);
913 f = floor(x);
914 c = ceil(x);
915 if (x == (f + c) / 2)
916 if (fmod(f, 2.0) == 0.0)
917 x = f;
918 else
919 x = c;
920 else
921 x = round(x);
922 if (x <= 999999999.0 && x >= -999999999.0)
923 return (makeint((int) x));
924 else
925 return (makelong((long long int) x));
926 } else
927 return (arg1);
928 }
929
930 int
f_gcd(int arglist)931 f_gcd(int arglist)
932 {
933 int arg1,
934 arg2;
935
936 arg1 = car(arglist);
937 arg2 = cadr(arglist);
938 if (length(arglist) != 2)
939 error(WRONG_ARGS, "gcd", arglist);
940 if (!numberp(arg1))
941 error(NOT_NUM, "gcd", arg1);
942 if (!numberp(arg2))
943 error(NOT_NUM, "gcd", arg2);
944
945 return (gcd(arg1, arg2));
946 }
947
948 int
f_lcm(int arglist)949 f_lcm(int arglist)
950 {
951 int arg1,
952 arg2;
953
954 arg1 = car(arglist);
955 arg2 = cadr(arglist);
956 if (length(arglist) != 2)
957 error(WRONG_ARGS, "lcm", arglist);
958 if (!numberp(arg1))
959 error(NOT_NUM, "lcm", arg1);
960 if (!numberp(arg2))
961 error(NOT_NUM, "lcm", arg2);
962
963 return (lcm(arg1, arg2));
964 }
965
966 int
f_max(int arglist)967 f_max(int arglist)
968 {
969 int res;
970
971 res = car(arglist);
972 if (!numberp(res))
973 error(NOT_NUM, "max", res);
974 arglist = cdr(arglist);
975 while (!nullp(arglist)) {
976 int arg1;
977
978 arg1 = car(arglist);
979 if (!numberp(arg1))
980 error(NOT_NUM, "max", arg1);
981 if (greaterp(arg1, res))
982 res = arg1;
983 arglist = cdr(arglist);
984 }
985 return (res);
986 }
987
988 int
f_min(int arglist)989 f_min(int arglist)
990 {
991 int res;
992
993 res = car(arglist);
994 if (!numberp(res))
995 error(NOT_NUM, "min", res);
996 arglist = cdr(arglist);
997 while (!nullp(arglist)) {
998 int arg1;
999
1000 arg1 = car(arglist);
1001 if (!numberp(arg1))
1002 error(NOT_NUM, "min", arg1);
1003 if (smallerp(arg1, res))
1004 res = arg1;
1005 arglist = cdr(arglist);
1006 }
1007 return (res);
1008
1009 }
1010
1011 int
f_float(int arglist)1012 f_float(int arglist)
1013 {
1014 int arg1;
1015
1016 arg1 = car(arglist);
1017 if (length(arglist) != 1)
1018 error(WRONG_ARGS, "float", arglist);
1019 if (!numberp(arg1))
1020 error(NOT_NUM, "float", arg1);
1021 return (exact_to_inexact(arg1));
1022 }
1023
1024 int
f_floatp(int arglist)1025 f_floatp(int arglist)
1026 {
1027 int arg;
1028
1029 arg = car(arglist);
1030 if (length(arglist) != 1)
1031 error(WRONG_ARGS, "floatp", arglist);
1032 if (IS_FLOAT(arg))
1033 return (T);
1034 else
1035 return (NIL);
1036 }
1037
1038
1039 int
f_div(int arglist)1040 f_div(int arglist)
1041 {
1042 int arg1,
1043 arg2,
1044 q,
1045 r;
1046
1047 arg1 = car(arglist);
1048 arg2 = cadr(arglist);
1049 if (length(arglist) != 2)
1050 error(WRONG_ARGS, "div", arglist);
1051 if (!numberp(arg1))
1052 error(NOT_INT, "div", arg1);
1053 if (!numberp(arg2))
1054 error(NOT_INT, "div", arg2);
1055 if (zerop(arg2))
1056 error(DIV_ZERO, "div", arglist);
1057
1058 q = divide(arg1, arg2);
1059 r = s_remainder(arg1, arg2);
1060 if (zerop(r))
1061 return (q);
1062 else if (positivep(arg1) && negativep(arg2))
1063 return (minus(q, makeint(1)));
1064 else if (negativep(arg1) && positivep(arg2))
1065 return (minus(q, makeint(1)));
1066 else
1067 return (q);
1068 }
1069
1070 int
f_integerp(int arglist)1071 f_integerp(int arglist)
1072 {
1073 int arg;
1074
1075 arg = car(arglist);
1076 if (length(arglist) != 1)
1077 error(WRONG_ARGS, "integerp", arglist);
1078 if (math_integerp(arg))
1079 return (T);
1080 else
1081 return (NIL);
1082 }
1083
1084 int
f_abs(int arglist)1085 f_abs(int arglist)
1086 {
1087 int arg1;
1088
1089 arg1 = car(arglist);
1090 if (length(arglist) != 1)
1091 error(WRONG_ARGS, "abs", arglist);
1092 if (!numberp(arg1))
1093 error(NOT_NUM, "abs", arg1);
1094 return (absolute(arg1));
1095 }
1096
1097 int
f_mod(int arglist)1098 f_mod(int arglist)
1099 {
1100 int arg1,
1101 arg2,
1102 div;
1103
1104 arg1 = car(arglist);
1105 arg2 = cadr(arglist);
1106 if (length(arglist) != 2)
1107 error(WRONG_ARGS, "mod", arglist);
1108 if (!integerp(arg1) && !longnump(arg1) && !bignump(arg1))
1109 error(NOT_INT, "mod", arg1);
1110 if (!integerp(arg2) && !longnump(arg2) && !bignump(arg2))
1111 error(NOT_INT, "mod", arg2);
1112
1113 div = f_div(arglist);
1114 return (minus(arg1, mult(arg2, div)));
1115
1116 }
1117
1118 int
f_exp(int arglist)1119 f_exp(int arglist)
1120 {
1121 int arg1;
1122 double val;
1123
1124 arg1 = car(arglist);
1125 if (length(arglist) != 1)
1126 error(WRONG_ARGS, "exp", arglist);
1127 if (!numberp(arg1))
1128 error(NOT_NUM, "exp", arg1);
1129
1130 val = GET_FLT(exact_to_inexact(arg1));
1131 if (val >= 10000000000.0)
1132 error(FLT_OVERF, "exp", arg1);
1133 if (val <= -10000000000.0)
1134 error(FLT_UNDERF, "exp", arg1);
1135 return (makeflt(exp(val)));
1136 }
1137
1138 int
f_log(int arglist)1139 f_log(int arglist)
1140 {
1141 int arg1;
1142
1143 arg1 = car(arglist);
1144 if (length(arglist) != 1)
1145 error(WRONG_ARGS, "log", arglist);
1146 if (!numberp(arg1))
1147 error(NOT_NUM, "log", arg1);
1148 if (!positivep(arg1))
1149 error(OUT_OF_REAL, "log", arglist);
1150
1151 return (makeflt(log(GET_FLT(exact_to_inexact(arg1)))));
1152 }
1153
1154 int
f_expt(int arglist)1155 f_expt(int arglist)
1156 {
1157 int arg1,
1158 arg2,
1159 i;
1160 double x,
1161 y;
1162
1163 arg1 = car(arglist);
1164 arg2 = cadr(arglist);
1165 if (length(arglist) != 2)
1166 error(WRONG_ARGS, "expt", arglist);
1167 if (!numberp(arg1))
1168 error(NOT_NUM, "expt", arg1);
1169 if (!numberp(arg2))
1170 error(NOT_NUM, "expt", arg2);
1171 if (zerop(arg1) && negativep(arg2))
1172 error(IMPROPER_ARGS, "expt", arglist);
1173 if (zerop(arg1) && zerop(arg2) && floatp(arg2))
1174 error(IMPROPER_ARGS, "expt", arglist);
1175 if (negativep(arg1) && floatp(arg2))
1176 error(IMPROPER_ARGS, "expt", arglist);
1177 if (greaterp(arg1, makeint(1)) && floatp(arg2)
1178 && GET_FLT(arg2) >= DBL_MAX)
1179 error(FLT_OVERF, "expt", arglist);
1180 if (greaterp(arg1, makeint(1)) && floatp(arg2)
1181 && GET_FLT(arg2) <= -DBL_MAX)
1182 error(FLT_UNDERF, "expt", arglist);
1183 if (greaterp(arg2, makeint(1)) && floatp(arg1)
1184 && GET_FLT(arg1) >= DBL_MAX)
1185 error(FLT_OVERF, "expt", arglist);
1186 if (negativep(arg2) && floatp(arg1) && GET_FLT(arg1) >= DBL_MAX)
1187 error(FLT_UNDERF, "expt", arglist);
1188 if (greaterp(arg2, makeint(1)) && floatp(arg1)
1189 && GET_FLT(arg1) <= -DBL_MAX)
1190 error(FLT_OVERF, "expt", arglist);
1191 if (negativep(arg2) && floatp(arg1) && GET_FLT(arg1) <= -DBL_MAX)
1192 error(FLT_UNDERF, "expt", arglist);
1193
1194 if ((integerp(arg1) || longnump(arg1) || bignump(arg1))
1195 && integerp(arg2) && GET_INT(arg2) == 0)
1196 return (makeint(1));
1197
1198 if (integerp(arg1) && GET_INT(arg1) == 1
1199 && (floatp(arg2) || negativep(arg2)))
1200 return (makeflt(1.0));
1201
1202 if (integerp(arg1) && GET_INT(arg1) == -1 && floatp(arg2)) {
1203 x = GET_FLT(arg2);
1204 if (x - ceil(x) == 0.0 && (int) x % 2 == 0)
1205 return (makeflt(1.0));
1206 else
1207 return (makeflt(-1.0));
1208 }
1209 if (integerp(arg1) && GET_INT(arg1) == -1 && integerp(arg2)) {
1210 i = GET_INT(arg2);
1211 if (i >= 0) {
1212 if (i % 2 == 0)
1213 return (makeint(1));
1214 else
1215 return (makeint(-1));
1216 } else {
1217 if (i % 2 == 0)
1218 return (makeflt(1.0));
1219 else
1220 return (makeflt(-1.0));
1221 }
1222 }
1223 if (integerp(arg1) && GET_INT(arg1) == -1
1224 && (longnump(arg2) || bignump(arg2))) {
1225 int j,
1226 k;
1227
1228 i = makeint(2);
1229 j = divide(arg2, i);
1230 k = minus(arg2, mult(j, i));
1231 if (positivep(arg2)) {
1232 if (zerop(k))
1233 return (makeint(1));
1234 else
1235 return (makeint(-1));
1236 } else {
1237 if (zerop(k))
1238 return (makeflt(1.0));
1239 else
1240 return (makeflt(-1.0));
1241 }
1242 }
1243 if ((integerp(arg1) || longnump(arg1) || bignump(arg1))
1244 && (integerp(arg2) && GET_INT(arg2) > 0))
1245 return (expt(arg1, GET_INT(arg2)));
1246
1247 if ((integerp(arg1) || floatp(arg1)) &&
1248 (integerp(arg2) || floatp(arg2))) {
1249 double z;
1250
1251 arg1 = exact_to_inexact(arg1);
1252 arg2 = exact_to_inexact(arg2);
1253 x = GET_FLT(arg1);
1254 y = GET_FLT(arg2);
1255 z = pow(x, y);
1256 return (makeflt(z));
1257 }
1258 if (integerp(arg1)
1259 && (integerp(arg2) || longnump(arg2) || bignump(arg2))) {
1260 if (GET_INT(arg1) == 1)
1261 return (arg1);
1262 else if (GET_INT(arg1) == 0)
1263 return (arg1);
1264 else if (GET_INT(arg1) == -1) {
1265 if (zerop(s_remainder(arg2, makeint(2))))
1266 return (makeint(1));
1267 else
1268 return (arg1);
1269 }
1270 }
1271 if (floatp(arg1) && (longnump(arg2) || bignump(arg2))) {
1272 if (GET_FLT(arg1) == 1.0)
1273 return (arg1);
1274 else if (GET_FLT(arg1) == 0.0)
1275 return (arg1);
1276 else if (GET_FLT(arg1) == -1.0) {
1277 if (zerop(s_remainder(arg2, makeint(2))))
1278 return (makeflt(1.0));
1279 else
1280 return (arg1);
1281 }
1282 }
1283 if (longnump(arg1) && integerp(arg2)) {
1284 if (GET_INT(arg2) == 1) {
1285 x = GET_FLT(exact_to_inexact(arg1));
1286 y = x;
1287 return (makeflt(y));
1288 } else if (GET_INT(arg2) == 2) {
1289 x = GET_FLT(exact_to_inexact(arg1));
1290 y = x * x;
1291 return (makeflt(y));
1292 } else if (GET_INT(arg2) == -1) {
1293 x = GET_FLT(exact_to_inexact(arg1));
1294 y = 1.0 / x;
1295 return (makeflt(y));
1296 } else if (GET_INT(arg2) == -2) {
1297 x = GET_FLT(exact_to_inexact(arg1));
1298 y = 1.0 / (x * x);
1299 return (makeflt(y));
1300 }
1301 }
1302 if (longnump(arg1) && floatp(arg2)) {
1303 if (GET_FLT(arg2) == 0.0) {
1304 return (makeflt(1.0));
1305 } else if (GET_FLT(arg2) == 1.0) {
1306 x = GET_FLT(exact_to_inexact(arg1));
1307 y = x;
1308 return (makeflt(y));
1309 } else if (GET_FLT(arg2) == 2.0) {
1310 x = GET_FLT(exact_to_inexact(arg1));
1311 y = x * x;
1312 return (makeflt(y));
1313 } else if (GET_FLT(arg2) == -1.0) {
1314 x = GET_FLT(exact_to_inexact(arg1));
1315 y = 1.0 / x;
1316 return (makeflt(y));
1317 } else if (GET_FLT(arg2) == -2.0) {
1318 x = GET_FLT(exact_to_inexact(arg1));
1319 y = 1.0 / (x * x);
1320 return (makeflt(y));
1321 }
1322 }
1323 if (positivep(arg2))
1324 error(FLT_OVERF, "expt", arglist);
1325 else
1326 error(FLT_UNDERF, "expt", arglist);
1327 return (UNDEF);
1328 }
1329
1330 int
expt(int x,int y)1331 expt(int x, int y)
1332 {
1333 int res,
1334 p;
1335
1336 res = makeint(1);
1337 p = x;
1338 while (y > 0) {
1339 if ((y % 2) == 0) {
1340 p = mult(p, p);
1341 y = y / 2;
1342 } else {
1343 res = mult(res, p);
1344 y = y - 1;
1345 }
1346 }
1347 return (res);
1348 }
1349
1350
1351 int
f_sqrt(int arglist)1352 f_sqrt(int arglist)
1353 {
1354 int arg1;
1355 double x;
1356
1357 arg1 = car(arglist);
1358 if (length(arglist) != 1)
1359 error(WRONG_ARGS, "sqrt", arglist);
1360 if (!numberp(arg1))
1361 error(NOT_NUM, "sqrt", arg1);
1362 if (negativep(arg1))
1363 error(OUT_OF_DOMAIN, "sqrt", arg1);
1364
1365 x = sqrt(GET_FLT(exact_to_inexact(arg1)));
1366 if ((integerp(arg1) || longnump(arg1) || bignump(arg1))
1367 && ceil(x) == floor(x)) {
1368 if (x <= 999999999.0)
1369 return (makeint((int) x));
1370 else if (x <= 999999999999999999.0)
1371 return (makelong((long long int) x));
1372 else
1373 return (makeflt(x));
1374 } else
1375 return (makeflt(x));
1376 }
1377
1378
1379 int
f_isqrt(int arglist)1380 f_isqrt(int arglist)
1381 {
1382 int arg1;
1383
1384 arg1 = car(arglist);
1385 if (length(arglist) != 1)
1386 error(WRONG_ARGS, "isqrt", arglist);
1387 if (!numberp(arg1))
1388 error(NOT_NUM, "isqrt", arg1);
1389 if (negativep(arg1))
1390 error(OUT_OF_DOMAIN, "isqrt", arg1);
1391 return (isqrt(arg1));
1392 }
1393
1394 int
f_atan2(int arglist)1395 f_atan2(int arglist)
1396 {
1397 int arg1,
1398 arg2;
1399
1400 arg1 = car(arglist);
1401 arg2 = cadr(arglist);
1402 if (length(arglist) != 2)
1403 error(WRONG_ARGS, "atan2", arglist);
1404 if (!numberp(arg1))
1405 error(NOT_NUM, "atan2", arg1);
1406 if (!numberp(arg2))
1407 error(NOT_NUM, "atan2", arg2);
1408 return (angle(arg1, arg2));
1409 }
1410
1411 int
f_reciprocal(int arglist)1412 f_reciprocal(int arglist)
1413 {
1414 int arg1;
1415 double val;
1416
1417 arg1 = car(arglist);
1418 if (length(arglist) != 1)
1419 error(WRONG_ARGS, "resiprocal", arglist);
1420 if (!numberp(arg1))
1421 error(NOT_NUM, "resiprocal", arg1);
1422
1423 val = GET_FLT(exact_to_inexact(arg1));
1424 if (val == 0.0)
1425 error(DIV_ZERO, "resiprocal", arg1);
1426 if (val >= DBL_MAX)
1427 error(FLT_UNDERF, "resiprocal", arg1);
1428 if (val <= -DBL_MAX)
1429 error(FLT_UNDERF, "resiprocal", arg1);
1430 return (quotient(makeint(1), arg1));
1431 }
1432
1433 int
f_numeqp(int arglist)1434 f_numeqp(int arglist)
1435 {
1436 int arg1,
1437 arg2;
1438
1439 arg1 = car(arglist);
1440 arg2 = cadr(arglist);
1441 if (length(arglist) != 2)
1442 error(WRONG_ARGS, "=", arglist);
1443 if (!numberp(arg1))
1444 error(NOT_NUM, "=", arg1);
1445 if (!numberp(arg2))
1446 error(NOT_NUM, "=", arg2);
1447
1448 if (numeqp(arg1, arg2))
1449 return (T);
1450 else
1451 return (NIL);
1452 }
1453
1454 int
f_notnumeqp(int arglist)1455 f_notnumeqp(int arglist)
1456 {
1457 int arg1,
1458 arg2;
1459
1460 arg1 = car(arglist);
1461 arg2 = cadr(arglist);
1462 if (length(arglist) != 2)
1463 error(WRONG_ARGS, "/=", arglist);
1464 if (!numberp(arg1))
1465 error(NOT_NUM, "/=", arg1);
1466 if (!numberp(arg2))
1467 error(NOT_NUM, "/=", arg2);
1468
1469 if (numeqp(arg1, arg2))
1470 return (NIL);
1471 else
1472 return (T);
1473 }
1474
1475
1476 // list function
1477
1478 int
f_car(int arglist)1479 f_car(int arglist)
1480 {
1481 int arg;
1482
1483 arg = car(arglist);
1484 if (!(IS_LIST(arg)))
1485 error(NOT_CONS, "car", arg);
1486 if (length(arglist) != 1)
1487 error(WRONG_ARGS, "car", arglist);
1488 return (car(arg));
1489 }
1490
1491 int
f_cdr(int arglist)1492 f_cdr(int arglist)
1493 {
1494 int arg;
1495
1496 arg = car(arglist);
1497 if (!(IS_LIST(arg)))
1498 error(NOT_CONS, "cdr", arg);
1499 if (length(arglist) != 1)
1500 error(WRONG_ARGS, "cdr", arglist);
1501 return (cdr(arg));
1502 }
1503
1504 int
f_cons(int arglist)1505 f_cons(int arglist)
1506 {
1507 int arg1,
1508 arg2;
1509
1510 arg1 = car(arglist);
1511 arg2 = cadr(arglist);
1512 if (length(arglist) != 2)
1513 error(WRONG_ARGS, "cons", arglist);
1514 return (cons(arg1, arg2));
1515 }
1516
1517 int
f_eq(int arglist)1518 f_eq(int arglist)
1519 {
1520 int arg1,
1521 arg2;
1522
1523 arg1 = car(arglist);
1524 arg2 = cadr(arglist);
1525 if (length(arglist) != 2)
1526 error(WRONG_ARGS, "eq", arglist);
1527 if (eqp(arg1, arg2))
1528 return (T);
1529 else
1530 return (NIL);
1531 }
1532
1533 int
f_eql(int arglist)1534 f_eql(int arglist)
1535 {
1536 int arg1,
1537 arg2;
1538
1539 arg1 = car(arglist);
1540 arg2 = cadr(arglist);
1541 if (length(arglist) != 2)
1542 error(WRONG_ARGS, "eql", arglist);
1543 if (eqlp(arg1, arg2))
1544 return (T);
1545 else
1546 return (NIL);
1547 }
1548
1549 int
f_equal(int arglist)1550 f_equal(int arglist)
1551 {
1552 int arg1,
1553 arg2;
1554
1555 arg1 = car(arglist);
1556 arg2 = cadr(arglist);
1557 if (length(arglist) != 2)
1558 error(WRONG_ARGS, "equal", arglist);
1559 if (equalp(arg1, arg2))
1560 return (T);
1561 else
1562 return (NIL);
1563 }
1564
1565 int
f_not(int arglist)1566 f_not(int arglist)
1567 {
1568 int arg;
1569
1570 arg = car(arglist);
1571 if (length(arglist) != 1)
1572 error(WRONG_ARGS, "not", arglist);
1573 if (IS_NIL(arg))
1574 return (T);
1575 else
1576 return (NIL);
1577 }
1578
1579 int
f_nullp(int arglist)1580 f_nullp(int arglist)
1581 {
1582 int arg;
1583
1584 arg = car(arglist);
1585 if (length(arglist) != 1)
1586 error(WRONG_ARGS, "not", arglist);
1587 if (nullp(arg))
1588 return (T);
1589 else
1590 return (NIL);
1591 }
1592
1593 int
f_atomp(int arglist)1594 f_atomp(int arglist)
1595 {
1596 int arg;
1597
1598 arg = car(arglist);
1599 if (length(arglist) != 1)
1600 error(WRONG_ARGS, "atom", arglist);
1601 if (atomp(arg))
1602 return (T);
1603 else
1604 return (NIL);
1605 }
1606
1607 int
f_functionp(int arglist)1608 f_functionp(int arglist)
1609 {
1610 int arg;
1611
1612 arg = car(arglist);
1613 if (length(arglist) != 1)
1614 error(WRONG_ARGS, "functionp", arglist);
1615 if (IS_FUNC(arg) || IS_SUBR(arg) || IS_GENERIC(arg))
1616 return (T);
1617 else
1618 return (NIL);
1619 }
1620
1621 int
f_consp(int arglist)1622 f_consp(int arglist)
1623 {
1624 int arg;
1625
1626 arg = car(arglist);
1627 if (length(arglist) != 1)
1628 error(WRONG_ARGS, "consp", arglist);
1629 if (IS_LIST(arg))
1630 return (T);
1631 else
1632 return (NIL);
1633 }
1634
1635
1636 int
f_list(int arglist)1637 f_list(int arglist)
1638 {
1639 return (list(arglist));
1640 }
1641
1642 int
f_append(int arglist)1643 f_append(int arglist)
1644 {
1645 int arg1;
1646
1647 arg1 = car(arglist);
1648 if (!listp(arg1) && nullp(arglist))
1649 error(NOT_CONS, "append", arg1);
1650 if (length(arg1) >= fc) {
1651 shelterpush(arglist);
1652 (void) gbc();
1653 shelterpop();
1654 }
1655 if (nullp(arglist))
1656 return (NIL);
1657 else if (nullp(cdr(arglist)))
1658 return (car(arglist));
1659 else if (nullp(arg1))
1660 return (f_append(cdr(arglist)));
1661 else
1662 return (append(car(arglist), f_append(cdr(arglist))));
1663 }
1664
1665
1666 int
f_symbolp(int arglist)1667 f_symbolp(int arglist)
1668 {
1669 int arg1;
1670
1671 arg1 = car(arglist);
1672 if (length(arglist) != 1)
1673 error(WRONG_ARGS, "symbolp", arglist);
1674 if (symbolp(arg1))
1675 return (T);
1676 else
1677 return (NIL);
1678 }
1679
1680 int
f_numberp(int arglist)1681 f_numberp(int arglist)
1682 {
1683 int arg1;
1684
1685 arg1 = car(arglist);
1686 if (length(arglist) != 1)
1687 error(WRONG_ARGS, "numberp", arglist);
1688 if (numberp(arg1))
1689 return (T);
1690 else
1691 return (NIL);
1692 }
1693
1694 int
f_listp(int arglist)1695 f_listp(int arglist)
1696 {
1697 int arg1;
1698
1699 arg1 = car(arglist);
1700 if (length(arglist) != 1)
1701 error(WRONG_ARGS, "listp", arglist);
1702 if (listp(arg1))
1703 return (T);
1704 else
1705 return (NIL);
1706 }
1707
1708
1709 int
f_member(int arglist)1710 f_member(int arglist)
1711 {
1712 int arg1,
1713 arg2;
1714
1715 arg1 = car(arglist);
1716 arg2 = cadr(arglist);
1717
1718 return (member(arg1, arg2));
1719 }
1720
1721 int
f_assoc(int arglist)1722 f_assoc(int arglist)
1723 {
1724 int arg1,
1725 arg2;
1726
1727 arg1 = car(arglist);
1728 arg2 = cadr(arglist);
1729 if (length(arglist) != 2)
1730 error(WRONG_ARGS, "assoc", arglist);
1731 if (!listp(arg2))
1732 error(NOT_LIST, "assoc", arg2);
1733 if (!assoclistp(arg2))
1734 error(IMPROPER_ARGS, "assoc", arg2);
1735
1736 return (assoc(arg1, arg2));
1737 }
1738
1739 int
f_mapcar(int arglist)1740 f_mapcar(int arglist)
1741 {
1742 int arg1,
1743 arg2;
1744
1745 arg1 = car(arglist);
1746 arg2 = cdr(arglist);
1747
1748 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
1749 error(NOT_FUNC, "mapcar", arg1);
1750 return (mapcar(arg1, arg2));
1751 }
1752
1753 int
f_mapc(int arglist)1754 f_mapc(int arglist)
1755 {
1756 int arg1,
1757 arg2;
1758
1759 arg1 = car(arglist);
1760 arg2 = cdr(arglist);
1761
1762 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
1763 error(NOT_FUNC, "mapc", arg1);
1764
1765 return (mapc(arg1, arg2));
1766 }
1767
1768 int
f_maplist(int arglist)1769 f_maplist(int arglist)
1770 {
1771 int arg1,
1772 arg2;
1773
1774 arg1 = car(arglist);
1775 arg2 = cdr(arglist);
1776
1777 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
1778 error(NOT_FUNC, "maplist", arg1);
1779
1780 return (maplist(arg1, arg2));
1781 }
1782
1783 int
f_mapl(int arglist)1784 f_mapl(int arglist)
1785 {
1786 int arg1,
1787 arg2;
1788
1789 arg1 = car(arglist);
1790 arg2 = cdr(arglist);
1791 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
1792 error(NOT_FUNC, "mapl", arg1);
1793
1794 return (mapl(arg1, arg2));
1795 }
1796
1797 int
f_mapcon(int arglist)1798 f_mapcon(int arglist)
1799 {
1800 int arg1,
1801 arg2;
1802
1803 arg1 = car(arglist);
1804 arg2 = cdr(arglist);
1805
1806 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
1807 error(NOT_FUNC, "mapcon", arg1);
1808
1809 return (mapcon(arg1, arg2));
1810 }
1811
1812 int
f_mapcan(int arglist)1813 f_mapcan(int arglist)
1814 {
1815 int arg1,
1816 arg2;
1817
1818 arg1 = car(arglist);
1819 arg2 = cdr(arglist);
1820 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
1821 error(NOT_FUNC, "mapcan", arg1);
1822 return (mapcan(arg1, arg2));
1823 }
1824
1825
1826 int
f_map_into(int arglist)1827 f_map_into(int arglist)
1828 {
1829 int arg1,
1830 arg2,
1831 arg3,
1832 arg4,
1833 val,
1834 i,
1835 res;
1836
1837 arg1 = car(arglist);
1838 arg2 = cadr(arglist);
1839 arg3 = cddr(arglist);
1840
1841 if (listp(arg1) && nullp(arg3))
1842 arg4 = arg1;
1843 else if (listp(arg1))
1844 arg4 = map_into_to_list(arg3);
1845 else if (vectorp(arg1) && nullp(arg3))
1846 arg4 = vector_to_list(arg1);
1847 else if (vectorp(arg1))
1848 arg4 = map_into_to_list(arg3);
1849 else if (stringp(arg1) && nullp(arg3))
1850 arg4 = string_to_list(arg1);
1851 else if (stringp(arg1))
1852 arg4 = map_into_to_list(arg3);
1853 else
1854 error(ILLEGAL_ARGS, "map-into", arg1);
1855
1856 if (IS_FUNC(arg2) && GET_OPT(arg2) == 0) // when arg2 is thunk
1857 // (lambda () ...)
1858 val = reverse(map_into_thunk(arg2, arg4));
1859 else
1860 val = mapcar(arg2, arg4);
1861
1862 res = arg1;
1863 if (listp(arg1)) {
1864 while (!nullp(val)) {
1865 SET_CAR(res, car(val));
1866 res = cdr(res);
1867 val = cdr(val);
1868 }
1869 } else if (vectorp(arg1)) {
1870 if (nullp(val)) // when val is null return arg1
1871 return (arg1);
1872 i = 0;
1873 while (!nullp(val)) {
1874 SET_VEC_ELT(res, i, car(val));
1875 i++;
1876 val = cdr(val);
1877 }
1878 } else if (stringp(arg1)) {
1879 if (nullp(val)) // when val is null return arg1
1880 return (arg1);
1881 i = 0;
1882 while (!nullp(val)) {
1883 if (!charp(car(val))) // when val is not char list
1884 // return arg1
1885 return (arg1);
1886 STRING_SET(res, i, GET_CHAR(car(val)));
1887 i++;
1888 val = cdr(val);
1889 }
1890 }
1891 if (findenv(arg1) != FAILSE)
1892 setlexenv(arg1, res);
1893 else if (GET_OPT(arg1) == GLOBAL)
1894 SET_CDR(arg1, res);
1895 return (arg1);
1896 }
1897
1898 int
map_into_thunk(int x,int y)1899 map_into_thunk(int x, int y)
1900 {
1901 if (nullp(y))
1902 return (NIL);
1903 else
1904 return (cons(apply(x, NIL), map_into_thunk(x, cdr(y))));
1905 }
1906
1907 int
map_into_to_list(int x)1908 map_into_to_list(int x)
1909 {
1910 if (nullp(x))
1911 return (NIL);
1912 else if (listp(car(x)))
1913 return (cons(car(x), map_into_to_list(cdr(x))));
1914 else if (vectorp(car(x)))
1915 return (cons(vector_to_list(car(x)), map_into_to_list(cdr(x))));
1916 else if (stringp(car(x)))
1917 return (cons(string_to_list(car(x)), map_into_to_list(cdr(x))));
1918 else {
1919 error(ILLEGAL_ARGS, "map-into", x);
1920 return (NIL);
1921 }
1922 }
1923
1924
1925 int
f_reverse(int arglist)1926 f_reverse(int arglist)
1927 {
1928 int arg1;
1929
1930 arg1 = car(arglist);
1931 if (length(arglist) != 1)
1932 error(WRONG_ARGS, "reverse", arglist);
1933 if (!listp(arg1))
1934 error(NOT_LIST, "reverse", arg1);
1935 return (reverse(arg1));
1936 }
1937
1938 int
f_nreverse(int arglist)1939 f_nreverse(int arglist)
1940 {
1941 int arg1;
1942
1943 arg1 = car(arglist);
1944 if (length(arglist) != 1)
1945 error(WRONG_ARGS, "nreverse", arglist);
1946 if (!listp(arg1))
1947 error(NOT_LIST, "nreverse", arg1);
1948 return (nreverse(arg1));
1949 }
1950
1951 int
f_create_list(int arglist)1952 f_create_list(int arglist)
1953 {
1954 int arg1,
1955 arg2,
1956 n;
1957
1958 arg1 = car(arglist);
1959 arg2 = cadr(arglist);
1960 if ((n = length(arglist)) != 1 && n != 2)
1961 error(WRONG_ARGS, "create-list", arglist);
1962 if (longnump(arg1) || bignump(arg1))
1963 error(MALLOC_OVERF, "create-list", arg1);
1964 if (!integerp(arg1))
1965 error(NOT_INT, "create-list", arg1);
1966 if (GET_INT(arg1) < 0)
1967 error(NOT_POSITIVE, "create-list", arg1);
1968 if (nullp(arg2))
1969 arg2 = UNDEF;
1970 return (create_list(GET_INT(arg1), arg2));
1971 }
1972
1973 int
f_property(int arglist)1974 f_property(int arglist)
1975 {
1976 int arg1,
1977 arg2,
1978 arg3,
1979 res,
1980 n;
1981
1982 arg1 = car(arglist);
1983 arg2 = cadr(arglist);
1984 arg3 = caddr(arglist);
1985 if ((n = length(arglist)) != 2 && n != 3)
1986 error(ILLEGAL_ARGS, "property", arglist);
1987 if (!symbolp(arg1))
1988 error(NOT_SYM, "property", arg1);
1989
1990 res = assoc(arg2, GET_PROP(arg1));
1991 if (res == 0)
1992 return (arg3);
1993 else
1994 return (cdr(res));
1995 }
1996
1997 int
f_set_property(int arglist)1998 f_set_property(int arglist)
1999 {
2000 int arg1,
2001 arg2,
2002 arg3,
2003 res;
2004
2005 arg1 = car(arglist);
2006 arg2 = cadr(arglist);
2007 arg3 = caddr(arglist);
2008 res = assoc(arg3, GET_PROP(arg2));
2009 if (nullp(res))
2010 SET_PROP(arg2, cons(cons(arg3, arg1), GET_PROP(arg2)));
2011 else
2012 SET_CDR(res, arg1);
2013 return (arg1);
2014 }
2015
2016 int
f_remove_property(int arglist)2017 f_remove_property(int arglist)
2018 {
2019 int arg1,
2020 arg2,
2021 val;
2022
2023 arg1 = car(arglist);
2024 arg2 = cadr(arglist);
2025 if (length(arglist) != 2)
2026 error(WRONG_ARGS, "remove-property", arglist);
2027 if (!symbolp(arg1))
2028 error(NOT_SYM, "remove-property", arg1);
2029
2030 val = assoc(arg2, GET_PROP(arg1));
2031 if (nullp(val))
2032 return (NIL);
2033 else {
2034 int res;
2035
2036 res = cdr(val);
2037 SET_PROP(arg1, remove_prop(arg2, GET_PROP(arg1)));
2038 return (res);
2039 }
2040 }
2041
2042 int
remove_prop(int x,int lis)2043 remove_prop(int x, int lis)
2044 {
2045
2046 if (car(car(lis)) == x)
2047 return (cdr(lis));
2048 else
2049 return (cons(car(lis), remove_prop(x, cdr(lis))));
2050 }
2051
2052 int
f_gensym(int arglist __unused)2053 f_gensym(int arglist __unused)
2054 {
2055 int res;
2056 char str[SYMSIZE];
2057
2058 Fmt_sfmt(str, SYMSIZE, "#:G%d", genint);
2059 genint++;
2060 res = makesym(str);
2061 return (res);
2062 }
2063
2064 int
f_length(int arglist)2065 f_length(int arglist)
2066 {
2067 int arg;
2068
2069 arg = car(arglist);
2070 if (!nullp(cdr(arglist)))
2071 error(WRONG_ARGS, "length", arglist);
2072 if (!listp(arg) && !vectorp(arg) && !stringp(arg))
2073 error(ILLEGAL_ARGS, "length", arg);
2074
2075 if (listp(arg))
2076 return (makeint(length(arg)));
2077 else if (vectorp(arg))
2078 return (makeint(vector_length(arg)));
2079 else
2080 return (makeint(string_length(arg)));
2081
2082 }
2083
2084
2085 int
f_set_car(int arglist)2086 f_set_car(int arglist)
2087 {
2088 int arg1,
2089 arg2;
2090
2091 arg1 = car(arglist);
2092 arg2 = cadr(arglist);
2093 if (length(arglist) != 2)
2094 error(WRONG_ARGS, "set-car", arglist);
2095 if (!(IS_LIST(arg2)))
2096 error(NOT_CONS, "set-car", arg2);
2097 SET_CAR(arg2, arg1);
2098 return (arg1);
2099 }
2100
2101 int
f_set_cdr(int arglist)2102 f_set_cdr(int arglist)
2103 {
2104 int arg1,
2105 arg2;
2106
2107 arg1 = car(arglist);
2108 arg2 = cadr(arglist);
2109 if (length(arglist) != 2)
2110 error(WRONG_ARGS, "set-cdr", arglist);
2111 if (!(IS_LIST(arg2)))
2112 error(NOT_CONS, "set-cdr", arg2);
2113 SET_CDR(arg2, arg1);
2114 return (arg1);
2115 }
2116
2117
2118
2119 // input and output
2120
2121 int
f_read(int arglist)2122 f_read(int arglist)
2123 {
2124 int arg1,
2125 arg2,
2126 arg3,
2127 save,
2128 n,
2129 res;
2130 #if __linux || __APPLE__ || defined(__OpenBSD__) || defined(__DragonFly__)
2131 int save1;
2132 #endif
2133
2134 arg1 = car(arglist);
2135 arg2 = cadr(arglist);
2136 arg3 = caddr(arglist);
2137 if ((n = length(arglist)) > 3)
2138 error(WRONG_ARGS, "read", arglist);
2139 if (n > 0 && !input_stream_p(arg1))
2140 error(NOT_IN_STREAM, "read", arg1);
2141
2142 #if __linux || __APPLE__ || defined(__OpenBSD__) || defined(__DragonFly__)
2143 save1 = repl_flag;
2144 repl_flag = 0;
2145 #endif
2146 if (n == 0)
2147 res = sread();
2148 else if (n == 1) {
2149 save = input_stream;
2150 input_stream = arg1;
2151 res = sread();
2152 input_stream = save;
2153 if (res == FEND) {
2154 #if __linux || __APPLE__ || defined(__OpenBSD__) || defined(__DragonFly__)
2155 repl_flag = save1;
2156 #endif
2157 error(END_STREAM, "read", NIL);
2158 }
2159
2160 } else {
2161 save = input_stream;
2162 input_stream = arg1;
2163 res = sread();
2164 input_stream = save;
2165 if (res == FEND) {
2166 #if __linux || __APPLE__ || defined(__OpenBSD__) || defined(__DragonFly__)
2167 repl_flag = save1;
2168 #endif
2169 if (nullp(arg2) && n == 2)
2170 return (arg2);
2171 else if (nullp(arg2) && n == 3)
2172 return (arg3);
2173 else
2174 error(END_STREAM, "read", NIL);
2175 }
2176 }
2177 #if __linux || __APPLE__ || defined(__OpenBSD__) || defined(__DragonFly__)
2178 repl_flag = save1;
2179 #endif
2180 return (res);
2181 }
2182
2183 int
f_read_char(int arglist)2184 f_read_char(int arglist)
2185 {
2186 int arg1,
2187 arg2,
2188 arg3,
2189 save,
2190 save1,
2191 n,
2192 res;
2193 int rc_buf[CHARSIZE];
2194
2195 arg1 = car(arglist);
2196 arg2 = cadr(arglist);
2197 arg3 = caddr(arglist);
2198 if ((n = length(arglist)) > 3)
2199 error(WRONG_ARGS, "read-char", arglist);
2200 if (GET_OPT(arg1) == EISL_CLOSESTR)
2201 error(CANT_OPEN, "read-char", arg1);
2202 if (n > 0 && !input_stream_p(arg1))
2203 error(NOT_IN_STREAM, "read-char", arg1);
2204
2205
2206 save1 = repl_flag;
2207 repl_flag = 0;
2208 if (n == 0) {
2209 rc_buf[0] = readc();
2210 rc_buf[1] = NUL;
2211 res = makechar((char *) rc_buf);
2212 } else if (n == 1) {
2213 save = input_stream;
2214 input_stream = arg1;
2215 rc_buf[0] = readc();
2216 rc_buf[1] = NUL;
2217 if (rc_buf[0] == EOF) {
2218 repl_flag = save1;
2219 input_stream = save;
2220 error(END_STREAM, "read-char", NIL);
2221 }
2222 input_stream = save;
2223 res = makechar((char *) rc_buf);
2224 } else {
2225 save = input_stream;
2226 input_stream = arg1;
2227 rc_buf[0] = readc();
2228 rc_buf[1] = NUL;
2229 input_stream = save;
2230 if (rc_buf[0] == EOF) {
2231 repl_flag = save1;
2232 input_stream = save;
2233 if (nullp(arg2) && n == 2)
2234 return (arg2);
2235 else if (nullp(arg2) && n == 3)
2236 return (arg3);
2237 else
2238 error(END_STREAM, "read-char", NIL);
2239 }
2240 res = makechar((char *) rc_buf);
2241 if (res == FEND && arg2 == NIL)
2242 res = arg3;
2243 else
2244 res = NIL;
2245 }
2246 repl_flag = save1;
2247 return (res);
2248 }
2249
2250 int
f_read_byte(int arglist)2251 f_read_byte(int arglist)
2252 {
2253 int arg1,
2254 arg2,
2255 arg3,
2256 save,
2257 save1,
2258 n,
2259 res;
2260
2261 arg1 = car(arglist);
2262 arg2 = cadr(arglist);
2263 arg3 = caddr(arglist);
2264 if ((n = length(arglist)) > 3)
2265 error(WRONG_ARGS, "read-byte", arglist);
2266 if (n > 0 && !input_stream_p(arg1))
2267 error(NOT_IN_STREAM, "read-byte", arg1);
2268
2269 save1 = repl_flag;
2270 repl_flag = 0;
2271 if (n == 0) {
2272 res = readc();
2273 } else if (n == 1) {
2274 save = input_stream;
2275 input_stream = arg1;
2276 res = readc();
2277 if (res == EOF) {
2278 repl_flag = save1;
2279 input_stream = save;
2280 error(END_STREAM, "read-byte", NIL);
2281 }
2282 input_stream = save;
2283 } else {
2284 save = input_stream;
2285 input_stream = arg1;
2286 res = readc();
2287 input_stream = save;
2288 if (res == EOF) {
2289 repl_flag = save1;
2290 input_stream = save;
2291 if (nullp(arg2) && n == 2)
2292 return (arg2);
2293 else if (nullp(arg2) && n == 3)
2294 return (arg3);
2295 else
2296 error(END_STREAM, "read-byte", NIL);
2297 }
2298 }
2299 repl_flag = save1;
2300 return (makeint(res));
2301 }
2302
2303
2304
2305 int
f_preview_char(int arglist)2306 f_preview_char(int arglist)
2307 {
2308 int arg1,
2309 arg2,
2310 arg3,
2311 save,
2312 n,
2313 res;
2314 int pc_buf[CHARSIZE];
2315
2316 arg1 = car(arglist);
2317 arg2 = cadr(arglist);
2318 arg3 = caddr(arglist);
2319 if ((n = length(arglist)) > 3)
2320 error(WRONG_ARGS, "preview-char", arglist);
2321 if (n > 0 && !input_stream_p(arg1))
2322 error(NOT_IN_STREAM, "preview-char", arg1);
2323
2324 if (n == 0) {
2325 pc_buf[0] = readc();
2326 pc_buf[1] = NUL;
2327 unreadc(pc_buf[0]);
2328 res = makechar((char *) pc_buf);
2329 } else if (n == 1) {
2330 save = input_stream;
2331 input_stream = arg1;
2332 pc_buf[0] = readc();
2333 pc_buf[1] = NUL;
2334 unreadc(pc_buf[0]);
2335 if (pc_buf[0] == EOF) {
2336 input_stream = save;
2337 error(END_STREAM, "preview-char", NIL);
2338 }
2339 input_stream = save;
2340 res = makechar((char *) pc_buf);
2341 } else {
2342 save = input_stream;
2343 input_stream = arg1;
2344 pc_buf[0] = readc();
2345 pc_buf[1] = NUL;
2346 unreadc(pc_buf[0]);
2347 if (pc_buf[0] == EOF) {
2348 input_stream = save;
2349 if (nullp(arg2) && n == 2)
2350 return (arg2);
2351 else if (nullp(arg2) && n == 3)
2352 return (arg3);
2353 else
2354 error(END_STREAM, "preview-char", NIL);
2355
2356 }
2357 input_stream = save;
2358 res = makechar((char *) pc_buf);
2359 if (res == FEND && arg2 == NIL)
2360 res = arg3;
2361 }
2362 return (res);
2363 }
2364
2365 int
f_read_line(int arglist)2366 f_read_line(int arglist)
2367 {
2368 int arg1,
2369 arg2,
2370 arg3,
2371 n,
2372 pos,
2373 save,
2374 res,
2375 c;
2376 char rl_buf[LINE_MAX];
2377 #if __linux || __APPLE__ || defined(__OpenBSD__) || defined(__DragonFly__)
2378 int save1;
2379 #endif
2380
2381 arg1 = car(arglist);
2382 arg2 = cadr(arglist);
2383 arg3 = caddr(arglist);
2384 if ((n = length(arglist)) > 3)
2385 error(WRONG_ARGS, "read-line", arglist);
2386 if (n > 0 && !input_stream_p(arg1))
2387 error(NOT_IN_STREAM, "read-line", arg1);
2388
2389
2390 save1 = repl_flag;
2391 repl_flag = 0;
2392 if (n == 0) {
2393 pos = 0;
2394 c = readc();
2395 while (c != EOL) {
2396 rl_buf[pos] = c;
2397 pos++;
2398 c = readc();
2399 }
2400 rl_buf[pos] = NUL;
2401 res = makestr(rl_buf);
2402 } else if (n == 1) {
2403 pos = 0;
2404 save = input_stream;
2405 input_stream = arg1;
2406 c = readc();
2407 if (c == EOF) {
2408 repl_flag = save1;
2409 error(END_STREAM, "read-line", NIL);
2410 }
2411 while (c != EOL && c != EOF) {
2412 rl_buf[pos] = c;
2413 pos++;
2414 c = readc();
2415 }
2416 rl_buf[pos] = NUL;
2417 input_stream = save;
2418 res = makestr(rl_buf);
2419 } else {
2420 pos = 0;
2421 save = input_stream;
2422 input_stream = arg1;
2423 c = readc();
2424 if (c == EOF) {
2425 repl_flag = save1;
2426 if (nullp(arg2) && n == 2) {
2427 input_stream = save;
2428 return (arg2);
2429 } else if (nullp(arg2) && n == 3) {
2430 input_stream = save;
2431 return (arg3);
2432 } else
2433 error(END_STREAM, "read-line", NIL);
2434 }
2435
2436 while (c != EOL && c != EOF) {
2437 rl_buf[pos] = c;
2438 pos++;
2439 c = readc();
2440 }
2441 rl_buf[pos] = NUL;
2442 input_stream = save;
2443 res = makestr(rl_buf);
2444 if (res == FEND && arg2 == NIL)
2445 res = arg3;
2446 }
2447 repl_flag = save1;
2448 return (res);
2449 }
2450
2451 int
f_load(int arglist)2452 f_load(int arglist)
2453 {
2454 int arg1,
2455 save1,
2456 save2,
2457 n;
2458 char str[PATH_MAX];
2459
2460 arg1 = car(arglist);
2461 if (length(arglist) != 1)
2462 error(WRONG_ARGS, "load", arglist);
2463 if (!stringp(arg1))
2464 error(NOT_STR, "load", arg1);
2465
2466 // object file ex "foo.o"
2467 n = strlen(GET_NAME(arg1));
2468 strncpy(str, GET_NAME(arg1), PATH_MAX - 1);
2469 str[PATH_MAX - 1] = '\0';
2470 if (str[n - 1] == 'o' && str[n - 2] == '.') {
2471 dynamic_link(arg1);
2472 return (T);
2473 }
2474 // text file
2475 save1 = input_stream;
2476 save2 = repl_flag;
2477 const char *fname = GET_NAME(arg1);
2478 input_stream =
2479 makestream(fopen(fname, "r"), EISL_INPUT, Str_dup(fname, 1, 0, 1));
2480
2481 if (GET_PORT(input_stream) == NULL) {
2482 input_stream = save1;
2483 error(CANT_OPEN, "load", arg1);
2484 }
2485 open_flag = true;
2486 line = 1;
2487 column = 0;
2488 if (looking_for_shebang) {
2489 FILE *infile = GET_PORT(input_stream);
2490 int ch = fgetc(infile);
2491 switch (ch) {
2492 case EOF:
2493 goto cleanup;
2494 case '#':
2495 ch = fgetc(infile);
2496 if (ch != '!' || ch == EOF) {
2497 goto cleanup;
2498 }
2499 while (ch != '\n' && ch != EOF) {
2500 ch = fgetc(infile);
2501 }
2502 if (ch == EOF) {
2503 goto cleanup;
2504 }
2505 break;
2506 default:
2507 ungetc(ch, infile);
2508 }
2509 looking_for_shebang = false;
2510 }
2511 while (1) {
2512 int sexp;
2513
2514 sexp = sread();
2515 if (sexp == FEND)
2516 break;
2517 top_flag = true;
2518 eval(sexp);
2519 }
2520 cleanup:
2521 open_flag = false;
2522 fclose(GET_PORT(input_stream));
2523 input_stream = save1;
2524 repl_flag = save2;
2525 if (redef_flag)
2526 redef_generic();
2527 return (T);
2528 }
2529
2530 int
f_import(int arglist)2531 f_import(int arglist)
2532 {
2533 int arg1 = car(arglist);
2534 if (!stringp(arg1))
2535 error(NOT_SYM, "import", arg1);
2536
2537 char *str = Str_cat(GET_NAME(arg1), 1, 0, ".o", 1, 0);
2538 char *fname = library_file(str);
2539 if (access(fname, R_OK) != -1) {
2540 f_load(list1(makestr(fname)));
2541 goto cleanup;
2542 }
2543
2544 FREE(str);
2545 str = Str_cat(GET_NAME(arg1), 1, 0, ".lsp", 1, 0);
2546 FREE(fname);
2547 fname = library_file(str);
2548 if (access(fname, R_OK) != -1) {
2549 f_load(list1(makestr(fname)));
2550 goto cleanup;
2551 }
2552 FREE(str);
2553 FREE(fname);
2554 error(CANT_OPEN, "import", arg1);
2555
2556 cleanup:
2557 FREE(str);
2558 FREE(fname);
2559 return (T);
2560 }
2561
2562 int
f_print(int arglist)2563 f_print(int arglist)
2564 {
2565 int arg1;
2566
2567 arg1 = car(arglist);
2568 if (length(arglist) != 1)
2569 error(WRONG_ARGS, "print", arglist);
2570 print(arg1);
2571 putchar('\n');
2572 return (NIL);
2573 }
2574
2575 int
f_prin1(int arglist)2576 f_prin1(int arglist)
2577 {
2578 int arg1;
2579
2580 arg1 = car(arglist);
2581 if (length(arglist) != 1)
2582 error(WRONG_ARGS, "prin1", arglist);
2583 print(arg1);
2584 return (T);
2585 }
2586
2587
2588 int
f_standard_input(int arglist)2589 f_standard_input(int arglist)
2590 {
2591 if (!nullp(arglist))
2592 error(WRONG_ARGS, "standard-input", arglist);
2593 return (standard_input);
2594 }
2595
2596 int
f_standard_output(int arglist)2597 f_standard_output(int arglist)
2598 {
2599 if (!nullp(arglist))
2600 error(WRONG_ARGS, "standard-output", arglist);
2601 return (standard_output);
2602 }
2603
2604 int
f_error_output(int arglist)2605 f_error_output(int arglist)
2606 {
2607 if (!nullp(arglist))
2608 error(WRONG_ARGS, "error-output", arglist);
2609 return (standard_error);
2610 }
2611
2612 int
f_streamp(int arglist)2613 f_streamp(int arglist)
2614 {
2615 int arg;
2616
2617 arg = car(arglist);
2618 if (length(arglist) != 1)
2619 error(WRONG_ARGS, "streamp", arglist);
2620 if (streamp(arg))
2621 return (T);
2622 else
2623 return (NIL);
2624 }
2625
2626 int
f_open_stream_p(int arglist)2627 f_open_stream_p(int arglist)
2628 {
2629 int arg;
2630
2631 arg = car(arglist);
2632 if (length(arglist) != 1)
2633 error(WRONG_ARGS, "open-stream-p", arglist);
2634 if (arg == standard_input || arg == standard_output
2635 || arg == standard_error)
2636 return (T);
2637 else if (GET_OPT(arg) == EISL_OPEN)
2638 return (T);
2639 else
2640 return (NIL);
2641 }
2642
2643 int
f_input_stream_p(int arglist)2644 f_input_stream_p(int arglist)
2645 {
2646 int arg;
2647
2648 arg = car(arglist);
2649 if (length(arglist) != 1)
2650 error(WRONG_ARGS, "input-stream-p", arglist);
2651 if (streamp(arg) && GET_OPT(arg) == EISL_INPUT)
2652 return (T);
2653 else
2654 return (NIL);
2655 }
2656
2657 int
f_output_stream_p(int arglist)2658 f_output_stream_p(int arglist)
2659 {
2660 int arg;
2661
2662 arg = car(arglist);
2663 if (length(arglist) != 1)
2664 error(WRONG_ARGS, "output-stream-p", arglist);
2665 if (streamp(arg) && GET_OPT(arg) == EISL_OUTPUT)
2666 return (T);
2667 else
2668 return (NIL);
2669 }
2670
2671 int
f_stream_ready_p(int arglist)2672 f_stream_ready_p(int arglist)
2673 {
2674 int arg1;
2675
2676 arg1 = car(arglist);
2677 if (length(arglist) != 1)
2678 error(WRONG_ARGS, "stream-ready-p", arglist);
2679 if (!streamp(arg1))
2680 error(NOT_STREAM, "stream-ready-p", arg1);
2681
2682 if (input_stream_p(arg1)) {
2683 int save,
2684 c;
2685
2686 save = input_stream;
2687 input_stream = arg1;
2688 c = readc();
2689 if (c == EOF) {
2690 input_stream = save;
2691 return (NIL);
2692 } else {
2693 unreadc(c);
2694 input_stream = save;
2695 return (T);
2696 }
2697 } else
2698 return (T);
2699 }
2700
2701 // evaluation function
2702
2703 int
f_eval(int arglist)2704 f_eval(int arglist)
2705 {
2706 int arg1;
2707
2708 arg1 = car(arglist);
2709 if (length(arglist) != 1)
2710 error(WRONG_ARGS, "eval", arglist);
2711 return (eval(arg1));
2712 }
2713
2714 int
f_apply(int arglist)2715 f_apply(int arglist)
2716 {
2717 int arg1,
2718 arg2;
2719
2720 arg1 = car(arglist);
2721 arg2 = cdr(arglist);
2722 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
2723 error(NOT_FUNC, "apply", arg1);
2724 if (!listp(last(arg2)))
2725 error(NOT_LIST, "apply", last(arg2));
2726
2727 return (apply(arg1, bind_args(arg2)));
2728 }
2729
2730 int
bind_args(int x)2731 bind_args(int x)
2732 {
2733 if (nullp(cdr(x)))
2734 return (car(x));
2735 else
2736 return (cons(car(x), bind_args(cdr(x))));
2737 }
2738
2739 int
f_funcall(int arglist)2740 f_funcall(int arglist)
2741 {
2742 int arg1,
2743 arg2,
2744 res;
2745
2746 arg1 = car(arglist);
2747 arg2 = cdr(arglist);
2748 if (!(IS_FUNC(arg1)) && !(IS_SUBR(arg1)))
2749 error(NOT_FUNC, "funcall", arg1);
2750 res = apply(arg1, arg2);
2751 return (res);
2752 }
2753
2754
2755
2756 // character function
2757
2758
2759 int
f_characterp(int arglist)2760 f_characterp(int arglist)
2761 {
2762 int arg1;
2763
2764 arg1 = car(arglist);
2765 if (length(arglist) != 1)
2766 error(WRONG_ARGS, "characterp", arglist);
2767 if (charp(arg1))
2768 return (T);
2769 else
2770 return (NIL);
2771 }
2772
2773
2774
2775 int
f_char_eqp(int arglist)2776 f_char_eqp(int arglist)
2777 {
2778 int arg1,
2779 arg2;
2780
2781 arg1 = car(arglist);
2782 arg2 = cadr(arglist);
2783 if (length(arglist) != 2)
2784 error(WRONG_ARGS, "char=", arglist);
2785 if (!charp(arg1))
2786 error(NOT_CHAR, "char=", arg1);
2787 if (!charp(arg2))
2788 error(NOT_CHAR, "char=", arg2);
2789
2790
2791 if (SAME_NAME(arg1, arg2))
2792 return (T);
2793 else
2794 return (NIL);
2795 }
2796
2797 int
f_char_noteqp(int arglist)2798 f_char_noteqp(int arglist)
2799 {
2800 int arg1,
2801 arg2;
2802
2803 arg1 = car(arglist);
2804 arg2 = cadr(arglist);
2805 if (length(arglist) != 2)
2806 error(WRONG_ARGS, "char/=", arglist);
2807 if (!charp(arg1))
2808 error(NOT_CHAR, "char/=", arg1);
2809 if (!charp(arg2))
2810 error(NOT_CHAR, "char/=", arg2);
2811
2812
2813 if (SAME_NAME(arg1, arg2))
2814 return (NIL);
2815 else
2816 return (T);
2817 }
2818
2819 static inline bool
SMALLER_NAME(int addr1,int addr2)2820 SMALLER_NAME(int addr1, int addr2)
2821 {
2822 return (strcmp(heap[addr1].name, heap[addr2].name) < 0);
2823 }
2824
2825 int
f_char_smallerp(int arglist)2826 f_char_smallerp(int arglist)
2827 {
2828 int arg1,
2829 arg2;
2830
2831 arg1 = car(arglist);
2832 arg2 = cadr(arglist);
2833 if (length(arglist) != 2)
2834 error(WRONG_ARGS, "char<", arglist);
2835 if (!charp(arg1))
2836 error(NOT_CHAR, "char<", arg1);
2837 if (!charp(arg2))
2838 error(NOT_CHAR, "char<", arg2);
2839
2840
2841 if (SMALLER_NAME(arg1, arg2))
2842 return (T);
2843 else
2844 return (NIL);
2845 }
2846
2847 int
f_char_eqsmallerp(int arglist)2848 f_char_eqsmallerp(int arglist)
2849 {
2850 int arg1,
2851 arg2;
2852
2853 arg1 = car(arglist);
2854 arg2 = cadr(arglist);
2855 if (length(arglist) != 2)
2856 error(WRONG_ARGS, "char<=", arglist);
2857 if (!charp(arg1))
2858 error(NOT_CHAR, "char<=", arg1);
2859 if (!charp(arg2))
2860 error(NOT_CHAR, "char<=", arg2);
2861
2862 if (SMALLER_NAME(arg1, arg2) || SAME_NAME(arg1, arg2))
2863 return (T);
2864 else
2865 return (NIL);
2866 }
2867
2868 static inline bool
GREATER_NAME(int addr1,int addr2)2869 GREATER_NAME(int addr1, int addr2)
2870 {
2871 return (strcmp(heap[addr1].name, heap[addr2].name) > 0);
2872 }
2873
2874 int
f_char_greaterp(int arglist)2875 f_char_greaterp(int arglist)
2876 {
2877 int arg1,
2878 arg2;
2879
2880 arg1 = car(arglist);
2881 arg2 = cadr(arglist);
2882 if (length(arglist) != 2)
2883 error(WRONG_ARGS, "char>", arglist);
2884 if (!charp(arg1))
2885 error(NOT_CHAR, "char>", arg1);
2886 if (!charp(arg2))
2887 error(NOT_CHAR, "char>", arg2);
2888
2889 if (GREATER_NAME(arg1, arg2))
2890 return (T);
2891 else
2892 return (NIL);
2893 }
2894
2895 int
f_char_eqgreaterp(int arglist)2896 f_char_eqgreaterp(int arglist)
2897 {
2898 int arg1,
2899 arg2;
2900
2901 arg1 = car(arglist);
2902 arg2 = cadr(arglist);
2903 if (length(arglist) != 2)
2904 error(WRONG_ARGS, "char>=", arglist);
2905 if (!charp(arg1))
2906 error(NOT_CHAR, "char>=", arg1);
2907 if (!charp(arg2))
2908 error(NOT_CHAR, "char>=", arg2);
2909
2910 if (GREATER_NAME(arg1, arg2) || SAME_NAME(arg1, arg2))
2911 return (T);
2912 else
2913 return (NIL);
2914 }
2915
2916 int
f_char_index(int arglist)2917 f_char_index(int arglist)
2918 {
2919 int arg1,
2920 arg2,
2921 arg3,
2922 n,
2923 i,
2924 j,
2925 len;
2926 char c;
2927
2928 arg1 = car(arglist);
2929 arg2 = cadr(arglist);
2930 arg3 = caddr(arglist);
2931 if ((n = length(arglist)) != 2 && n != 3)
2932 error(WRONG_ARGS, "char-index", arglist);
2933 if (!charp(arg1))
2934 error(NOT_CHAR, "char-index", arg1);
2935 if (!stringp(arg2))
2936 error(NOT_STR, "char-index", arg2);
2937 if (n == 3 && negativep(arg3))
2938 error(NOT_POSITIVE, "char-index", arg3);
2939 if (n == 3 && !integerp(arg3))
2940 error(WRONG_ARGS, "char-index", arg3);
2941 if (n == 3 && GET_INT(arg3) >= string_length(arg2))
2942 error(WRONG_ARGS, "char-index", arg3);
2943
2944
2945 if (string_length(arg2) == 0)
2946 return (NIL);
2947
2948 if (arg3 != NIL)
2949 j = GET_INT(arg3);
2950 else
2951 j = 0;
2952
2953 c = GET_CHAR(arg1);
2954 len = strlen(GET_NAME(arg2));
2955 for (i = j; i < len; i++) {
2956 if (STRING_REF(arg2, i) == c)
2957 break;
2958 }
2959 if (i < len)
2960 return (makeint(i));
2961 else
2962 return (NIL);
2963 }
2964
2965
2966 // string function
2967 int
f_stringp(int arglist)2968 f_stringp(int arglist)
2969 {
2970 int arg1;
2971
2972 arg1 = car(arglist);
2973 if (length(arglist) != 1)
2974 error(WRONG_ARGS, "stringp", arglist);
2975 if (stringp(arg1))
2976 return (T);
2977 else
2978 return (NIL);
2979 }
2980
2981 int
f_string_eqp(int arglist)2982 f_string_eqp(int arglist)
2983 {
2984 int arg1,
2985 arg2;
2986
2987 if (length(arglist) != 2)
2988 error(WRONG_ARGS, "string=", arglist);
2989 arg1 = car(arglist);
2990 arg2 = cadr(arglist);
2991 if (!stringp(arg1))
2992 error(NOT_STR, "string=", arg1);
2993 if (!stringp(arg2))
2994 error(NOT_STR, "string=", arg2);
2995 if (SAME_NAME(arg1, arg2))
2996 return (T);
2997 else
2998 return (NIL);
2999 }
3000
3001 int
f_string_noteqp(int arglist)3002 f_string_noteqp(int arglist)
3003 {
3004 int arg1,
3005 arg2;
3006
3007 arg1 = car(arglist);
3008 arg2 = cadr(arglist);
3009 if (length(arglist) != 2)
3010 error(WRONG_ARGS, "string=", arglist);
3011 if (!stringp(arg1))
3012 error(NOT_STR, "string=", arg1);
3013 if (!stringp(arg2))
3014 error(NOT_STR, "string=", arg2);
3015 if (SAME_NAME(arg1, arg2))
3016 return (NIL);
3017 else
3018 return (T);
3019 }
3020
3021
3022 static inline char
GET_NAME_ELT(int addr,int n)3023 GET_NAME_ELT(int addr, int n)
3024 {
3025 return heap[addr].name[n];
3026 }
3027
3028 int
f_elt(int arglist)3029 f_elt(int arglist)
3030 {
3031 int arg1,
3032 arg2;
3033 char str[CHARSIZE];
3034
3035 arg1 = car(arglist);
3036 arg2 = cadr(arglist);
3037 if (length(arglist) != 2)
3038 error(WRONG_ARGS, "elt", arglist);
3039 if (!integerp(arg2) && !longnump(arg2))
3040 error(NOT_INT, "elt", arg2);
3041 if (negativep(arg2))
3042 error(OUT_OF_DOMAIN, "elt", arg2);
3043
3044 if (listp(arg1)) {
3045 if (length(arg1) == 0)
3046 error(OUT_OF_RANGE, "elt", arg1);
3047 if (integerp(arg2) && length(arg1) <= GET_INT(arg2))
3048 error(OUT_OF_RANGE, "elt", arg2);
3049 if (longnump(arg2)
3050 && (long long int) length(arg1) <= GET_LONG(arg2))
3051 error(OUT_OF_RANGE, "elt", arg2);
3052 return (listref(arg1, GET_INT(arg2)));
3053 } else if (vectorp(arg1)) {
3054 if (vector_length(arg1) == 0)
3055 error(OUT_OF_RANGE, "elt", arg1);
3056 if (integerp(arg2) && vector_length(arg1) <= GET_INT(arg2))
3057 error(OUT_OF_RANGE, "elt", arg2);
3058 if (longnump(arg2)
3059 && (long long int) vector_length(arg1) <= GET_LONG(arg2))
3060 error(OUT_OF_RANGE, "elt", arg2);
3061 return (vector_ref(arg1, GET_INT(arg2)));
3062 } else if (stringp(arg1)) {
3063 if (string_length(arg1) == 0)
3064 error(OUT_OF_RANGE, "elt", arg1);
3065 if (integerp(arg2)
3066 && ((int) strlen(GET_NAME(arg1)) <= GET_INT(arg2)))
3067 error(OUT_OF_RANGE, "elt", arg2);
3068 if (longnump(arg2)
3069 && (long long int) strlen(GET_NAME(arg1)) <= GET_LONG(arg2))
3070 error(OUT_OF_RANGE, "elt", arg2);
3071 str[0] = GET_NAME_ELT(arg1, GET_INT(arg2));
3072 str[1] = NUL;
3073 return (makechar(str));
3074 }
3075 return (NIL);
3076 }
3077
3078
3079 int
f_set_elt(int arglist)3080 f_set_elt(int arglist)
3081 {
3082 int arg1,
3083 arg2,
3084 arg3;
3085
3086 arg1 = car(arglist);
3087 arg2 = cadr(arglist);
3088 arg3 = caddr(arglist);
3089 if (length(arglist) != 3)
3090 error(WRONG_ARGS, "set-elt", arglist);
3091 if (!integerp(arg3) && !longnump(arg3))
3092 error(NOT_INT, "set-elt", arg3);
3093 if (negativep(arg3))
3094 error(OUT_OF_DOMAIN, "set-elt", arg2);
3095
3096 if (listp(arg2)) {
3097 if (length(arg2) == 0)
3098 error(OUT_OF_RANGE, "set-elt", arg1);
3099 if (integerp(arg3) && length(arg2) <= GET_INT(arg3))
3100 error(OUT_OF_RANGE, "set-elt", arg2);
3101 if (longnump(arg3)
3102 && (long long int) length(arg2) <= GET_LONG(arg3))
3103 error(OUT_OF_RANGE, "set-elt", arg2);
3104 SET_CAR(listref1(arg2, GET_INT(arg3)), arg1);
3105 } else if (vectorp(arg2)) {
3106 if (vector_length(arg2) == 0)
3107 error(OUT_OF_RANGE, "set-elt", arg2);
3108 if (integerp(arg3) && vector_length(arg2) <= GET_INT(arg3))
3109 error(OUT_OF_RANGE, "set-elt", arg3);
3110 if (longnump(arg3)
3111 && (long long int) vector_length(arg2) <= GET_LONG(arg3))
3112 error(OUT_OF_RANGE, "set-elt", arg3);
3113 SET_VEC_ELT(arg2, GET_INT(arg3), arg1);
3114 } else if (stringp(arg2)) {
3115 if (string_length(arg2) == 0)
3116 error(OUT_OF_RANGE, "set-elt", arg2);
3117 if (integerp(arg3)
3118 && ((int) strlen(GET_NAME(arg2)) <= GET_INT(arg3)))
3119 error(OUT_OF_RANGE, "set-elt", arg3);
3120 if (longnump(arg3)
3121 && (long long int) strlen(GET_NAME(arg2)) <= GET_LONG(arg3))
3122 error(OUT_OF_RANGE, "set-elt", arg2);
3123 STRING_SET(arg2, GET_INT(arg3), GET_CHAR(arg1));
3124 }
3125 return (arg1);
3126 }
3127
3128
3129
3130 int
f_string_smallerp(int arglist)3131 f_string_smallerp(int arglist)
3132 {
3133 int arg1,
3134 arg2;
3135
3136 arg1 = car(arglist);
3137 arg2 = cadr(arglist);
3138 if (length(arglist) != 2)
3139 error(WRONG_ARGS, "string<", arglist);
3140 if (!stringp(arg1))
3141 error(NOT_STR, "string<", arg1);
3142 if (!stringp(arg2))
3143 error(NOT_STR, "string<", arg2);
3144
3145 if (SMALLER_NAME(arg1, arg2))
3146 return (T);
3147 else
3148 return (NIL);
3149 }
3150
3151 int
f_string_greaterp(int arglist)3152 f_string_greaterp(int arglist)
3153 {
3154 int arg1,
3155 arg2;
3156
3157 arg1 = car(arglist);
3158 arg2 = cadr(arglist);
3159 if (length(arglist) != 2)
3160 error(WRONG_ARGS, "string>", arglist);
3161 if (!stringp(arg1))
3162 error(NOT_STR, "string>", arg1);
3163 if (!stringp(arg2))
3164 error(NOT_STR, "string>", arg2);
3165
3166 if (GREATER_NAME(arg1, arg2))
3167 return (T);
3168 else
3169 return (NIL);
3170 }
3171
3172 int
f_string_eqgreaterp(int arglist)3173 f_string_eqgreaterp(int arglist)
3174 {
3175 int arg1,
3176 arg2;
3177
3178 arg1 = car(arglist);
3179 arg2 = cadr(arglist);
3180 if (length(arglist) != 2)
3181 error(WRONG_ARGS, "string>=", arglist);
3182 if (!stringp(arg1))
3183 error(NOT_STR, "string>=", arg1);
3184 if (!stringp(arg2))
3185 error(NOT_STR, "string>=", arg2);
3186
3187 if (GREATER_NAME(arg1, arg2) || SAME_NAME(arg1, arg2))
3188 return (T);
3189 else
3190 return (NIL);
3191
3192 }
3193
3194
3195 int
f_string_eqsmallerp(int arglist)3196 f_string_eqsmallerp(int arglist)
3197 {
3198 int arg1,
3199 arg2;
3200
3201 arg1 = car(arglist);
3202 arg2 = cadr(arglist);
3203 if (length(arglist) != 2)
3204 error(WRONG_ARGS, "string<=", arglist);
3205 if (!stringp(arg1))
3206 error(NOT_STR, "string<=", arg1);
3207 if (!stringp(arg2))
3208 error(NOT_STR, "string<=", arg2);
3209
3210 if (SMALLER_NAME(arg1, arg2) || SAME_NAME(arg1, arg2))
3211 return (T);
3212 else
3213 return (NIL);
3214
3215 }
3216
3217 int
f_string_append(int arglist)3218 f_string_append(int arglist)
3219 {
3220 int arg1;
3221
3222 if (nullp(arglist))
3223 return (makestr(""));
3224
3225 arg1 = car(arglist);
3226 if (!stringp(arg1))
3227 error(NOT_STR, "string-append", arg1);
3228 arglist = cdr(arglist);
3229 if (nullp(arglist))
3230 return (arg1);
3231 Text_save_T save = Text_save();
3232 Text_T txt1 = Text_put(GET_NAME(arg1));
3233 while (!nullp(arglist)) {
3234 int arg2;
3235
3236 arg2 = car(arglist);
3237 if (!stringp(arg2))
3238 error(NOT_STR, "string-append", arg2);
3239 arglist = cdr(arglist);
3240
3241 Text_T txt2 = Text_put(GET_NAME(arg2));
3242 txt1 = Text_cat(txt1, txt2);
3243 }
3244 char *str = Text_get(NULL, 0, txt1);
3245 int res = makestr(str);
3246 FREE(str);
3247 Text_restore(&save);
3248 return res;
3249 }
3250
3251
3252 int
f_string_index(int arglist)3253 f_string_index(int arglist)
3254 {
3255 int arg1,
3256 arg2,
3257 arg3,
3258 n,
3259 i,
3260 j,
3261 k,
3262 len1,
3263 len2;
3264
3265 arg1 = car(arglist);
3266 arg2 = cadr(arglist);
3267 arg3 = caddr(arglist);
3268 if ((n = length(arglist)) != 2 && n != 3)
3269 error(WRONG_ARGS, "string-index", arglist);
3270 if (!stringp(arg1))
3271 error(NOT_STR, "string-index", arg1);
3272 if (!stringp(arg2))
3273 error(NOT_STR, "string-index", arg2);
3274 if (n == 3 && negativep(arg3))
3275 error(NOT_POSITIVE, "string-index", arg3);
3276 if (n == 3 && !integerp(arg3))
3277 error(WRONG_ARGS, "string-index", arg3);
3278 if (n == 3 && GET_INT(arg3) >= string_length(arg2))
3279 error(ILLEGAL_ARGS, "string-index", arg3);
3280
3281 if (string_length(arg1) == 0 && string_length(arg2) == 0) // (string-index
3282 //
3283 //
3284 //
3285 //
3286 //
3287 //
3288 //
3289 //
3290 //
3291 //
3292 //
3293 //
3294 // "" "")
3295 return (makeint(0));
3296
3297 if (string_length(arg2) == 0)
3298 return (NIL);
3299
3300 len1 = strlen(GET_NAME(arg1));
3301 len2 = strlen(GET_NAME(arg2));
3302 if (n == 3)
3303 j = GET_INT(arg3);
3304 else
3305 j = 0;
3306
3307
3308
3309 for (i = j; i < len2; i++)
3310 for (k = 0; k < len1 + 1; k++)
3311 if (STRING_REF(arg1, k) == NUL)
3312 return (makeint(i));
3313 else if (STRING_REF(arg1, k) != STRING_REF(arg2, i + k))
3314 break;
3315
3316
3317 return (NIL);
3318 }
3319
3320
3321 // vector and array
3322
3323 int
f_aref(int arglist)3324 f_aref(int arglist)
3325 {
3326 int arg1,
3327 arg2;
3328
3329 arg1 = car(arglist);
3330 arg2 = cdr(arglist);
3331
3332 if (length(arglist) < 1)
3333 error(WRONG_ARGS, "aref", arglist);
3334
3335 if (stringp(arg1)) {
3336 if (negativep(car(arg2)))
3337 error(OUT_OF_DOMAIN, "aref", arg2);
3338 if (GET_INT(car(arg2)) >= string_length(arg1))
3339 error(OUT_OF_RANGE, "aref", arg2);
3340 return (string_ref(arg1, car(arg2)));
3341 } else if (vectorp(arg1)) {
3342 if (!indomainp(arg2))
3343 error(OUT_OF_DOMAIN, "aref", arg2);
3344 if (!inrangep(arg2, list1(makeint(vector_length(arg1)))))
3345 error(OUT_OF_RANGE, "aref", arg2);
3346 return (array_ref(arg1, arg2));
3347 } else if (arrayp(arg1)) {
3348 if (!indomainp(arg2))
3349 error(OUT_OF_DOMAIN, "aref", arg2);
3350 if (!inrangep(arg2, array_length(arg1)))
3351 error(OUT_OF_RANGE, "aref", arg2);
3352 return (array_ref(arg1, arg2));
3353 } else
3354 error(NOT_BASIC_ARRAY, "aref", arg1);
3355
3356 return (NIL);
3357 }
3358
3359 int
indomainp(int ls)3360 indomainp(int ls)
3361 {
3362 if (nullp(ls))
3363 return (1);
3364 else if (negativep(car(ls)))
3365 return (0);
3366 else
3367 return (indomainp(cdr(ls)));
3368 }
3369
3370
3371 int
inrangep(int x,int y)3372 inrangep(int x, int y)
3373 {
3374
3375 while (!nullp(x)) {
3376 if (longnump(car(x) || bignump(car(x))))
3377 return (0);
3378 else if (eqgreaterp(car(x), car(y)) || GET_INT(car(x)) < 0)
3379 return (0);
3380 else if (nullp(y))
3381 return (0);
3382
3383 x = cdr(x);
3384 y = cdr(y);
3385 }
3386 if (nullp(y))
3387 return (1);
3388 else
3389 return (0);
3390 }
3391
3392 int
f_garef(int arglist)3393 f_garef(int arglist)
3394 {
3395 int arg1,
3396 arg2;
3397
3398 arg1 = car(arglist);
3399 arg2 = cdr(arglist);
3400
3401 if (vectorp(arg1)) {
3402 if (!indomainp(arg2))
3403 error(OUT_OF_DOMAIN, "garef", arg2);
3404 if (!inrangep(arg2, list1(makeint(vector_length(arg1)))))
3405 error(OUT_OF_RANGE, "garef", arg2);
3406 return (array_ref(arg1, arg2));
3407 } else if (arrayp(arg1)) {
3408 if (!indomainp(arg2))
3409 error(OUT_OF_DOMAIN, "garef", arg2);
3410 if (!inrangep(arg2, array_length(arg1)))
3411 error(OUT_OF_RANGE, "garef", arg2);
3412 return (array_ref(arg1, arg2));
3413 } else
3414 error(NOT_VECARR, "garef", arg1);
3415 return (NIL);
3416
3417 }
3418
3419
3420 int
f_set_aref(int arglist)3421 f_set_aref(int arglist)
3422 {
3423 int arg1,
3424 arg2,
3425 arg3;
3426
3427 arg1 = car(arglist);
3428 arg2 = cadr(arglist);
3429 arg3 = cddr(arglist);
3430
3431
3432 if (stringp(arg2)) {
3433 if (negativep(car(arg3)))
3434 error(OUT_OF_DOMAIN, "set-aref", arg3);
3435 if (GET_INT(car(arg3)) >= string_length(arg2))
3436 error(OUT_OF_RANGE, "set-aref", arg3);
3437 string_set(arg2, car(arg3), arg1);
3438 } else if (vectorp(arg2)) {
3439 if (!indomainp(arg3))
3440 error(OUT_OF_DOMAIN, "set-aref", arg3);
3441 if (!inrangep(arg3, list1(makeint(vector_length(arg2)))))
3442 error(OUT_OF_RANGE, "set-aref", arg3);
3443 array_set(arg2, arg3, arg1);
3444 } else if (arrayp(arg2)) {
3445 if (!indomainp(arg3))
3446 error(OUT_OF_DOMAIN, "set-aref", arg3);
3447 if (!inrangep(arg3, array_length(arg2)))
3448 error(OUT_OF_RANGE, "set-aref", arg3);
3449 array_set(arg2, arg3, arg1);
3450 } else
3451 error(ILLEGAL_ARGS, "set-aref", arg2);
3452
3453 return (arg1);
3454 }
3455
3456 int
f_set_garef(int arglist)3457 f_set_garef(int arglist)
3458 {
3459 int arg1,
3460 arg2,
3461 arg3;
3462
3463 arg1 = car(arglist);
3464 arg2 = cadr(arglist);
3465 arg3 = cddr(arglist);
3466 if (GET_AUX(arg2) != cgeneral_vector
3467 && GET_AUX(arg2) != cgeneral_array_star)
3468 error(NOT_VECARR, "set-garef", arg2);
3469
3470 if (vectorp(arg2)) {
3471 if (!indomainp(arg3))
3472 error(OUT_OF_DOMAIN, "set-aref", arg3);
3473 if (!inrangep(arg3, list1(makeint(vector_length(arg2)))))
3474 error(OUT_OF_RANGE, "set-aref", arg3);
3475 array_set(arg2, arg3, arg1);
3476 } else if (arrayp(arg2)) {
3477 if (!indomainp(arg3))
3478 error(OUT_OF_DOMAIN, "set-aref", arg3);
3479 if (!inrangep(arg3, array_length(arg2)))
3480 error(OUT_OF_RANGE, "set-aref", arg3);
3481 array_set(arg2, arg3, arg1);
3482 }
3483
3484 return (arg1);
3485 }
3486
3487 int
f_basic_vector_p(int arglist)3488 f_basic_vector_p(int arglist)
3489 {
3490 int arg1;
3491
3492 arg1 = car(arglist);
3493 if (length(arglist) != 1)
3494 error(WRONG_ARGS, "basic-vector-p", arglist);
3495
3496 if (!symbolp(arg1) && GET_AUX(arg1) == cbasic_vector)
3497 return (T);
3498 else if (!symbolp(arg1) && subclassp(GET_AUX(arg1), cbasic_vector))
3499 return (T);
3500 else
3501 return (NIL);
3502
3503 return (UNDEF);
3504 }
3505
3506 int
f_general_vector_p(int arglist)3507 f_general_vector_p(int arglist)
3508 {
3509 int arg1;
3510
3511 arg1 = car(arglist);
3512 if (length(arglist) != 1)
3513 error(WRONG_ARGS, "general-vector-p", arglist);
3514
3515 if (!symbolp(arg1) && GET_AUX(arg1) == cgeneral_vector)
3516 return (T);
3517 else if (!symbolp(arg1) && subclassp(GET_AUX(arg1), cgeneral_vector))
3518 return (T);
3519 else
3520 return (NIL);
3521
3522 return (UNDEF);
3523 }
3524
3525
3526 int
f_basic_array_p(int arglist)3527 f_basic_array_p(int arglist)
3528 {
3529 int arg1;
3530
3531 arg1 = car(arglist);
3532 if (length(arglist) != 1)
3533 error(WRONG_ARGS, "basic-array-p", arglist);
3534
3535 if (!symbolp(arg1) && GET_AUX(arg1) == cbasic_array)
3536 return (T);
3537 else if (!symbolp(arg1) && subclassp(GET_AUX(arg1), cbasic_array))
3538 return (T);
3539 else
3540 return (NIL);
3541
3542 return (UNDEF);
3543 }
3544
3545 int
f_basic_array_star_p(int arglist)3546 f_basic_array_star_p(int arglist)
3547 {
3548 int arg1;
3549
3550 arg1 = car(arglist);
3551 if (length(arglist) != 1)
3552 error(WRONG_ARGS, "basic-array-p", arglist);
3553
3554 if (!symbolp(arg1) && GET_AUX(arg1) == cbasic_array_star)
3555 return (T);
3556 else if (!symbolp(arg1) && subclassp(GET_AUX(arg1), cbasic_array_star))
3557 return (T);
3558 else
3559 return (NIL);
3560
3561 return (UNDEF);
3562 }
3563
3564 int
f_general_array_star_p(int arglist)3565 f_general_array_star_p(int arglist)
3566 {
3567 int arg1;
3568
3569 arg1 = car(arglist);
3570 if (length(arglist) != 1)
3571 error(WRONG_ARGS, "general-array*-p", arglist);
3572
3573 if (!symbolp(arg1) && GET_AUX(arg1) == cgeneral_array_star)
3574 return (T);
3575 else if (!symbolp(arg1)
3576 && subclassp(GET_AUX(arg1), cgeneral_array_star))
3577 return (T);
3578 else
3579 return (NIL);
3580
3581 return (UNDEF);
3582 }
3583
3584
3585 int
f_array_dimensions(int arglist)3586 f_array_dimensions(int arglist)
3587 {
3588 int arg1;
3589
3590 arg1 = car(arglist);
3591 if (length(arglist) != 1)
3592 error(WRONG_ARGS, "array-dimensions", arglist);
3593 if (!vectorp(arg1) && !arrayp(arg1) && !stringp(arg1))
3594 error(NOT_ARR, "array-dimensions", arg1);
3595
3596 if (vectorp(arg1))
3597 return (list1(makeint(GET_CDR(arg1))));
3598 else if (arrayp(arg1))
3599 return (GET_CDR(arg1));
3600 else
3601 return (list1(makeint(strlen(GET_NAME(arg1)))));
3602 }
3603
3604
3605
3606 int
f_vector(int arglist)3607 f_vector(int arglist)
3608 {
3609 return (vector(arglist));
3610 }
3611
3612
3613 int
f_create_star(int arglist)3614 f_create_star(int arglist)
3615 {
3616 int arg1,
3617 arg2;
3618
3619 arg1 = car(arglist); // class
3620 arg2 = cadr(arglist); // initargs,vals
3621 if (length(arglist) != 2)
3622 error(WRONG_ARGS, "create", arglist);
3623 if (!(IS_CLASS(arg1)))
3624 error(NOT_CLASS, "create", arg1);
3625 if (GET_OPT(arg1) == SYSTEM || GET_OPT(arg1) == ABSTRACT)
3626 error(CANT_CREATE, "create", arg1);
3627
3628 return (makeinstance(arg1, arg2));
3629 }
3630
DEF_PREDICATE(INSTANCE,INSTANCE)3631 DEF_PREDICATE(INSTANCE, INSTANCE)
3632 int f_slot_value(int arglist)
3633 {
3634 int arg1,
3635 arg2,
3636 val;
3637
3638 arg1 = car(arglist); // instance
3639 arg2 = cadr(arglist); // var
3640 if (length(arglist) != 2)
3641 error(WRONG_ARGS, "slot-value", arglist);
3642 if (!(IS_INSTANCE(arg1)))
3643 error(NOT_INSTANCE, "slot-value", arg1);
3644 if (!symbolp(arg2))
3645 error(NOT_SYM, "slot-value", arg2);
3646
3647 val = assoc(arg2, GET_CDR(arg1));
3648 if (nullp(val))
3649 error(UNDEF_VAR, "slot-value", arg2);
3650
3651
3652 return (cdr(val));
3653 }
3654
3655 int
f_set_slot_value(int arglist)3656 f_set_slot_value(int arglist)
3657 {
3658 int arg1,
3659 arg2,
3660 arg3,
3661 val;
3662
3663 arg1 = car(arglist); // value to set
3664 arg2 = cadr(arglist); // instance
3665 arg3 = caddr(arglist); // var
3666 if (length(arglist) != 3)
3667 error(WRONG_ARGS, "set-slot-value", arglist);
3668 if (!(IS_INSTANCE(arg2)))
3669 error(NOT_INSTANCE, "set-slot-value", arg1);
3670 if (!symbolp(arg3))
3671 error(NOT_SYM, "set-slot-value", arg2);
3672
3673 val = assoc(arg3, GET_CDR(arg2));
3674 if (nullp(val))
3675 error(UNDEF_VAR, "set-slot-value", arg3);
3676
3677 set_cdr(val, arg1);
3678 return (arg1);
3679 }
3680
3681 int
f_format(int arglist)3682 f_format(int arglist)
3683 {
3684 int arg1,
3685 arg2,
3686 args,
3687 i,
3688 save,
3689 n,
3690 quote_flag;
3691 char *str,
3692 c;
3693
3694 arg1 = car(arglist); // output-stream
3695 arg2 = cadr(arglist); // format-string
3696 args = cddr(arglist); // data
3697 quote_flag = 0;
3698 if (!output_stream_p(arg1))
3699 error(NOT_OUT_STREAM, "format", arg1);
3700 if (!stringp(arg2))
3701 error(NOT_STR, "format", arg2);
3702
3703 save = output_stream;
3704 output_stream = arg1;
3705 str = Str_dup(GET_NAME(arg2), 1, 0, 1);
3706 i = 0;
3707 c = str[i];
3708 while (c != 0) {
3709 if (c == '~' && quote_flag == 0) {
3710 i++;
3711 c = str[i];
3712 if (c == 'A') {
3713 if (nullp(args)) {
3714 output_stream = save;
3715 error(IMPROPER_ARGS, "format ", arg2);
3716 }
3717 f_format_object(list3(arg1, car(args), NIL));
3718 args = cdr(args);
3719 } else if (c == 'B') {
3720 if (nullp(args)) {
3721 output_stream = save;
3722 error(IMPROPER_ARGS, "format ", arg2);
3723 }
3724 f_format_integer(list3(arg1, car(args), makeint(2)));
3725 args = cdr(args);
3726 } else if (c == 'C') {
3727 if (nullp(args)) {
3728 output_stream = save;
3729 error(IMPROPER_ARGS, "format ", arg2);
3730 }
3731 f_format_char(list2(arg1, car(args)));
3732 args = cdr(args);
3733 } else if (c == 'D') {
3734 if (nullp(args)) {
3735 output_stream = save;
3736 error(IMPROPER_ARGS, "format ", arg2);
3737 }
3738 f_format_integer(list3(arg1, car(args), makeint(10)));
3739 args = cdr(args);
3740 } else if (c == 'G') {
3741 if (nullp(args)) {
3742 output_stream = save;
3743 error(IMPROPER_ARGS, "format ", arg2);
3744 }
3745 f_format_float(list2(arg1, car(args)));
3746 args = cdr(args);
3747 } else if (c == 'O') {
3748 if (nullp(args)) {
3749 output_stream = save;
3750 error(IMPROPER_ARGS, "format ", arg2);
3751 }
3752 f_format_integer(list3(arg1, car(args), makeint(8)));
3753 args = cdr(args);
3754 } else if (c == 'S') {
3755 if (nullp(args)) {
3756 output_stream = save;
3757 error(IMPROPER_ARGS, "format ", arg2);
3758 }
3759 f_format_object(list3(arg1, car(args), T));
3760 args = cdr(args);
3761 } else if (c == 'X') {
3762 if (nullp(args)) {
3763 output_stream = save;
3764 error(IMPROPER_ARGS, "format ", arg2);
3765 }
3766 f_format_integer(list3(arg1, car(args), makeint(16)));
3767 args = cdr(args);
3768 } else if (isdigit(c)) {
3769 n = 0;
3770 while (isdigit(c)) {
3771 n = n * 10 + (c - '0');
3772 i++;
3773 c = str[i];
3774 }
3775 if (c == 'R') {
3776 if (nullp(args)) {
3777 output_stream = save;
3778 error(IMPROPER_ARGS, "format ", arg2);
3779 }
3780 f_format_integer(list3(arg1, car(args), makeint(n)));
3781 args = cdr(args);
3782 } else if (c == 'T') {
3783 if (nullp(args)) {
3784 output_stream = save;
3785 error(IMPROPER_ARGS, "format ", arg2);
3786 }
3787 f_format_tab(list2(arg1, makeint(n)));
3788 } else
3789 error(ILLEGAL_ARGS, "format ~n?", NIL);
3790
3791
3792 } else if (c == '%') {
3793 output_char(output_stream, '\n');
3794 start_flag = false;
3795 charcnt = 0;
3796 } else if (c == '&') {
3797 f_format_fresh_line(list1(arg1));
3798 } else if (c == '~') {
3799 output_char(output_stream, '~');
3800 start_flag = false;
3801 charcnt++;
3802 }
3803 i++;
3804 } else if (c == '\\' && str[i + 1] == '\\' && quote_flag == 0) {
3805 output_char(output_stream, c);
3806 i++;
3807 i++;
3808 c = str[i];
3809 output_char(output_stream, c);
3810 i++;
3811 } else if (c == '\\' && quote_flag == 0)
3812 i++;
3813 else if (c == '\\' && quote_flag == 1) {
3814 output_char(output_stream, c);
3815 i++;
3816 c = str[i];
3817 output_char(output_stream, c);
3818 i++;
3819 } else {
3820 if (c == '\'' && str[i + 1] == '\'') {
3821 if (quote_flag == 0)
3822 quote_flag = 1;
3823 else
3824 quote_flag = 0;
3825 c = '"';
3826 i++;
3827 }
3828 output_char(output_stream, c);
3829 i++;
3830 start_flag = false;
3831 charcnt++;
3832 }
3833 c = str[i];
3834 }
3835 output_stream = save;
3836 FREE(str);
3837 return (NIL);
3838 }
3839
3840 static int
printr_h(int r,int n,char * b,int * sign)3841 printr_h(int r, int n, char *b, int *sign)
3842 {
3843 int i;
3844 static const char *digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
3845
3846 REQUIRE(r >= 2 && r <= 36);
3847 *sign = 1;
3848 if (n == 0) {
3849 b[0] = '0';
3850 i = 0;
3851 } else {
3852 if (n >= 0)
3853 *sign = 1;
3854 else {
3855 *sign = -1;
3856 n = abs(n);
3857 }
3858 i = 0;
3859 while (n > 0) {
3860 b[i] = digits[n % r];
3861
3862 n = n / r;
3863 i++;
3864 }
3865 i--;
3866 }
3867 b[i + 1] = '\0';
3868 return (i + 1);
3869 }
3870
3871 int
fprintr(FILE * p,int r,int n)3872 fprintr(FILE * p, int r, int n)
3873 {
3874 int i,
3875 sign,
3876 len;
3877 char b[BININT_LEN + 1];
3878
3879 len = printr_h(r, n, b, &sign);
3880 i = len - 1;
3881 if (sign == -1) {
3882 fputc('-', p);
3883 len++;
3884 }
3885 while (i >= 0) {
3886 fputc(b[i], p);
3887 i--;
3888 }
3889 return (len);
3890 }
3891
3892 int
sprintr(char * str,int r,int n)3893 sprintr(char *str, int r, int n)
3894 {
3895 int i,
3896 j,
3897 sign,
3898 len;
3899 char b[BININT_LEN + 1];
3900
3901 len = printr_h(r, n, b, &sign);
3902 i = len - 1;
3903 j = 0;
3904 if (sign == -1) {
3905 str[j] = '-';
3906 j++;
3907 len++;
3908 }
3909 while (i >= 0) {
3910 str[j] = b[i];
3911 i--;
3912 j++;
3913 }
3914 str[j] = NUL;
3915 return (len);
3916 }
3917
3918 int
f_format_char(int arglist)3919 f_format_char(int arglist)
3920 {
3921 int arg1,
3922 arg2;
3923
3924 arg1 = car(arglist);
3925 arg2 = cadr(arglist);
3926 if (length(arglist) != 2)
3927 error(WRONG_ARGS, "format-char", arglist);
3928 if (!output_stream_p(arg1))
3929 error(NOT_OUT_STREAM, "format-char", arg1);
3930 if (!charp(arg2))
3931 error(NOT_CHAR, "format-char", arg2);
3932
3933 if (GET_OPT(arg1) != EISL_OUTSTR) {
3934 fputs(GET_NAME(arg2), GET_PORT(arg1));
3935 charcnt++;
3936 } else {
3937 append_str(arg1, GET_NAME(arg2));
3938 charcnt = charcnt + strlen(GET_NAME(arg2));
3939 }
3940 start_flag = false;
3941 return (NIL);
3942 }
3943
3944 int
f_format_fresh_line(int arglist)3945 f_format_fresh_line(int arglist)
3946 {
3947 int arg1;
3948
3949 arg1 = car(arglist);
3950 if (length(arglist) != 1)
3951 error(WRONG_ARGS, "format-fresh-line", arglist);
3952 if (!output_stream_p(arg1))
3953 error(NOT_STREAM, "format-fresh-line", arg1);
3954
3955 if (!start_flag) {
3956 int save;
3957
3958 save = output_stream;
3959 output_stream = arg1;
3960 // output newline char if it cannot be determinned that the output
3961 //
3962 //
3963 //
3964 //
3965 //
3966 //
3967 //
3968 //
3969 // stream is at the begining of a fresh line
3970 if (GET_OPT(output_stream) == EISL_OUTSTR
3971 && strlen(GET_NAME(output_stream)) == 0) {
3972 goto skip;
3973 }
3974 output_char(output_stream, '\n');
3975 start_flag = false;
3976 charcnt = 0;
3977 // if output_stream is string-stream, set charcnt 0.
3978 if (GET_OPT(output_stream) == EISL_OUTSTR) {
3979 SET_PROP(output_stream, 0);
3980 }
3981
3982 skip:
3983 output_stream = save;
3984 }
3985 return (NIL);
3986 }
3987
3988
3989 int
f_format_float(int arglist)3990 f_format_float(int arglist)
3991 {
3992 int arg1,
3993 arg2,
3994 save,
3995 flt;
3996
3997 arg1 = car(arglist);
3998 arg2 = cadr(arglist);
3999 if (length(arglist) != 2)
4000 error(WRONG_ARGS, "format-float", arglist);
4001 if (!output_stream_p(arg1))
4002 error(NOT_OUT_STREAM, "format-float", arg1);
4003 if (!numberp(arg2))
4004 error(NOT_FLT, "format-float", arg2);
4005 save = output_stream;
4006 output_stream = arg1;
4007 flt = exact_to_inexact(arg2);
4008 print(flt);
4009 start_flag = false;
4010 // count character
4011 output_stream = save;
4012 charcnt = charcnt + strlen(stream_str);
4013 return (NIL);
4014 }
4015
4016
4017 int
f_format_integer(int arglist)4018 f_format_integer(int arglist)
4019 {
4020 int arg1,
4021 arg2,
4022 arg3,
4023 n,
4024 save;
4025
4026 arg1 = car(arglist);
4027 arg2 = cadr(arglist);
4028 arg3 = caddr(arglist);
4029 if (length(arglist) != 3)
4030 error(WRONG_ARGS, "format-integer", arglist);
4031 if (!output_stream_p(arg1))
4032 error(NOT_OUT_STREAM, "format-integer", arg1);
4033 if (!integerp(arg2) && !longnump(arg2) && !bignump(arg2))
4034 error(NOT_INT, "format-integer", arg2);
4035 if (!integerp(arg3))
4036 error(NOT_INT, "format-integer", arg3);
4037 if ((n = GET_INT(arg3)) < 2 || n > 36)
4038 error(IMPROPER_ARGS, "format-integer", arg3);
4039
4040 save = output_stream;
4041 output_stream = arg1;
4042 if (integerp(arg2)) {
4043 int len;
4044
4045 if (GET_OPT(output_stream) != EISL_OUTSTR)
4046 len = fprintr(GET_PORT(arg1), GET_INT(arg3), GET_INT(arg2));
4047 else {
4048 len = sprintr(stream_str, GET_INT(arg3), GET_INT(arg2));
4049 append_str(output_stream, stream_str);
4050 }
4051 charcnt = charcnt + len;
4052 } else {
4053 print(arg2);
4054 charcnt = charcnt + strlen(stream_str);
4055 }
4056 output_stream = save;
4057 start_flag = false;
4058 return (NIL);
4059 }
4060
4061 int
f_format_object(int arglist)4062 f_format_object(int arglist)
4063 {
4064 int arg1,
4065 arg2,
4066 arg3,
4067 save;
4068
4069 arg1 = car(arglist);
4070 arg2 = cadr(arglist);
4071 arg3 = caddr(arglist);
4072
4073 if (length(arglist) != 3)
4074 error(WRONG_ARGS, "format-object", arglist);
4075 if (!output_stream_p(arg1))
4076 error(NOT_OUT_STREAM, "format-object", arglist);
4077
4078 save = output_stream;
4079 output_stream = arg1;
4080 if (stringp(arg2)) {
4081 if (nullp(arg3)) {
4082 output_str(arg1, GET_NAME(arg2));
4083 charcnt = charcnt + strlen(GET_NAME(arg2));
4084 } else {
4085 if (GET_OPT(arg1) != EISL_OUTSTR) {
4086 Fmt_fprint(GET_PORT(arg1), "\\\"%s\\\"", GET_NAME(arg2));
4087 } else {
4088 Fmt_sfmt(stream_str, STRSIZE, "\\\"%s\\\"",
4089 GET_NAME(arg2));
4090 append_str(arg1, stream_str);
4091 }
4092 charcnt = charcnt + 4 + strlen(GET_NAME(arg2));
4093 }
4094 } else if (charp(arg2)) {
4095 if (nullp(arg3)) {
4096 output_str(arg1, GET_NAME(arg2));
4097 charcnt = charcnt + strlen(GET_NAME(arg2));
4098 } else {
4099 if (GET_OPT(arg1) != EISL_OUTSTR)
4100 Fmt_fprint(GET_PORT(arg1), "#\\\\%s", GET_NAME(arg2));
4101 else {
4102 char *str =
4103 Str_cat("#\\\\", 1, 0, GET_NAME(arg2), 1, 0);
4104 append_str(arg1, str);
4105 FREE(str);
4106 }
4107 charcnt = charcnt + 3 + strlen(GET_NAME(arg2));
4108 }
4109 } else {
4110 print(arg2);
4111 charcnt = charcnt + strlen(stream_str);
4112 }
4113 output_stream = save;
4114 start_flag = false;
4115 return (NIL);
4116 }
4117
4118 int
f_format_tab(int arglist)4119 f_format_tab(int arglist)
4120 {
4121 int arg1,
4122 arg2,
4123 n,
4124 save;
4125
4126 arg1 = car(arglist);
4127 arg2 = cadr(arglist);
4128 if (length(arglist) != 2)
4129 error(WRONG_ARGS, "format-tab", arglist);
4130 if (!output_stream_p(arg1))
4131 error(NOT_OUT_STREAM, "format-tab", arg1);
4132 if (!integerp(arg2))
4133 error(IMPROPER_ARGS, "format-tab", arg2);
4134 if (negativep(arg2))
4135 error(IMPROPER_ARGS, "format-tab", arg2);
4136
4137 save = output_stream;
4138 output_stream = arg1;
4139
4140 if (GET_OPT(output_stream) != EISL_OUTSTR)
4141 n = GET_INT(arg2) - charcnt;
4142 else
4143 n = GET_INT(arg2) - GET_PROP(output_stream);
4144
4145 if (n < 0)
4146 n = 1;
4147 while (n > 0) {
4148 output_char(arg1, ' ');
4149 n--;
4150 charcnt++;
4151 }
4152 start_flag = false;
4153 output_stream = save;
4154 return (NIL);
4155 }
4156
4157
4158 int
f_open_input_file(int arglist)4159 f_open_input_file(int arglist)
4160 {
4161 int arg1,
4162 n;
4163 FILE *port;
4164
4165 arg1 = car(arglist);
4166 if ((n = length(arglist)) != 1 && n != 2)
4167 error(WRONG_ARGS, "open-input-file", arglist);
4168 if (!stringp(arg1))
4169 error(NOT_STR, "open-input-file", arg1);
4170
4171 const char *fname = GET_NAME(arg1);
4172 if (n == 1)
4173 port = fopen(fname, "r");
4174 else
4175 port = fopen(fname, "rb");
4176
4177 if (port == NULL)
4178 error(CANT_OPEN, "open-input-file", arg1);
4179
4180 return (makestream(port, EISL_INPUT, Str_dup(fname, 1, 0, 1)));
4181 }
4182
4183 int
f_open_output_file(int arglist)4184 f_open_output_file(int arglist)
4185 {
4186 int arg1,
4187 n;
4188 FILE *port;
4189
4190 arg1 = car(arglist);
4191 if ((n = length(arglist)) != 1 && n != 2)
4192 error(WRONG_ARGS, "open-output-file", arglist);
4193 if (!stringp(arg1))
4194 error(NOT_STR, "open-output-file", arg1);
4195
4196 const char *fname = GET_NAME(arg1);
4197 port = fopen(fname, "w");
4198 if (port == NULL)
4199 error(CANT_OPEN, "open-output-file", arg1);
4200
4201 return (makestream(port, EISL_OUTPUT, Str_dup(fname, 1, 0, 1)));
4202 }
4203
4204 int
f_open_io_file(int arglist)4205 f_open_io_file(int arglist)
4206 {
4207 int arg1,
4208 n;
4209 FILE *port;
4210
4211 arg1 = car(arglist);
4212 if ((n = length(arglist)) != 1 && n != 2)
4213 error(WRONG_ARGS, "open-io-file", arglist);
4214 if (!stringp(arg1))
4215 error(NOT_STR, "open-io-file", arg1);
4216
4217 const char *fname = GET_NAME(arg1);
4218 port = fopen(fname, "r+");
4219 if (port == NULL)
4220 error(CANT_OPEN, "open-io-file", arg1);
4221
4222 return (makestream(port, EISL_OPEN, Str_dup(fname, 1, 0, 1)));
4223 }
4224
4225 int
f_close(int arglist)4226 f_close(int arglist)
4227 {
4228 int arg1;
4229
4230 arg1 = car(arglist);
4231 if (length(arglist) != 1)
4232 error(WRONG_ARGS, "close", arglist);
4233 if (!streamp(arg1))
4234 error(NOT_STREAM, "close", arg1);
4235
4236 if (GET_OPT(arg1) != EISL_INSTR && GET_OPT(arg1) != EISL_OUTSTR)
4237 fclose(GET_PORT(arg1));
4238 else
4239 SET_OPT(arg1, EISL_CLOSESTR);
4240
4241 start_flag = true;
4242 return (UNDEF);
4243 }
4244
4245 int
f_finish_output(int arglist)4246 f_finish_output(int arglist)
4247 {
4248 int arg1;
4249
4250 arg1 = car(arglist);
4251 if (length(arglist) != 1)
4252 error(WRONG_ARGS, "finish-output", arglist);
4253 if (!(streamp(arg1) && GET_CDR(arg1) == EISL_OUTPUT))
4254 error(NOT_OUT_STREAM, "finish-output", arg1);
4255 fflush(GET_PORT(arg1));
4256 return (UNDEF);
4257 }
4258
4259
4260 int
f_file_length(int arglist)4261 f_file_length(int arglist)
4262 {
4263 int arg1,
4264 arg2,
4265 size,
4266 res;
4267 FILE *p;
4268
4269 arg1 = car(arglist);
4270 arg2 = cadr(arglist);
4271 if (length(arglist) != 2)
4272 error(WRONG_ARGS, "file-length", arglist);
4273 if (!stringp(arg1))
4274 error(NOT_STR, "file-length", arg1);
4275 if (!integerp(arg2))
4276 error(NOT_INT, "file-length", arg2);
4277
4278 p = fopen(GET_NAME(arg1), "rb");
4279 if (p == NULL) {
4280 error(CANT_OPEN, "file-length", arg1);
4281 return NIL;
4282 }
4283
4284 fseek(p, 0, SEEK_END);
4285 size = ftell(p);
4286 fclose(p);
4287 res = size;
4288 return (makeint(res));
4289 }
4290
4291 int
f_probe_file(int arglist)4292 f_probe_file(int arglist)
4293 {
4294 int arg1,
4295 res;
4296 FILE *p;
4297
4298 arg1 = car(arglist);
4299 if (length(arglist) != 1)
4300 error(WRONG_ARGS, "probe-file", arglist);
4301 if (!stringp(arg1))
4302 error(NOT_STR, "probe-file", arg1);
4303
4304 res = T;
4305 p = fopen(GET_NAME(arg1), "rb");
4306 if (p == NULL)
4307 res = NIL;
4308
4309 if (res != NIL)
4310 fclose(p);
4311
4312 return (res);
4313 }
4314
4315 int
f_file_position(int arglist)4316 f_file_position(int arglist)
4317 {
4318 int arg1;
4319 FILE *p;
4320
4321 arg1 = car(arglist);
4322 if (length(arglist) != 1)
4323 error(WRONG_ARGS, "file-position", arglist);
4324 if (!streamp(arg1))
4325 error(NOT_STREAM, "file-position", arg1);
4326
4327 p = GET_PORT(arg1);
4328 return (makeint(ftell(p)));
4329
4330 }
4331
4332 int
f_set_file_position(int arglist)4333 f_set_file_position(int arglist)
4334 {
4335 int arg1,
4336 arg2;
4337 FILE *p;
4338
4339 arg1 = car(arglist);
4340 arg2 = cadr(arglist);
4341 if (length(arglist) != 2)
4342 error(WRONG_ARGS, "set-file-position", arglist);
4343 if (!streamp(arg1))
4344 error(NOT_STREAM, "set-file-position", arg1);
4345 if (!integerp(arg2))
4346 error(NOT_INT, "set-file-position", arg2);
4347 if (negativep(arg2))
4348 error(NOT_POSITIVE, "set-file-position", arg2);
4349
4350 p = GET_PORT(arg1);
4351 fseek(p, GET_INT(arg2), SEEK_SET);
4352 return (arg2);
4353 }
4354
4355
4356
4357 int
f_write_byte(int arglist)4358 f_write_byte(int arglist)
4359 {
4360 int arg1,
4361 arg2;
4362
4363 arg1 = car(arglist);
4364 arg2 = cadr(arglist);
4365 if (length(arglist) != 2)
4366 error(WRONG_ARGS, "write-byte", arglist);
4367 if (!integerp(arg1))
4368 error(NOT_INT, "write-byte", arg1);
4369 if (!(streamp(arg2) && GET_OPT(arg2)))
4370 error(NOT_OUT_STREAM, "write-byte", arg2);
4371
4372 fputc((char) GET_INT(arg1), GET_PORT(arg2));
4373 return (arg1);
4374 }
4375
4376
4377
4378 int
f_create_vector(int arglist)4379 f_create_vector(int arglist)
4380 {
4381 int arg1,
4382 arg2;
4383
4384 arg1 = car(arglist);
4385 arg2 = cadr(arglist);
4386
4387 if (length(arglist) != 1 && length(arglist) != 2)
4388 error(WRONG_ARGS, "create-vector", arglist);
4389 if (negativep(arg1))
4390 error(NOT_POSITIVE, "create-vector", arg1);
4391 if (!integerp(arg1))
4392 error(EXHAUSTED_ERR, "create-vector", arg1);
4393 if (length(arglist) == 1)
4394 arg2 = UNDEF;
4395
4396 return (makevec(GET_INT(arg1), arg2));
4397 }
4398
4399 int
f_create_array(int arglist)4400 f_create_array(int arglist)
4401 {
4402 int arg1,
4403 arg2,
4404 temp;
4405
4406 arg1 = car(arglist);
4407 arg2 = cadr(arglist);
4408
4409 temp = 0;
4410 if (length(arglist) != 1 && length(arglist) != 2
4411 && length(arglist) != 3)
4412 error(OUT_OF_DOMAIN, "create-array", arglist);
4413 if (!listp(arg1))
4414 error(NOT_LIST, "create-array", arg1);
4415 if ((temp = check_dimension(arg1)) == 1)
4416 error(OUT_OF_DOMAIN, "create-array", arg1);
4417 if (temp == 2)
4418 error(EXHAUSTED_ERR, "create-array", arg1);
4419 if (length(arglist) == 1)
4420 arg2 = UNDEF;
4421
4422 return (makearray(arg1, arg2));
4423
4424 }
4425
4426 // when dimension is domain-error return 1.
4427 // when dimension is storage-exhausted-error return 2.
4428 int
check_dimension(int ls)4429 check_dimension(int ls)
4430 {
4431 while (!nullp(ls)) {
4432 if (negativep(car(ls)))
4433 return (1);
4434 else if (longnump(car(ls)) || bignump(car(ls)))
4435 return (2);
4436 else if (!integerp(car(ls)))
4437 return (1);
4438 else
4439 ls = cdr(ls);
4440 }
4441 return (0);
4442 }
4443
4444 int
f_create_string(int arglist)4445 f_create_string(int arglist)
4446 {
4447 int arg1,
4448 arg2,
4449 n;
4450 char *str,
4451 c;
4452
4453 arg1 = car(arglist);
4454 arg2 = cadr(arglist);
4455 if ((n = length(arglist)) != 1 && n != 2)
4456 error(WRONG_ARGS, "create-string", arglist);
4457 if (negativep(arg1))
4458 error(DOMAIN_ERR, "create-string", arg1);
4459 if (longnump(arg1) || bignump(arg1))
4460 error(EXHAUSTED_ERR, "create-string", arg1);
4461
4462
4463 n = GET_INT(arg1);
4464 if (nullp(arg2))
4465 c = ' ';
4466 else
4467 c = GET_CHAR(arg2);
4468
4469 str = ALLOC(n + 1);
4470 memset(str, c, n);
4471 str[n] = NUL;
4472 int res = makestr(str);
4473 FREE(str);
4474 return res;
4475 }
4476
4477 int
f_parse_number(int arglist)4478 f_parse_number(int arglist)
4479 {
4480 int arg1,
4481 res;
4482 char *e;
4483
4484 arg1 = car(arglist);
4485 if (length(arglist) != 1)
4486 error(WRONG_ARGS, "parse-number", arglist);
4487 if (!stringp(arg1))
4488 error(NOT_STR, "parse-number", arg1);
4489 if (strcmp(GET_NAME(arg1), "") == 0)
4490 error(CANT_PARSE, "parse-number", arg1);
4491
4492 strncpy(stok.buf, GET_NAME(arg1), BUFSIZE - 1);
4493 stok.buf[BUFSIZE - 1] = '\0';
4494
4495 if (bignumtoken(stok.buf))
4496 return (makebigx(stok.buf));
4497
4498 if (dectoken(stok.buf))
4499 return (makeint((int) strtol(stok.buf, &e, 10)));
4500
4501 if (inttoken(stok.buf))
4502 return (makeint(strtol(stok.buf, &e, 10)));
4503
4504 if (flttoken(stok.buf))
4505 return (makeflt(atof(stok.buf)));
4506
4507 if ((res = expttoken(stok.buf))) {
4508 if (res == 2)
4509 error(FLT_OVERF, "number-parse", arg1);
4510 else if (res == 3)
4511 error(FLT_UNDERF, "number-parse", arg1);
4512 else
4513 return (makeflt(atof(stok.buf)));
4514 }
4515
4516 if (bintoken(stok.buf))
4517 return (readbin(stok.buf));
4518
4519 if (octtoken(stok.buf))
4520 return (readoct(stok.buf));
4521
4522 if (hextoken(stok.buf))
4523 return (readhex(stok.buf));
4524
4525
4526 error(CANT_PARSE, "parse-number", arg1);
4527 return (UNDEF);
4528 }
4529
4530 int
f_create_string_input_stream(int arglist)4531 f_create_string_input_stream(int arglist)
4532 {
4533 int arg1,
4534 res;
4535
4536 arg1 = car(arglist);
4537 if (length(arglist) != 1)
4538 error(WRONG_ARGS, "create-string-input-stream", arglist);
4539 if (!stringp(arg1))
4540 error(NOT_STR, "create-string-input-stream", arg1);
4541
4542 res = makestream(stdin, EISL_INSTR, NULL);
4543 TRY heap[res].name = Str_dup(GET_NAME(arg1), 1, 0, 1);
4544 EXCEPT(Mem_Failed)
4545 error(MALLOC_OVERF, "create-string-input-stream", NIL);
4546 END_TRY;
4547 return (res);
4548 }
4549
4550 int
f_create_string_output_stream(int arglist)4551 f_create_string_output_stream(int arglist)
4552 {
4553 int res;
4554 char *str;
4555
4556 if (length(arglist) != 0)
4557 error(WRONG_ARGS, "create-string-output-stream", arglist);
4558
4559 res = makestream(stdout, EISL_OUTSTR, NULL);
4560 TRY str = (char *) ALLOC(STRSIZE);
4561 EXCEPT(Mem_Failed)
4562 error(MALLOC_OVERF, "create-string-output-stream", NIL);
4563 END_TRY;
4564 heap[res].name = str;
4565 heap[res].name[0] = '\0';
4566 return (res);
4567 }
4568
4569 int
f_get_output_stream_string(int arglist)4570 f_get_output_stream_string(int arglist)
4571 {
4572 int arg1,
4573 res;
4574
4575 arg1 = car(arglist);
4576 if (length(arglist) != 1)
4577 error(WRONG_ARGS, "get-output-stream-string", arglist);
4578 if (!output_stream_p(arg1))
4579 error(NOT_STR, "get-output-stream-string", arg1);
4580
4581 res = makestr(GET_NAME(arg1));
4582 heap[arg1].name[0] = '\0';
4583 return (res);
4584 }
4585
4586
4587
4588 int
f_subseq(int arglist)4589 f_subseq(int arglist)
4590 {
4591 int arg1,
4592 arg2,
4593 arg3;
4594
4595 arg1 = car(arglist);
4596 arg2 = cadr(arglist);
4597 arg3 = caddr(arglist);
4598 if (length(arglist) != 3)
4599 error(WRONG_ARGS, "subseq", arglist);
4600 if (!integerp(arg2) && !longnump(arg2))
4601 error(NOT_INT, "subseq", arg2);
4602 if (!integerp(arg3) && !longnump(arg3))
4603 error(NOT_INT, "subseq", arg3);
4604 if (negativep(arg2) || negativep(arg3))
4605 error(OUT_OF_DOMAIN, "subseq", arglist);
4606 if (greaterp(arg2, arg3))
4607 error(OUT_OF_RANGE, "subseq", arglist);
4608
4609
4610
4611 if (stringp(arg1)) {
4612 if (((int) strlen(GET_NAME(arg1))) < GET_INT(arg3))
4613 error(OUT_OF_RANGE, "subseq", arglist);
4614 return (substr(arg1, GET_INT(arg2), GET_INT(arg3)));
4615 } else if (listp(arg1)) {
4616 if (length(arg1) < GET_INT(arg3))
4617 error(OUT_OF_RANGE, "subseq", arglist);
4618 return (sublis(arg1, GET_INT(arg2), GET_INT(arg3)));
4619 } else if (vectorp(arg1)) {
4620 if (vector_length(arg1) < GET_INT(arg3))
4621 error(OUT_OF_RANGE, "subseq", arglist);
4622 return (subvec(arg1, GET_INT(arg2), GET_INT(arg3)));
4623 }
4624
4625 error(ILLEGAL_ARGS, "subseq", arg1);
4626 return (UNDEF);
4627 }
4628
4629
4630 int
f_identity(int arglist)4631 f_identity(int arglist)
4632 {
4633 int arg1;
4634
4635 arg1 = car(arglist);
4636 if (length(arglist) != 1)
4637 error(WRONG_ARGS, "identity", arglist);
4638
4639 return (arg1);
4640 }
4641
4642 int
f_get_universal_time(int arglist)4643 f_get_universal_time(int arglist)
4644 {
4645 time_t t;
4646
4647 if (length(arglist) != 0)
4648 error(WRONG_ARGS, "get-universal-time", arglist);
4649
4650 t = time(NULL);
4651 return (makelong((long long int) (t + 70 * 365.25 * 24 * 60 * 60)));
4652 }
4653
4654 int
f_get_internal_run_time(int arglist)4655 f_get_internal_run_time(int arglist)
4656 {
4657 clock_t t;
4658
4659 if (length(arglist) != 0)
4660 error(WRONG_ARGS, "get-internal-run-time", arglist);
4661
4662 t = clock();
4663 return (makeint((int) t));
4664 }
4665
4666 int
f_get_internal_real_time(int arglist)4667 f_get_internal_real_time(int arglist)
4668 {
4669 time_t t;
4670
4671 if (length(arglist) != 0)
4672 error(WRONG_ARGS, "get-internal-real-time", arglist);
4673
4674 t = time(NULL);
4675 return (makelong((long long int) (t * CLOCKS_PER_SEC)));
4676 }
4677
4678 int
f_internal_time_units_per_second(int arglist)4679 f_internal_time_units_per_second(int arglist)
4680 {
4681
4682 if (length(arglist) != 0)
4683 error(WRONG_ARGS, "internal-time-units-per-second", arglist);
4684
4685 return (makeint(CLOCKS_PER_SEC));
4686 }
4687
4688
4689 int
f_initialize_object_star(int arglist)4690 f_initialize_object_star(int arglist)
4691 {
4692 int arg1,
4693 arg2;
4694
4695 arg1 = car(arglist);
4696 arg2 = cadr(arglist);
4697
4698 if (length(arglist) != 2)
4699 error(WRONG_ARGS, "initialize-object*", arglist);
4700 if (!(IS_INSTANCE(arg1)))
4701 error(NOT_INSTANCE, "initialize-object*", arg1);
4702 if (!listp(arg2))
4703 error(NOT_LIST, "initialize-object*", arg2);
4704
4705 return (initinst(arg1, arg2));
4706 }
4707
4708 // controle
4709 __dead int
f_quit(int arglist __unused)4710 f_quit(int arglist __unused)
4711 {
4712 if (!script_flag) {
4713 puts("- good bye -");
4714 }
4715 greeting_flag = false;
4716 RAISE(Exit_Interp);
4717 }
4718
4719 // extension
4720
4721 int
f_heapdump(int arglist)4722 f_heapdump(int arglist)
4723 {
4724 int arg;
4725
4726 arg = GET_INT(car(arglist));
4727 heapdump(arg, arg + 10);
4728 return (T);
4729 }
4730
4731 static inline void
SET_FLAG(int addr,flag x)4732 SET_FLAG(int addr, flag x)
4733 {
4734 REQUIRE(CELLRANGE(addr));
4735 heap[addr].flag = x;
4736 }
4737
4738 int
f_gbc(int arglist)4739 f_gbc(int arglist)
4740 {
4741 int n,
4742 addr;
4743
4744 if ((n = length(arglist)) != 0 && n != 1)
4745 error(WRONG_ARGS, "gbc", arglist);
4746 if (nullp(arglist))
4747 (void) gbc();
4748 else if (car(arglist) == T)
4749 gbc_flag = true;
4750 else if (car(arglist) == NIL)
4751 gbc_flag = false;
4752 else if (car(arglist) == makesym("M&S")) {
4753 // re initialize heap area
4754 for (addr = WORK1; addr < CELLSIZE; addr++) {
4755 SET_FLAG(addr, FRE);
4756 SET_CAR(addr, 0);
4757 SET_AUX(addr, 0);
4758 SET_PROP(addr, 0);
4759 SET_OPT(addr, 0);
4760 SET_CDR(addr, hp);
4761 hp = addr;
4762 }
4763 fc = fc + (CELLSIZE - WORK1);
4764 gc_sw = 0;
4765 } else if (car(arglist) == makesym("COPY")) {
4766 // initialize work area
4767 for (addr = WORK1; addr < CELLSIZE; addr++) {
4768 SET_CAR(addr, 0);
4769 SET_CDR(addr, 0);
4770 SET_AUX(addr, 0);
4771 SET_OPT(addr, 0);
4772 }
4773 fc = fc - (CELLSIZE - WORK1);
4774 gc_sw = 1;
4775 wp = WORK1;
4776 } else
4777 error(WRONG_ARGS, "gbc", arglist);
4778
4779 return (T);
4780 }
4781
4782 int
f_dummyp(int arglist)4783 f_dummyp(int arglist)
4784 {
4785 int arg1;
4786
4787 arg1 = car(arglist);
4788 if (length(arglist) != 1)
4789 error(WRONG_ARGS, "dummyp", arg1);
4790
4791 if (GET_TAG(arg1) == DUMMY)
4792 return (T);
4793 else
4794 return (NIL);
4795 }
4796
4797 // object
4798
4799 int
f_class_of(int arglist)4800 f_class_of(int arglist)
4801 {
4802 int arg;
4803
4804 arg = car(arglist);
4805 if (length(arglist) != 1)
4806 error(WRONG_ARGS, "class-of", arglist);
4807 if (nullp(arg))
4808 return (GET_AUX(arg));
4809 else if (GET_OPT(arg) == SYSTEM)
4810 return (cbuilt_in_class);
4811 else if (GET_OPT(arg) == USER)
4812 return (cstandard_class);
4813 else if (symbolp(arg))
4814 return (csymbol);
4815 else
4816 return (GET_AUX(arg));
4817 }
4818
4819 int
f_instancep(int arglist)4820 f_instancep(int arglist)
4821 {
4822 int arg1,
4823 arg2;
4824
4825 arg1 = car(arglist);
4826 arg2 = cadr(arglist);
4827 if (length(arglist) != 2)
4828 error(WRONG_ARGS, "instancep", arglist);
4829 if (!classp(arg2))
4830 error(NOT_CLASS, "instancep", arg2);
4831
4832
4833
4834 if (symbolp(arg1) && arg1 != NIL && arg1 != T) {
4835 if (arg2 == csymbol)
4836 return (T);
4837 else if (subclassp(csymbol, arg2))
4838 return (T);
4839 else
4840 return (NIL);
4841 } else if (IS_GENERIC(arg1) && strcmp(GET_NAME(arg1), "CREATE") == 0) {
4842 // (instancep #'create (class <standard-generic-function>)) =>
4843 // NIL)
4844 if (subclassp(GET_AUX(arg1), arg2))
4845 return (T);
4846 else
4847 return (NIL);
4848 } else if (GET_OPT(arg1) == USER && arg2 == cstandard_class)
4849 // user defined class instance is standard-class
4850 return (T);
4851 else if (GET_AUX(arg1) == arg2)
4852 return (T);
4853 else if (subclassp(GET_AUX(arg1), arg2))
4854 return (T);
4855 else if (GET_OPT(arg1) == SYSTEM && arg2 == cbuilt_in_class)
4856 return (T);
4857 else
4858 return (NIL);
4859 }
4860
4861 int
f_subclassp(int arglist)4862 f_subclassp(int arglist)
4863 {
4864 int arg1,
4865 arg2;
4866
4867 arg1 = car(arglist);
4868 arg2 = cadr(arglist);
4869 if (length(arglist) != 2)
4870 error(WRONG_ARGS, "subclassp", arglist);
4871 if (!classp(arg1))
4872 error(NOT_CLASS, "subclassp", arg2);
4873 if (!classp(arg2))
4874 error(NOT_CLASS, "subclassp", arg2);
4875
4876
4877 if (subclassp(arg1, arg2))
4878 return (T);
4879 else
4880 return (NIL);
4881 }
4882
4883
4884 int
f_generic_function_p(int arglist)4885 f_generic_function_p(int arglist)
4886 {
4887 int arg1;
4888
4889 arg1 = car(arglist);
4890 if (length(arglist) != 1)
4891 error(WRONG_ARGS, "generic-function-p", arglist);
4892
4893 if (IS_GENERIC(arg1))
4894 return (T);
4895 else
4896 return (NIL);
4897 }
4898
4899
4900
4901 int
f_next_method_p(int arglist)4902 f_next_method_p(int arglist)
4903 {
4904 int method;
4905
4906 if (generic_func == NIL)
4907 error(UNDEF_FUN, "next-method-p", NIL);
4908 if (length(arglist) != 0)
4909 error(WRONG_ARGS, "next-method-p", arglist);
4910
4911 method = cdr(next_method);
4912 while (!nullp(method)) {
4913 int varlist;
4914
4915 varlist = car(GET_CAR(car(method)));
4916 if (adaptp(varlist, generic_vars)) {
4917 return (T);
4918 }
4919 method = cdr(method);
4920 }
4921 return (NIL);
4922 }
4923
4924 int
f_call_next_method(int arglist)4925 f_call_next_method(int arglist)
4926 {
4927 int varlist,
4928 body,
4929 res,
4930 pexist,
4931 qexist,
4932 caller,
4933 save1,
4934 save2;
4935
4936 if (generic_func == NIL)
4937 error(UNDEF_FUN, "call-next-method", NIL);
4938 if (length(arglist) != 0)
4939 error(WRONG_ARGS, "call-next-method", arglist);
4940 if (nullp(cdr(next_method)))
4941 error(IMPROPER_ARGS, "call-next-method",
4942 GET_CAR(car(next_method)));
4943 if (GET_OPT(car(next_method)) != AROUND
4944 && GET_OPT(car(next_method)) != PRIMARY) {
4945 error(IMPROPER_ARGS, "call-next-method",
4946 GET_CAR(car(next_method)));
4947 }
4948
4949 res = NIL;
4950 varlist = NIL;
4951 save1 = next_method;
4952 caller = car(next_method);
4953 next_method = cdr(next_method);
4954 if (GET_OPT(caller) == PRIMARY) {
4955 while (!nullp(next_method)) {
4956 varlist = car(GET_CAR(car(next_method)));
4957 // match(x,y) if sameclass or subclass return 1 else 0;
4958 if (adaptp(varlist, generic_vars)) {
4959 varlist = genlamlis_to_lamlis(varlist);
4960 body = cdr(GET_CAR(car(next_method)));
4961 bindarg(varlist, generic_vars);
4962 while (!nullp(body)) {
4963 res = eval(car(body));
4964 body = cdr(body);
4965 }
4966 unbind();
4967 goto exit;
4968 }
4969 next_method = cdr(next_method);
4970 }
4971 } else {
4972 while (!nullp(next_method)) {
4973 varlist = car(GET_CAR(car(next_method)));
4974 // match(x,y) if sameclass or subclass return 1 else 0;
4975 if (adaptp(varlist, generic_vars)) {
4976 if (GET_OPT(car(next_method)) == AROUND
4977 || GET_OPT(car(next_method)) == BEFORE
4978 || GET_OPT(car(next_method)) == AFTER) {
4979 qexist = 1;
4980 }
4981 if (GET_OPT(car(next_method)) == PRIMARY) {
4982 pexist = 1;
4983 }
4984 // if only qualifier or sameclass-primary, eval method;
4985 if ((GET_OPT(car(next_method)) == AROUND
4986 || GET_OPT(car(next_method)) == BEFORE
4987 || GET_OPT(car(next_method)) == AFTER)
4988 || GET_OPT(car(next_method)) == PRIMARY) {
4989 varlist = genlamlis_to_lamlis(varlist);
4990 body = cdr(GET_CAR(car(next_method)));
4991 save2 = multiple_call_next_method;
4992 multiple_call_next_method =
4993 has_multiple_call_next_method_p(body);
4994 bindarg(varlist, generic_vars);
4995 while (!nullp(body)) {
4996 res = eval(car(body));
4997 body = cdr(body);
4998 }
4999 multiple_call_next_method = save2;
5000 unbind();
5001 }
5002 if (GET_OPT(car(next_method)) == AROUND) {
5003 goto exit;
5004 }
5005 }
5006 next_method = cdr(next_method);
5007 }
5008 exit:
5009 if (pexist == 0 && qexist == 0)
5010 error(NOT_EXIST_METHOD, "call-next-method", generic_vars);
5011
5012 if (multiple_call_next_method) {
5013 next_method = save1;
5014 }
5015
5016
5017 return (res);
5018 }
5019 return (NIL);
5020 }
5021
5022
5023
5024 // condition
5025 int
f_error(int arglist)5026 f_error(int arglist)
5027 {
5028 int arg1,
5029 arg2;
5030
5031 arg1 = car(arglist); // error-string
5032 arg2 = cdr(arglist); // obj
5033
5034 if (!stringp(arg1))
5035 error(NOT_STR, "error", arg1);
5036
5037 return (signal_condition
5038 (makeusercond(csimple_error, arg1, arg2), NIL));
5039 }
5040
5041 int
f_cerror(int arglist)5042 f_cerror(int arglist)
5043 {
5044 int arg1,
5045 arg2,
5046 arg3;
5047
5048 arg1 = car(arglist); // continue-string
5049 arg2 = cadr(arglist); // error-string
5050 arg3 = cddr(arglist); // obj
5051 if (!stringp(arg1))
5052 error(NOT_STR, "error", arg1);
5053 if (!stringp(arg2))
5054 error(NOT_STR, "error", arg2);
5055
5056 return (signal_condition(makeusercond(cerror, arg2, arg3), arg1));
5057 }
5058
5059 int
f_signal_condition(int arglist)5060 f_signal_condition(int arglist)
5061 {
5062 int arg1,
5063 arg2;
5064
5065 arg1 = car(arglist);
5066 arg2 = cadr(arglist);
5067 if (length(arglist) != 2)
5068 error(WRONG_ARGS, "signal-condition", arglist);
5069
5070 signal_condition(arg1, arg2);
5071 return (UNDEF);
5072 }
5073
5074 int
f_simple_error_format_string(int arglist)5075 f_simple_error_format_string(int arglist)
5076 {
5077 int arg1,
5078 vars,
5079 val;
5080
5081 arg1 = car(arglist);
5082 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5083 error(SIMPLE_ERR, "simple-error-format-string", arg1);
5084
5085 vars = GET_CDR(arg1);
5086 val = cdr(assq(makesym("a"), vars));
5087 return (val);
5088 }
5089
5090 int
f_simple_error_format_arguments(int arglist)5091 f_simple_error_format_arguments(int arglist)
5092 {
5093 int arg1,
5094 vars,
5095 val;
5096
5097 arg1 = car(arglist);
5098 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5099 error(SIMPLE_ERR, "simple-error-format-arguments", arg1);
5100
5101 vars = GET_CDR(arg1);
5102 val = cdr(assq(makesym("b"), vars));
5103 return (val);
5104 }
5105
5106 int
f_arithmetic_error_operation(int arglist)5107 f_arithmetic_error_operation(int arglist)
5108 {
5109 int arg1,
5110 fun;
5111
5112 arg1 = car(arglist);
5113 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5114 error(ARITHMETIC_ERR, "arithmetic-error-operation", arg1);
5115
5116 fun = GET_CAR(cdr(assoc(makesym("c"), GET_CDR(arg1))));
5117 return (fun);
5118 }
5119
5120
5121 int
f_arithmetic_error_operands(int arglist)5122 f_arithmetic_error_operands(int arglist)
5123 {
5124 int arg1,
5125 fun;
5126
5127 arg1 = car(arglist);
5128 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5129 error(ARITHMETIC_ERR, "arithmetic-error-operands", arg1);
5130
5131 fun = cdr(assoc(makesym("b"), GET_CDR(arg1)));
5132 return (fun);
5133 }
5134
5135 int
f_domain_error_object(int arglist)5136 f_domain_error_object(int arglist)
5137 {
5138 int arg1,
5139 fun;
5140
5141 arg1 = car(arglist);
5142 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5143 error(DOMAIN_ERR, "domain-error-object",
5144 cons(arg1, cdomain_error));
5145
5146 fun = cdr(assoc(makesym("f"), GET_CDR(arg1)));
5147 return (fun);
5148 }
5149
5150 int
f_domain_error_expected_class(int arglist)5151 f_domain_error_expected_class(int arglist)
5152 {
5153 int arg1,
5154 fun;
5155
5156 arg1 = car(arglist);
5157 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5158 error(DOMAIN_ERR, "domain-error-expected-class",
5159 cons(arg1, cdomain_error));
5160
5161 fun = cdr(assoc(makesym("g"), GET_CDR(arg1)));
5162 return (fun);
5163 }
5164
5165 int
f_parse_error_string(int arglist)5166 f_parse_error_string(int arglist)
5167 {
5168 int arg1,
5169 fun;
5170
5171 arg1 = car(arglist);
5172 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5173 error(DOMAIN_ERR, "parse-error-string", cons(arg1, cparse_error));
5174
5175 fun = cdr(assoc(makesym("h"), GET_CDR(arg1)));
5176 return (fun);
5177 }
5178
5179
5180 int
f_parse_error_expected_class(int arglist)5181 f_parse_error_expected_class(int arglist)
5182 {
5183 int arg1,
5184 fun;
5185
5186 arg1 = car(arglist);
5187 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5188 error(DOMAIN_ERR, "parse-error-expected-class",
5189 cons(arg1, cparse_error));
5190
5191 fun = cdr(assoc(makesym("g"), GET_CDR(arg1)));
5192 return (fun);
5193 }
5194
5195
5196 int
f_stream_error_stream(int arglist)5197 f_stream_error_stream(int arglist)
5198 {
5199 int arg1,
5200 fun;
5201
5202 arg1 = car(arglist);
5203 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5204 error(NOT_STREAM, "stream-error-stream", arg1);
5205
5206 fun = cdr(assoc(makesym("i"), GET_CDR(arg1)));
5207 return (fun);
5208 }
5209
5210 int
f_undefined_entity_name(int arglist)5211 f_undefined_entity_name(int arglist)
5212 {
5213 int arg1,
5214 fun;
5215
5216 arg1 = car(arglist);
5217 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5218 error(UNDEF_ENTITY, "undefined-entity-name", arg1);
5219
5220 fun = cdr(assoc(makesym("j"), GET_CDR(arg1)));
5221 return (fun);
5222 }
5223
5224 int
f_undefined_entity_namespace(int arglist)5225 f_undefined_entity_namespace(int arglist)
5226 {
5227 int arg1,
5228 fun;
5229
5230 arg1 = car(arglist);
5231 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5232 error(UNDEF_ENTITY, "undefined-entity-namespace", arg1);
5233
5234 fun = cdr(assoc(makesym("k"), GET_CDR(arg1)));
5235 return (fun);
5236 }
5237
5238 int
f_condition_continuable(int arglist)5239 f_condition_continuable(int arglist)
5240 {
5241 int arg1;
5242
5243 arg1 = car(arglist);
5244
5245 if (!subclassp(GET_AUX(arg1), cerror) && GET_AUX(arg1) != cerror)
5246 error(SERIOUS_ERR, "condition-continuable", arg1);
5247
5248 if (GET_OPT(arg1) == NOTCONT)
5249 return (NIL);
5250 else
5251 return (makestr(GET_NAME(arg1)));
5252 }
5253
5254 int
f_continue_condition(int arglist)5255 f_continue_condition(int arglist)
5256 {
5257 int arg1,
5258 arg2;
5259
5260 arg1 = car(arglist);
5261 arg2 = cadr(arglist);
5262
5263 if (GET_OPT(arg1) == CONTINUABLE)
5264 return (arg2);
5265 else
5266 return (arg1);
5267 }
5268