1 #include <stdio.h>
2 #include <string.h>
3 #include <ctype.h>
4 #include <stdlib.h>
5 #include <setjmp.h>
6 #include <math.h>
7 #include <time.h>
8 #include <sys/time.h>
9 #include "eisl.h"
10 #include "nana.h"
11 #include "fmt.h"
12 #include "str.h"
13 
14 #define TAGBODY_LEN_MAX 100
15 
16 void
initsyntax(void)17 initsyntax(void)
18 {
19     deffsubr("LAMBDA", f_lambda);
20     deffsubr("LABELS", f_labels);
21     deffsubr("FLET", f_flet);
22     deffsubr("LET", f_let);
23     deffsubr("LET*", f_letstar);
24     deffsubr("SETQ", f_setq);
25     deffsubr("SETF", f_setf);
26     deffsubr("SET-DYNAMIC", f_set_dynamic);
27     deffsubr("DEFCONSTANT", f_defconstant);
28     deffsubr("DEFUN", f_defun);
29     deffsubr("DEFMACRO", f_defmacro);
30     deffsubr("DEFGLOBAL", f_defglobal);
31     deffsubr("DEFDYNAMIC", f_defdynamic);
32     deffsubr("DYNAMIC", f_dynamic);
33     deffsubr("FUNCTION", f_function);
34     deffsubr("FUNCTION*", f_function_star);
35     deffsubr("SYMBOL-FUNCTION", f_symbol_function);
36     deffsubr("CLASS", f_class);
37     deffsubr("SYMBOL-CLASS", f_symbol_class);
38     deffsubr("AND", f_and);
39     deffsubr("OR", f_or);
40     deffsubr("IF", f_if);
41     deffsubr("COND", f_cond);
42     deffsubr("WHILE", f_while);
43     deffsubr("FOR", f_for);
44     deffsubr("BLOCK", f_block);
45     deffsubr("RETURN-FROM", f_return_from);
46     deffsubr("CASE", f_case);
47     deffsubr("CASE-USING", f_case_using);
48     deffsubr("CONVERT", f_convert);
49     deffsubr("PROGN", f_progn);
50     deffsubr("DEFCLASS", f_defclass);
51     deffsubr("DEFGENERIC", f_defgeneric);
52     deffsubr("DEFGENERIC*", f_defgeneric_star);
53     deffsubr("DEFMETHOD", f_defmethod);
54     deffsubr("DYNAMIC-LET", f_dynamic_let);
55     deffsubr("IGNORE-ERRORS", f_ignore_errors);
56     deffsubr("CATCH", f_catch);
57     deffsubr("THROW", f_throw);
58     deffsubr("TAGBODY", f_tagbody);
59     deffsubr("GO", f_go);
60     deffsubr("UNWIND-PROTECT", f_unwind_protect);
61     deffsubr("WITH-STANDARD-INPUT", f_with_standard_input);
62     deffsubr("WITH-STANDARD-OUTPUT", f_with_standard_output);
63     deffsubr("WITH-ERROR-OUTPUT", f_with_error_output);
64     deffsubr("WITH-HANDLER", f_with_handler);
65     deffsubr("WITH-OPEN-INPUT-FILE", f_with_open_input_file);
66     deffsubr("WITH-OPEN-OUTPUT-FILE", f_with_open_output_file);
67     deffsubr("WITH-OPEN-IO-FILE", f_with_open_io_file);
68     deffsubr("THE", f_the);
69     deffsubr("ASSURE", f_assure);
70     deffsubr("TIME", f_time);
71     deffsubr("TRACE", f_trace);
72     deffsubr("UNTRACE", f_untrace);
73     deffsubr("DEFMODULE", f_defmodule);
74 }
75 
76 // --FSUBR-----------
77 int
f_lambda(int arglist)78 f_lambda(int arglist)
79 {
80 
81     if (nullp(arglist))
82 	error(NOT_EXIST_ARG, "lambda", NIL);
83     if (duplicate_list_p(car(arglist)))
84 	error(IMPROPER_ARGS, "lambda", car(arglist));
85     if (improper_list_p(car(arglist)))
86 	error(IMPROPER_ARGS, "lambda", car(arglist));
87     if (illegal_lambda_p(car(arglist)))
88 	error(ILLEGAL_ARGS, "lambda", car(arglist));
89     if (!symbol_list_p(car(arglist)))
90 	error(OUT_OF_DOMAIN, "lambda", car(arglist));
91 
92 
93     return (makefunc("", arglist));
94 }
95 
96 int
f_labels(int arglist)97 f_labels(int arglist)
98 {
99     int             arg1,
100                     arg2,
101                     save,
102                     func,
103                     res,
104                     temp;
105 
106     arg1 = car(arglist);
107     arg2 = cdr(arglist);
108     if (improper_list_p(arglist))
109 	error(IMPROPER_ARGS, "labels", arglist);
110     if (nullp(arglist))
111 	error(NOT_EXIST_ARG, "labels", NIL);
112     if (!listp(arg1))
113 	error(IMPROPER_ARGS, "labels", arg1);
114     temp = arg1;
115     while (!nullp(temp)) {
116 	int             temparg1,
117 	                temparg2;
118 
119 	temparg1 = car(car(temp));
120 	temparg2 = cdr(car(temp));
121 	if (length(car(temp)) < 2)
122 	    error(IMPROPER_ARGS, "labels", car(temp));
123 	if (!symbolp(temparg1))
124 	    error(NOT_SYM, "labels", temparg1);
125 	if (STRING_REF(temparg1, 0) == ':'
126 	    || STRING_REF(temparg1, 0) == '&')
127 	    error(WRONG_ARGS, "labels", temparg1);
128 	if (duplicate_list_p(car(temparg2)))
129 	    error(IMPROPER_ARGS, "labels", car(temparg2));
130 	if (improper_list_p(car(temparg2)))
131 	    error(IMPROPER_ARGS, "labels", car(temparg2));
132 	if (illegal_lambda_p(car(temparg2)))
133 	    error(ILLEGAL_ARGS, "labels", car(temparg2));
134 	if (!symbol_list_p(car(temparg2)))
135 	    error(OUT_OF_DOMAIN, "labels", car(temparg2));
136 
137 	temp = cdr(temp);
138     }
139 
140 
141     save = ep;
142     func = NIL;
143     res = NIL;
144     while (arg1 != NIL) {
145 	int             sym,
146 	                val;
147 
148 	sym = caar(arg1);
149 	if (!symbolp(sym))
150 	    error(NOT_SYM, "labels", sym);
151 	addlexenv(sym, NIL);
152 	val = makefunc("", cdar(arg1));
153 	setlexenv(sym, val);
154 	func = cons(val, func);
155 	arg1 = cdr(arg1);
156     }
157     while (func != NIL) {
158 	SET_CDR(car(func), ep);
159 	func = cdr(func);
160     }
161     while (arg2 != NIL) {
162 	res = eval(car(arg2));
163 	arg2 = cdr(arg2);
164     }
165     ep = save;
166     return (res);
167 }
168 
169 int
f_flet(int arglist)170 f_flet(int arglist)
171 {
172     int             arg1,
173                     arg2,
174                     save,
175                     ep1,
176                     res,
177                     temp;
178 
179     arg1 = car(arglist);
180     arg2 = cdr(arglist);
181     if (improper_list_p(arglist))
182 	error(IMPROPER_ARGS, "flet", arglist);
183     if (nullp(arglist))
184 	error(NOT_EXIST_ARG, "flet", NIL);
185     if (!listp(arg1))
186 	error(IMPROPER_ARGS, "flet", arg1);
187     temp = arg1;
188     while (!nullp(temp)) {
189 	int             temparg1,
190 	                temparg2;
191 
192 	temparg1 = car(car(temp));
193 	temparg2 = cdr(car(temp));
194 	if (length(car(temp)) < 2)
195 	    error(IMPROPER_ARGS, "flet", car(temp));
196 	if (!symbolp(temparg1))
197 	    error(NOT_SYM, "flet", temparg1);
198 	if (STRING_REF(temparg1, 0) == ':'
199 	    || STRING_REF(temparg1, 0) == '&')
200 	    error(WRONG_ARGS, "flet", temparg1);
201 	if (duplicate_list_p(car(temparg2)))
202 	    error(IMPROPER_ARGS, "flet", car(temparg2));
203 	if (improper_list_p(car(temparg2)))
204 	    error(IMPROPER_ARGS, "flet", car(temparg2));
205 	if (illegal_lambda_p(car(temparg2)))
206 	    error(ILLEGAL_ARGS, "flet", car(temparg2));
207 	if (!symbol_list_p(car(temparg2)))
208 	    error(OUT_OF_DOMAIN, "flet", car(temparg2));
209 
210 	temp = cdr(temp);
211     }
212 
213     save = ep;
214     ep1 = ep;
215     res = NIL;
216     while (arg1 != NIL) {
217 	int             sym,
218 	                val;
219 
220 	sym = caar(arg1);
221 	if (!symbolp(sym))
222 	    error(NOT_SYM, "flet", sym);
223 	ep = save;
224 	val = makefunc("", cdar(arg1));
225 	ep = ep1;
226 	addlexenv(sym, val);
227 	ep1 = ep;
228 	arg1 = cdr(arg1);
229     }
230     while (arg2 != NIL) {
231 	res = eval(car(arg2));
232 	arg2 = cdr(arg2);
233     }
234     ep = save;
235     return (res);
236 }
237 
238 int
f_let(int arglist)239 f_let(int arglist)
240 {
241     int             arg1,
242                     arg2,
243                     save,
244                     res,
245                     temp;
246 
247     arg1 = car(arglist);
248     arg2 = cdr(arglist);
249     if (length(arglist) == 0)
250 	error(WRONG_ARGS, "let", arglist);
251     if (!listp(arg1))
252 	error(IMPROPER_ARGS, "let", arg1);
253     temp = arg1;
254     while (!nullp(temp)) {
255 	int             temparg1;
256 
257 	temparg1 = car(car(temp));
258 	if (improper_list_p(car(temp)))
259 	    error(IMPROPER_ARGS, "let", car(temp));
260 	if (length(car(temp)) != 2)
261 	    error(IMPROPER_ARGS, "let", car(temp));
262 	if (!symbolp(temparg1))
263 	    error(NOT_SYM, "let", temparg1);
264 	if (temparg1 == T || temparg1 == NIL || temparg1 == makesym("*PI*")
265 	    || temparg1 == makesym("*MOST-POSITIVE-FLOAT*")
266 	    || temparg1 == makesym("*MOST-NEGATIVE-FLOAT*"))
267 	    error(WRONG_ARGS, "let", arg1);
268 	if (STRING_REF(temparg1, 0) == ':'
269 	    || STRING_REF(temparg1, 0) == '&')
270 	    error(WRONG_ARGS, "let", arg1);
271 
272 	temp = cdr(temp);
273     }
274 
275     save = ep;
276     res = NIL;
277     while (arg1 != NIL) {
278 	int             ep1,
279 	                sym,
280 	                val;
281 
282 	ep1 = ep;
283 	ep = save;
284 	sym = caar(arg1);
285 	if (!symbolp(sym))
286 	    error(NOT_SYM, "let", sym);
287 	shelterpush(ep1);
288 	val = eval(cadar(arg1));
289 	shelterpop();
290 	ep = ep1;
291 	addlexenv(sym, val);
292 	arg1 = cdr(arg1);
293     }
294     while (arg2 != NIL) {
295 	shelterpush(arg2);
296 	res = eval(car(arg2));
297 	shelterpop();
298 	arg2 = cdr(arg2);
299     }
300     ep = save;
301     return (res);
302 }
303 
304 int
f_letstar(int arglist)305 f_letstar(int arglist)
306 {
307     int             arg1,
308                     arg2,
309                     save,
310                     res,
311                     temp;
312 
313     arg1 = car(arglist);
314     arg2 = cdr(arglist);
315     if (length(arglist) == 0)
316 	error(WRONG_ARGS, "let*", arglist);
317     if (!listp(arg1))
318 	error(IMPROPER_ARGS, "let*", arg1);
319     temp = arg1;
320     while (!nullp(temp)) {
321 	int             temparg1;
322 
323 	temparg1 = car(car(temp));
324 	if (improper_list_p(car(temp)))
325 	    error(IMPROPER_ARGS, "let*", car(temp));
326 	if (length(car(temp)) != 2)
327 	    error(IMPROPER_ARGS, "let*", car(temp));
328 	if (!symbolp(temparg1))
329 	    error(NOT_SYM, "let*", temparg1);
330 	if (temparg1 == T || temparg1 == NIL || temparg1 == makesym("*PI*")
331 	    || temparg1 == makesym("*MOST-POSITIVE-FLOAT*")
332 	    || temparg1 == makesym("*MOST-NEGATIVE-FLOAT*"))
333 	    error(WRONG_ARGS, "let*", arg1);
334 	if (STRING_REF(temparg1, 0) == ':'
335 	    || STRING_REF(temparg1, 0) == '&')
336 	    error(WRONG_ARGS, "let*", arg1);
337 
338 	temp = cdr(temp);
339     }
340 
341     save = ep;
342     res = NIL;
343     while (arg1 != NIL) {
344 	int             sym;
345 
346 	sym = caar(arg1);
347 	if (!symbolp(sym))
348 	    error(NOT_SYM, "let*", sym);
349 	addlexenv(sym, eval(cadar(arg1)));
350 	arg1 = cdr(arg1);
351     }
352     while (arg2 != NIL) {
353 	res = eval(car(arg2));
354 	arg2 = cdr(arg2);
355     }
356     ep = save;
357     return (res);
358 }
359 
360 int
f_dynamic_let(int arglist)361 f_dynamic_let(int arglist)
362 {
363     int             arg1,
364                     arg2,
365                     save,
366                     res,
367                     temp;
368 
369     arg1 = car(arglist);
370     arg2 = cdr(arglist);
371     if (length(arglist) == 0)
372 	error(WRONG_ARGS, "dynamic-let", arglist);
373     if (!listp(arg1))
374 	error(IMPROPER_ARGS, "dynamic-let", arg1);
375     temp = arg1;
376     while (!nullp(temp)) {
377 	int             temparg1;
378 
379 	temparg1 = car(car(temp));
380 	if (improper_list_p(car(temp)))
381 	    error(IMPROPER_ARGS, "dynamic-let", car(temp));
382 	if (length(car(temp)) != 2)
383 	    error(IMPROPER_ARGS, "dynamic-let", car(temp));
384 	if (!symbolp(temparg1))
385 	    error(NOT_SYM, "dynamic-let", temparg1);
386 	if (temparg1 == T || temparg1 == NIL || temparg1 == makesym("*PI*")
387 	    || temparg1 == makesym("*MOST-POSITIVE-FLOAT*")
388 	    || temparg1 == makesym("*MOST-NEGATIVE-FLOAT*"))
389 	    error(WRONG_ARGS, "dynamic-let", arg1);
390 	if (STRING_REF(temparg1, 0) == ':'
391 	    || STRING_REF(temparg1, 0) == '&')
392 	    error(WRONG_ARGS, "dynamic-let", arg1);
393 
394 	temp = cdr(temp);
395     }
396 
397     save = dp;
398     res = NIL;
399     while (arg1 != NIL) {
400 	int             dp1,
401 	                sym,
402 	                val;
403 
404 	dp1 = dp;
405 	dp = save;
406 	shelterpush(dp1);
407 	sym = caar(arg1);
408 	if (!symbolp(sym))
409 	    error(NOT_SYM, "dynamic-let", sym);
410 	val = eval(cadar(arg1));
411 	dp = dp1;
412 	shelterpop();
413 	adddynenv(sym, val);
414 	arg1 = cdr(arg1);
415     }
416     while (arg2 != NIL) {
417 	res = eval(car(arg2));
418 	arg2 = cdr(arg2);
419     }
420     dp = save;
421     return (res);
422 }
423 
424 
425 int
f_setf(int arglist)426 f_setf(int arglist)
427 {
428     int             arg1,
429                     arg2,
430                     newform,
431                     var,
432                     res;
433 
434     arg1 = car(arglist);
435     arg2 = cadr(arglist);
436     newform = NIL;
437     if (length(arglist) != 2)
438 	error(WRONG_ARGS, "setf", arglist);
439     if (arg1 == T || arg1 == NIL)
440 	error(CANT_MODIFY, "setf", arg1);
441     if (listp(arg1)
442 	&& eqlp(makeint(1),
443 		cdr(assoc(makesym("read"), GET_AUX(car(arg1))))))
444 	error(CANT_MODIFY, "setf", arg1);
445     if (improper_list_p(arglist))
446 	error(IMPROPER_ARGS, "setf", arglist);
447 
448     if (listp(arg1) && eqp(car(arg1), makesym("AREF"))) {
449 	newform = cons(makesym("SET-AREF"), cons(arg2, cdr(arg1)));
450     } else if (listp(arg1) && eqp(car(arg1), makesym("GAREF"))) {
451 	newform = cons(makesym("SET-GAREF"), cons(arg2, cdr(arg1)));
452     } else if (listp(arg1) && eqp(car(arg1), makesym("ELT"))) {
453 	newform = cons(makesym("SET-ELT"), cons(arg2, cdr(arg1)));
454     } else if (listp(arg1) && eqp(car(arg1), makesym("PROPERTY"))) {
455 	newform = cons(makesym("SET-PROPERTY"), cons(arg2, cdr(arg1)));
456     } else if (listp(arg1) && eqp(car(arg1), makesym("CAR"))) {
457 	newform = cons(makesym("SET-CAR"), cons(arg2, cdr(arg1)));
458     } else if (listp(arg1) && eqp(car(arg1), makesym("CDR"))) {
459 	newform = cons(makesym("SET-CDR"), cons(arg2, cdr(arg1)));
460     } else if (listp(arg1) && eqp(car(arg1), makesym("DYNAMIC"))) {
461 	if (improper_list_p(arg1))
462 	    error(IMPROPER_ARGS, "dynamic", arg1);
463 	if (length(arg1) != 2)
464 	    error(IMPROPER_ARGS, "dynamic", arg1);
465 	newform = cons(makesym("SET-DYNAMIC"), list2(cadr(arg1), arg2));
466     } else if (listp(arg1) && macrop(car(arg1))) {
467 	var = f_macroexpand_1(list1(arg1));
468 	return (f_setf(list2(var, arg2)));
469     }
470     // (setf (slot-value instance slot-name) value)
471     else if (listp(arg1) && eqp(car(arg1), makesym("SLOT-VALUE"))) {
472 	newform = cons(makesym("SET-SLOT-VALUE"), cons(arg2, cdr(arg1)));
473     }
474     // e.g. (setf (access-foo-a x) 100)
475     else if (listp(arg1) && length(arg1) == 2) {
476 	// a method returns it's variable name
477 	if (functionp(car(arg1)) || genericp(car(arg1))) {
478 	    var = eval(list2(car(arg1), NIL));
479 	} else
480 	    error(IMPROPER_ARGS, "setf", arg1);
481 
482 	newform =
483 	    cons(makesym("SET-SLOT-VALUE"),
484 		 cons(arg2,
485 		      list2(cadr(arg1), list2(makesym("QUOTE"), var))));
486     }
487     // e.g. when (setf (foo 1 2) 3) foo was define with (defgeneric (setf
488     // foo) (x y z))
489     else if (listp(arg1)) {
490 	// e.g. above case (foo 3 1 2)
491 	newform = cons(car(arg1), cons(arg2, cdr(arg1)));
492 	if (!genericp(car(arg1)))
493 	    error(ILLEGAL_FORM, "setf", arg1);
494     } else if (symbolp(arg1)) {
495 	newform = cons(makesym("SETQ"), list2(arg1, arg2));
496     } else
497 	error(IMPROPER_ARGS, "setf", arglist);
498 
499     shelterpush(newform);
500     res = eval(newform);
501     shelterpop();
502     return (res);
503 }
504 
505 
506 
507 int
f_set_dynamic(int arglist)508 f_set_dynamic(int arglist)
509 {
510     int             arg1,
511                     arg2;
512 
513     arg1 = car(arglist);
514     arg2 = eval(cadr(arglist));
515     if (nullp(arglist))
516 	error(IMPROPER_ARGS, "set-dynamic", arglist);
517     if (improper_list_p(arglist))
518 	error(IMPROPER_ARGS, "set-dynamic", arglist);
519     if (length(arglist) != 2)
520 	error(WRONG_ARGS, "set-dynamic", arglist);
521     if (!symbolp(arg1))
522 	error(NOT_SYM, "set-dynamic", arg1);
523     if (STRING_REF(arg1, 0) == ':' || STRING_REF(arg1, 0) == '&')
524 	error(WRONG_ARGS, "set-dynamic", arg1);
525 
526     if (finddyn(arg1) != FAILSE) {
527 	setdynenv(arg1, arg2);
528 	return (arg2);
529     } else
530 	error(UNDEF_VAR, "set-dynamic", arg1);
531 
532     return (arg2);
533 }
534 
535 
536 int
f_setq(int arglist)537 f_setq(int arglist)
538 {
539     int             arg1,
540                     arg2;
541 
542     arg1 = car(arglist);
543     arg2 = cadr(arglist);
544     if (length(arglist) != 2)
545 	error(WRONG_ARGS, "setq", arglist);
546     if (!symbolp(arg1))
547 	error(NOT_SYM, "setq", arg1);
548     if (GET_OPT(arg1) == CONSTN)
549 	error(CANT_MODIFY, "setq", arg1);
550     if (improper_list_p(arglist))
551 	error(IMPROPER_ARGS, "setq", arglist);
552 
553     arg2 = eval(arg2);
554     if (findenv(arg1) != FAILSE)
555 	setlexenv(arg1, arg2);
556     else if (GET_OPT(arg1) == GLOBAL)
557 	SET_CDR(arg1, arg2);
558     else
559 	error(UNDEF_VAR, "setq", arg1);
560 
561     return (arg2);
562 }
563 
564 int
f_defconstant(int arglist)565 f_defconstant(int arglist)
566 {
567     int             arg1,
568                     arg2;
569 
570     arg1 = car(arglist);
571     arg2 = cadr(arglist);
572     if (improper_list_p(arglist))
573 	error(IMPROPER_ARGS, "defconstant", arglist);
574     if (length(arglist) != 2)
575 	error(WRONG_ARGS, "defconstant", arglist);
576     if (!symbolp(arg1))
577 	error(NOT_SYM, "defconstant", arg1);
578     if (arg1 == T || arg1 == NIL || arg1 == makesym("*PI*") ||
579 	arg1 == makesym("*MOST-POSITIVE-FLOAT*")
580 	|| arg1 == makesym("*MOST-NEGATIVE-FLOAT*"))
581 	error(WRONG_ARGS, "defconstant", arg1);
582     if (STRING_REF(arg1, 0) == ':' || STRING_REF(arg1, 0) == '&')
583 	error(WRONG_ARGS, "defconstant", arg1);
584     if (!top_flag && !ignore_topchk)
585 	error(NOT_TOP_LEVEL, "defconstant", arglist);
586 
587     SET_CDR(arg1, eval(arg2));
588     SET_OPT(arg1, CONSTN);	// constant
589     return (arg1);
590 
591 }
592 
593 int
f_defun(int arglist)594 f_defun(int arglist)
595 {
596     int             arg1,
597                     arg2,
598                     val;
599 
600     arg1 = car(arglist);
601     arg2 = cdr(arglist);
602     if (length(arglist) < 2)
603 	error(WRONG_ARGS, "defun", arglist);
604     if (!symbolp(arg1))
605 	error(NOT_SYM, "defun", arg1);
606     if (IS_SUBR(GET_CAR(arg1)))
607 	error(CANT_MODIFY, "defun", arg1);
608     if (IS_FSUBR(GET_CAR(arg1)))
609 	error(CANT_MODIFY, "defun", arg1);
610     if (STRING_REF(arg1, 0) == ':' || STRING_REF(arg1, 0) == '&')
611 	error(WRONG_ARGS, "defun", arg1);
612     if (duplicate_list_p(car(arg2)))
613 	error(IMPROPER_ARGS, "defun", car(arg2));
614     if (improper_list_p(car(arg2)))
615 	error(IMPROPER_ARGS, "defun", car(arg2));
616     if (illegal_lambda_p(car(arg2)))
617 	error(ILLEGAL_ARGS, "defun", car(arg2));
618     if (!symbol_list_p(car(arg2)))
619 	error(OUT_OF_DOMAIN, "defun", car(arg2));
620 
621     val = makefunc(GET_NAME(arg1), arg2);
622     SET_CAR(arg1, val);
623     return (arg1);
624 }
625 
626 int
f_defmacro(int arglist)627 f_defmacro(int arglist)
628 {
629     int             arg1,
630                     arg2;
631 
632     arg1 = car(arglist);
633     arg2 = cdr(arglist);
634 
635     if (length(arglist) < 2)
636 	error(WRONG_ARGS, "defmacro", arglist);
637     if (!symbolp(arg1))
638 	error(NOT_SYM, "defmacro", arg1);
639     if (GET_OPT(arg1) == CONSTN)
640 	error(CANT_MODIFY, "defmacro", arg1);
641     if (IS_SUBR(GET_CAR(arg1)))
642 	error(CANT_MODIFY, "defmacro", arg1);
643     if (IS_FSUBR(GET_CAR(arg1)))
644 	error(CANT_MODIFY, "defmacro", arg1);
645     if (improper_list_p(arg2)) {
646 	error(IMPROPER_ARGS, "defmacro", arg2);
647     }
648     if (duplicate_list_p(car(arg2)))
649 	error(IMPROPER_ARGS, "defmacro", car(arg2));
650     if (improper_list_p(car(arg2))) {
651 	error(IMPROPER_ARGS, "defmacro", car(arg2));
652     }
653     if (illegal_lambda_p(car(arg2))) {
654 	error(ILLEGAL_ARGS, "defmacro", car(arg2));
655     }
656     if (!symbol_list_p(car(arg2))) {
657 	error(OUT_OF_DOMAIN, "defmacro", car(arg2));
658     }
659     if (!top_flag && !ignore_topchk)
660 	error(NOT_TOP_LEVEL, "defmacro", arglist);
661 
662 
663     bindmacro(GET_NAME(arg1), arg2);
664     return (arg1);
665 }
666 
667 int
f_defglobal(int arglist)668 f_defglobal(int arglist)
669 {
670     int             arg1,
671                     arg2;
672 
673     arg1 = car(arglist);
674     arg2 = cadr(arglist);
675     if (improper_list_p(arglist))
676 	error(IMPROPER_ARGS, "defglobal", arglist);
677     if (length(arglist) != 2)
678 	error(WRONG_ARGS, "defglobal", arglist);
679     if (!symbolp(arg1))
680 	error(NOT_SYM, "defglobal", arg1);
681     if (GET_OPT(arg1) == CONSTN)
682 	error(CANT_MODIFY, "defglobal", arg1);
683     if (STRING_REF(arg1, 0) == ':' || STRING_REF(arg1, 0) == '&')
684 	error(ILLEGAL_ARGS, "defglobal", arg1);
685 
686     arg2 = eval(arg2);
687     SET_CDR(arg1, arg2);
688     SET_OPT(arg1, GLOBAL);
689 
690     return (arg1);
691 }
692 
693 int
f_defdynamic(int arglist)694 f_defdynamic(int arglist)
695 {
696     int             arg1,
697                     arg2;
698 
699     arg1 = car(arglist);
700     arg2 = cadr(arglist);
701     if (improper_list_p(cdr(arglist)))
702 	error(IMPROPER_ARGS, "defdynamic", arglist);
703     if (length(arglist) != 2)
704 	error(WRONG_ARGS, "defdynamic", arglist);
705     if (!symbolp(arg1))
706 	error(NOT_SYM, "defdynamic", arg1);
707     if (STRING_REF(arg1, 0) == ':' || STRING_REF(arg1, 0) == '&')
708 	error(WRONG_ARGS, "defdynamic", arg1);
709 
710 
711     setdynenv(arg1, eval(arg2));
712     return (arg1);
713 }
714 
715 int
f_dynamic(int arglist)716 f_dynamic(int arglist)
717 {
718     int             arg1,
719                     res;
720 
721     arg1 = car(arglist);
722     if (improper_list_p(arglist))
723 	error(IMPROPER_ARGS, "dynamic", arglist);
724     if (length(arglist) != 1)
725 	error(WRONG_ARGS, "dynamic", arglist);
726     if (!symbolp(arg1))
727 	error(NOT_SYM, "dynamic", arg1);
728 
729     res = finddyn(arg1);
730     if (res == FAILSE)
731 	error(UNDEF_DYN, "dynamic", arg1);
732 
733     return (res);
734 }
735 
736 int
f_and(int arglist)737 f_and(int arglist)
738 {
739 
740     if (nullp(arglist))
741 	return (T);
742     else if (nullp(cdr(arglist)))
743 	return (eval(car(arglist)));
744     else if (eval(car(arglist)) != NIL)
745 	return (f_and(cdr(arglist)));
746     else
747 	return (NIL);
748 
749 }
750 
751 int
f_or(int arglist)752 f_or(int arglist)
753 {
754     int             temp;
755 
756     if (nullp(arglist))
757 	return (NIL);
758     else if (nullp(cdr(arglist)))
759 	return (eval(car(arglist)));
760     else if ((temp = eval(car(arglist))) == NIL)
761 	return (f_or(cdr(arglist)));
762     else
763 	return (temp);
764 
765     return (UNDEF);
766 }
767 
768 int
f_function(int arglist)769 f_function(int arglist)
770 {
771     int             arg1;
772 
773     arg1 = car(arglist);
774     if (length(arglist) != 1)
775 	error(WRONG_ARGS, "function", arglist);
776     if (improper_list_p(arglist))
777 	error(ILLEGAL_ARGS, "function", arglist);
778 
779     if (symbolp(arg1)) {
780 	int             res;
781 
782 	res = findenv(arg1);
783 	if (IS_FUNC(res))
784 	    return (res);
785 	else if (GET_CAR(arg1) != NIL)
786 	    return (GET_CAR(arg1));
787 	else
788 	    error(UNDEF_FUN, "function", arg1);
789     } else if (listp(arg1) && eqp(car(arg1), makesym("lambda")))
790 	return (eval(arg1));
791     else
792 	error(NOT_FUNC, "function", arg1);
793     return (UNDEF);
794 }
795 
796 // function* diffrence of function is that return nil
797 // defclass uses this function*
798 int
f_function_star(int arglist)799 f_function_star(int arglist)
800 {
801     int             arg1;
802 
803     arg1 = car(arglist);
804     if (length(arglist) != 1)
805 	error(WRONG_ARGS, "function*", arglist);
806     if (improper_list_p(arglist))
807 	error(ILLEGAL_ARGS, "function*", arglist);
808 
809     if (symbolp(arg1)) {
810 	int             res;
811 
812 	res = findenv(arg1);
813 	if (IS_FUNC(res))
814 	    return (res);
815 	else if (GET_CAR(arg1) != NIL)
816 	    return (GET_CAR(arg1));
817 	else
818 	    return (NIL);
819     } else if (listp(arg1) && eqp(car(arg1), makesym("lambda")))
820 	return (eval(arg1));
821     else
822 	return (NIL);
823     return (UNDEF);
824 }
825 
826 int
f_symbol_function(int arglist)827 f_symbol_function(int arglist)
828 {
829     int             arg1;
830 
831     arg1 = car(arglist);
832     if (length(arglist) != 1)
833 	error(WRONG_ARGS, "symbol-function", arglist);
834 
835     if (symbolp(arg1)) {
836 	int             sym,
837 	                res;
838 
839 	sym = findenv(arg1);
840 	if (sym == FAILSE && GET_CDR(arg1) != NIL)
841 	    sym = GET_CDR(arg1);
842 
843 	if (!symbolp(sym))
844 	    error(UNDEF_FUN, "symbol-function", arg1);
845 
846 	res = findenv(sym);
847 	if (IS_FUNC(res))
848 	    return (res);
849 	else if (GET_CAR(sym) != NIL)
850 	    return (GET_CAR(sym));
851 	else
852 	    error(UNDEF_FUN, "symbol-function", sym);
853     } else
854 	error(ILLEGAL_ARGS, "symbol-function", arg1);
855     return (UNDEF);
856 }
857 
858 int
f_class(int arglist)859 f_class(int arglist)
860 {
861     int             arg1;
862 
863     arg1 = car(arglist);
864     if (length(arglist) != 1)
865 	error(WRONG_ARGS, "class", arglist);
866     if (!symbolp(arg1))
867 	error(NOT_SYM, "class", arglist);
868     if (GET_AUX(arg1) == NIL)
869 	error(UNDEF_CLASS, "class", arg1);
870     if (GET_AUX(arg1) == csymbol && GET_OPT(arg1) != SYSTEM)
871 	error(UNDEF_CLASS, "class", arg1);
872 
873     return (GET_AUX(arg1));
874 }
875 
876 int
f_symbol_class(int arglist)877 f_symbol_class(int arglist)
878 {
879     int             arg1;
880 
881     arg1 = car(arglist);
882     if (length(arglist) != 1)
883 	error(WRONG_ARGS, "symbol-class", arglist);
884 
885     if (symbolp(arg1)) {
886 	int             sym;
887 
888 	sym = findenv(arg1);
889 	if (sym == FAILSE && GET_CDR(arg1) != NIL)
890 	    sym = GET_CDR(arg1);
891 
892 	if (!symbolp(sym))
893 	    error(UNDEF_CLASS, "symbol-class", arg1);
894 
895 	if (GET_AUX(sym) == NIL)
896 	    error(UNDEF_CLASS, "symbol-class", sym);
897 	if (GET_AUX(sym) == csymbol && GET_OPT(sym) != SYSTEM)
898 	    error(UNDEF_CLASS, "class", sym);
899 
900 	return (GET_AUX(sym));
901     } else {
902 	error(ILLEGAL_ARGS, "symbol-class", arg1);
903 	return (UNDEF);
904     }
905 }
906 
907 
908 
909 int
f_if(int arglist)910 f_if(int arglist)
911 {
912     int             arg1,
913                     arg2,
914                     arg3,
915                     n;
916 
917     arg1 = car(arglist);
918     arg2 = cadr(arglist);
919     if ((n = length(arglist)) < 2 || n > 3)
920 	error(WRONG_ARGS, "if", arglist);
921     if (improper_list_p(arglist))
922 	error(WRONG_ARGS, "if", arglist);
923 
924     if (length(arglist) == 3)
925 	arg3 = car(cdr(cdr(arglist)));
926     else
927 	arg3 = NIL;
928 
929     if (!(nullp(eval(arg1))))
930 	return (eval(arg2));
931     else {
932 	return (eval(arg3));
933     }
934 }
935 
936 int
f_cond(int arglist)937 f_cond(int arglist)
938 {
939     int             arg1,
940                     arg2,
941                     arg3;
942 
943     if (nullp(arglist))
944 	return (NIL);
945 
946     arg1 = car(arglist);
947     arg2 = car(arg1);
948     arg3 = cdr(arg1);
949     if (nullp(arg1))
950 	error(IMPROPER_ARGS, "cond", arglist);
951     if (improper_list_p(arg1))
952 	error(IMPROPER_ARGS, "cond", arg1);
953 
954 
955     if (length(arg1) == 1 && atomp(arg2) && !nullp(eval(arg2)))
956 	return (arg2);
957     else if (!nullp(eval(arg2)))
958 	return (f_progn(arg3));
959     else
960 	return (f_cond(cdr(arglist)));
961 }
962 
963 int
f_while(int arglist)964 f_while(int arglist)
965 {
966     int             arg1,
967                     arg2;
968 
969     arg1 = car(arglist);
970     arg2 = cdr(arglist);
971     while (eval(arg1) != NIL) {
972 	f_progn(arg2);
973     }
974     return (NIL);
975 }
976 
977 int
f_for(int arglist)978 f_for(int arglist)
979 {
980     int             arg1,
981                     arg2,
982                     arg3,
983                     iter,
984                     temp,
985                     save,
986                     res,
987                     temparg2;
988 
989     arg1 = car(arglist);
990     arg2 = cadr(arglist);
991     arg3 = cddr(arglist);
992     if (length(arglist) < 2)
993 	error(WRONG_ARGS, "for", arglist);
994     if (!listp(arg1))
995 	error(NOT_LIST, "for", arg1);
996     if (!listp(arg2))
997 	error(NOT_LIST, "for", arg2);
998     if (nullp(arg2))
999 	error(IMPROPER_ARGS, "for", arg2);
1000 
1001     temp = arg1;
1002     temparg2 = NIL;
1003     while (!nullp(temp)) {
1004 	int             temp1,
1005 	                temparg1;
1006 
1007 	temp1 = car(temp);
1008 	if (!listp(temp1))
1009 	    error(IMPROPER_ARGS, "for", temp1);
1010 	temparg1 = car(temp1);
1011 
1012 	if (!symbolp(temparg1))
1013 	    error(NOT_SYM, "for", temparg1);
1014 	if (STRING_REF(temparg1, 0) == ':'
1015 	    || STRING_REF(temparg1, 0) == '&')
1016 	    error(WRONG_ARGS, "for", arg1);
1017 	if (temparg1 == T || temparg1 == NIL || temparg1 == makesym("*PI*")
1018 	    || temparg1 == makesym("*MOST-POSITIVE-FLOAT*")
1019 	    || temparg1 == makesym("*MOST-NEGATIVE-FLOAT*"))
1020 	    error(WRONG_ARGS, "for", temparg1);
1021 	if (length(temp1) != 2 && length(temp1) != 3)
1022 	    error(IMPROPER_ARGS, "for", temp1);
1023 	if (member(temparg1, temparg2))
1024 	    error(IMPROPER_ARGS, "for", temparg1);
1025 
1026 	temparg2 = cons(temparg1, temparg2);
1027 	temp = cdr(temp);
1028     }
1029 
1030     save = ep;
1031 
1032     iter = arg1;
1033     // initilize local variable
1034     while (iter != NIL) {
1035 	addlexenv(caar(iter), eval(cadar(iter)));
1036 	iter = cdr(iter);
1037     }
1038     // check condition of end
1039     while (eval(car(arg2)) == NIL) {
1040 	int             save1;
1041 
1042 	save1 = ep;
1043 	shelterpush(arg3);
1044 	f_progn(arg3);		// do body
1045 	shelterpop();
1046 	ep = save1;
1047 	iter = arg1;		// update local variable
1048 	temp = NIL;
1049 	while (iter != NIL) {
1050 	    if (!nullp(caddar(iter))) {	// update part is not null
1051 		shelterpush(iter);
1052 		shelterpush(temp);
1053 		temp = cons(cons(caar(iter), eval(caddar(iter))), temp);
1054 		shelterpop();
1055 		shelterpop();
1056 	    }
1057 	    iter = cdr(iter);
1058 	}
1059 	while (temp != NIL) {
1060 	    setlexenv(caar(temp), cdar(temp));
1061 	    temp = cdr(temp);
1062 	}
1063     }
1064     res = f_progn(cdr(arg2));
1065     ep = save;
1066     return (res);
1067 }
1068 
1069 int
f_block(int arglist)1070 f_block(int arglist)
1071 {
1072     int             arg1,
1073                     arg2,
1074                     tag,
1075                     ret,
1076                     res;
1077 
1078     arg1 = car(arglist);
1079     arg2 = cdr(arglist);
1080     if (nullp(arglist))
1081 	error(WRONG_ARGS, "block", arglist);
1082     if (improper_list_p(arglist) && nullp(arg1))
1083 	error(WRONG_ARGS, "block", arglist);
1084     if (improper_list_p(arglist))
1085 	error(IMPROPER_ARGS, "block", arglist);
1086     if (!symbolp(arg1))
1087 	error(NOT_SYM, "block", arg1);
1088 
1089     tag = arg1;
1090 
1091     if (block_pt >= 50)
1092 	error(CTRL_OVERF, "block buffer over fllow", NIL);
1093 
1094 
1095     block_env[block_pt][0] = ep;	// save environment
1096     block_env[block_pt][1] = tag;	// save tag symbol
1097     block_tag_check[block_pt] = find_return_from_p(macroexpand_all(arg2));	// save
1098     // flag.
1099     // if
1100     // exist
1101     // return-from
1102     // 1 else
1103     // -1
1104     block_pt++;
1105     ret = setjmp(block_buf[block_pt - 1]);
1106 
1107 
1108     if (ret == 0) {
1109 	res = f_progn(arg2);
1110 	block_pt--;
1111 	return (res);
1112     } else if (ret == 1) {
1113 	if (unwind_pt > 0) {
1114 	    unwind_pt--;
1115 	    while (unwind_pt >= 0) {
1116 		apply(unwind_buf[unwind_pt], NIL);
1117 		unwind_pt--;
1118 	    }
1119 	    unwind_pt = 0;
1120 	}
1121 	res = block_arg;
1122 	return (res);
1123     }
1124     return (UNDEF);
1125 }
1126 
1127 int
find_return_from_p(int x)1128 find_return_from_p(int x)
1129 {
1130     if (nullp(x))
1131 	return (-1);
1132     else if (symbolp(x) && eqp(x, makesym("RETURN-FROM")))
1133 	return (1);
1134     else if (atomp(x))
1135 	return (-1);
1136     else if (find_return_from_p(car(x)) == 1
1137 	     || find_return_from_p(cdr(x)) == 1)
1138 	return (1);
1139     else
1140 	return (-1);
1141 
1142 }
1143 
1144 int
f_return_from(int arglist)1145 f_return_from(int arglist)
1146 {
1147     int             arg1,
1148                     arg2,
1149                     tag;
1150 
1151     arg1 = car(arglist);
1152     arg2 = cdr(arglist);
1153     if (length(arglist) != 2)
1154 	error(WRONG_ARGS, "return-from", arglist);
1155     if (!symbolp(arg1))
1156 	error(NOT_SYM, "return-from", arg1);
1157     tag = arg1;
1158     block_pt--;
1159     if (block_env[block_pt][1] != tag)
1160 	error(UNDEF_TAG, "return-from tag not exist", tag);
1161     if (block_tag_check[block_pt] == -1)
1162 	error(UNDEF_TAG, "return-from tag not exist", tag);
1163     block_arg = f_progn(arg2);
1164     ep = block_env[block_pt][0];	// restore environment
1165     longjmp(block_buf[block_pt], 1);
1166 }
1167 
1168 
1169 
1170 int
f_catch(int arglist)1171 f_catch(int arglist)
1172 {
1173     int             arg1,
1174                     arg2,
1175                     i,
1176                     tag,
1177                     ret,
1178                     res,
1179                     save;
1180 
1181     save = sp;
1182     arg1 = car(arglist);	// tag
1183     arg2 = cdr(arglist);	// body
1184     if (nullp(arglist))
1185 	error(WRONG_ARGS, "catch", arglist);
1186     if (arg1 == makesym("catch"))
1187 	error(WRONG_ARGS, "catch", arglist);
1188     if (nullp(arg1))
1189 	error(WRONG_ARGS, "catch", arglist);
1190     if (improper_list_p(arglist))
1191 	error(IMPROPER_ARGS, "catch", arglist);
1192     tag = eval(arg1);		// tag symbol
1193     if (!symbolp(tag))
1194 	error(IMPROPER_ARGS, "catch", tag);
1195 
1196 
1197     if (!member(tag, catch_symbols))
1198 	catch_symbols = cons(tag, catch_symbols);
1199     if (GET_OPT(tag) == 0) {
1200 	catch_pt++;		// opt is 1~5, when 0 symbol is not tag
1201 	SET_OPT(tag, catch_pt);
1202 	if (catch_pt > CTRLSTK)
1203 	    error(CTRL_OVERF, "catch tag count", NIL);
1204     }
1205     i = GET_PROP(tag);
1206     SET_PROP(tag, GET_PROP(tag) + 1);	// nest level +1
1207     if (GET_PROP(tag) > CTRLSTK)
1208 	error(CTRL_OVERF, "catch tag nest", tag);
1209 
1210     catch_env[GET_OPT(tag) - 1][i] = ep;	// save environment
1211     ret = setjmp(catch_buf[GET_OPT(tag) - 1][i]);
1212 
1213 
1214     if (ret == 0) {
1215 	res = f_progn(arg2);
1216 	SET_PROP(tag, GET_PROP(tag) - 1);	// nest level -1
1217 	return (res);
1218     } else if (ret == 1) {
1219 	if (unwind_pt > 0) {
1220 	    unwind_pt--;
1221 	    while (unwind_pt >= 0) {
1222 		apply(unwind_buf[unwind_pt], NIL);
1223 		unwind_pt--;
1224 	    }
1225 	    unwind_pt = 0;
1226 	}
1227 	res = catch_arg;
1228 	catch_arg = NIL;
1229 	sp = save;		// restore stack pointer. longjump destroy
1230 				//
1231 	//
1232 	//
1233 	//
1234 	//
1235 	//
1236 	//
1237 	//
1238 	//
1239 	//
1240 	// sp
1241 	return (res);
1242     }
1243     return (UNDEF);
1244 }
1245 
1246 
1247 int
f_throw(int arglist)1248 f_throw(int arglist)
1249 {
1250     int             arg1,
1251                     arg2,
1252                     tag,
1253                     i;
1254 
1255     arg1 = car(arglist);
1256     arg2 = cdr(arglist);
1257     tag = eval(arg1);
1258 
1259     if (!symbolp(tag))
1260 	error(IMPROPER_ARGS, "throw", tag);
1261     if (GET_OPT(tag) == 0)	// tag opt has 1~4
1262 	error(UNDEF_TAG, "throw", tag);
1263     if (GET_PROP(tag) == 0)
1264 	error(CTRL_OVERF, "throw", NIL);
1265 
1266     catch_arg = f_progn(arg2);
1267     i = GET_PROP(tag);
1268     SET_PROP(tag, i - 1);
1269     ep = catch_env[GET_OPT(tag) - 1][i - 1];	// restore environment
1270     longjmp(catch_buf[GET_OPT(tag) - 1][i - 1], 1);
1271 }
1272 
1273 int
f_tagbody(int arglist)1274 f_tagbody(int arglist)
1275 {
1276     int             prog[TAGBODY_LEN_MAX],
1277                     tb_line,
1278                     end,
1279                     i;
1280 
1281     if (improper_list_p(arglist))
1282 	error(IMPROPER_ARGS, "tagbody", arglist);
1283 
1284     end = 0;
1285     while (!nullp(arglist)) {
1286 	prog[end] = car(arglist);
1287 	arglist = cdr(arglist);
1288 	end++;
1289     }
1290 
1291     tb_line = 0;
1292     while (tb_line < end) {
1293 	if (symbolp(prog[tb_line]))
1294 	    tb_line++;
1295 	else {
1296 	    tagbody_tag = NIL;
1297 	    eval(prog[tb_line]);
1298 	    tb_line++;
1299 	    // when go was evaled
1300 	    if (tagbody_tag != NIL) {
1301 		for (i = 0; i < end; i++) {
1302 		    if (tagbody_tag == prog[i]) {
1303 			tagbody_tag = NIL;
1304 			tb_line = i;
1305 			break;
1306 		    }
1307 		}
1308 		if (tagbody_tag != NIL) {
1309 		    error(UNDEF_TAG, "tagbody", tagbody_tag);
1310 		} else {
1311 		    continue;
1312 		}
1313 	    }
1314 	}
1315     }
1316 
1317     return (NIL);
1318 }
1319 
1320 int
f_go(int arglist)1321 f_go(int arglist)
1322 {
1323     int             arg1;
1324 
1325     arg1 = car(arglist);
1326     if (!symbolp(arg1))
1327 	error(NOT_SYM, "go", arg1);
1328     if (improper_list_p(arglist))
1329 	error(IMPROPER_ARGS, "go", arglist);
1330     if (length(arglist) != 1)
1331 	error(WRONG_ARGS, "go", arglist);
1332 
1333     tagbody_tag = arg1;
1334     return (T);
1335 }
1336 
1337 
1338 int
f_unwind_protect(int arglist)1339 f_unwind_protect(int arglist)
1340 {
1341     int             arg1,
1342                     args,
1343                     res;
1344 
1345     arg1 = car(arglist);
1346     args = cdr(arglist);
1347     if (nullp(arglist))
1348 	error(WRONG_ARGS, "unwind-protect", arglist);
1349     if (improper_list_p(arglist))
1350 	error(WRONG_ARGS, "unwind-protect", arglist);
1351 
1352     unwind_buf[unwind_pt] = makefunc("", cons(NIL, args));	// make
1353     // thunk
1354     unwind_pt++;
1355     res = eval(arg1);
1356     if (unwind_pt > 0) {
1357 	unwind_pt--;
1358 	while (unwind_pt >= 0) {
1359 	    apply(unwind_buf[unwind_pt], NIL);
1360 	    unwind_pt--;
1361 	}
1362 	unwind_pt = 0;
1363     }
1364     return (res);
1365 }
1366 
1367 
1368 int
f_case(int arglist)1369 f_case(int arglist)
1370 {
1371     int             arg1,
1372                     arg2,
1373                     key,
1374                     res,
1375                     temp;
1376 
1377     arg1 = car(arglist);
1378     arg2 = cdr(arglist);
1379     if (nullp(car(arg2)))
1380 	error(IMPROPER_ARGS, "case", arg2);
1381     temp = arg2;
1382     while (!nullp(temp)) {
1383 	int             temparg1;
1384 
1385 	temparg1 = car(temp);
1386 	if (!listp(temparg1))
1387 	    error(WRONG_ARGS, "case", temparg1);
1388 	if (car(temparg1) == T && length(temp) != 1)
1389 	    error(IMPROPER_ARGS, "case", temparg1);
1390 	if (atomp(car(temparg1)) && car(temparg1) != T)
1391 	    error(IMPROPER_ARGS, "case", temparg1);
1392 	temp = cdr(temp);
1393     }
1394 
1395     res = NIL;
1396     key = eval(arg1);
1397     while (arg2 != NIL) {
1398 	if (caar(arg2) == T) {
1399 	    res = f_progn(cdar(arg2));
1400 	    break;
1401 	} else if (member(key, caar(arg2)) != NIL) {
1402 	    res = f_progn(cdar(arg2));
1403 	    break;
1404 	} else {
1405 	    arg2 = cdr(arg2);
1406 	}
1407     }
1408     return (res);
1409 }
1410 
1411 int
f_case_using(int arglist)1412 f_case_using(int arglist)
1413 {
1414     int             arg1,
1415                     arg2,
1416                     arg3,
1417                     key,
1418                     fun,
1419                     res,
1420                     temp;
1421 
1422     arg1 = car(arglist);
1423     arg2 = cadr(arglist);
1424     arg3 = cddr(arglist);
1425     if (nullp(car(arg3)))
1426 	error(IMPROPER_ARGS, "case-using", arg3);
1427     temp = arg3;
1428     while (!nullp(temp)) {
1429 	int             temparg1;
1430 
1431 	temparg1 = car(temp);
1432 	if (!listp(temparg1))
1433 	    error(WRONG_ARGS, "case-using", temparg1);
1434 	if (car(temparg1) == T && length(temp) != 1)
1435 	    error(IMPROPER_ARGS, "case-using", temparg1);
1436 	if (atomp(car(temparg1)) && car(temparg1) != T)
1437 	    error(IMPROPER_ARGS, "case-using", temparg1);
1438 	temp = cdr(temp);
1439     }
1440 
1441     res = NIL;
1442     key = eval(arg2);
1443     fun = eval(arg1);
1444     while (arg3 != NIL) {
1445 	if (caar(arg3) == T) {
1446 	    res = f_progn(cdar(arg3));
1447 	    break;
1448 	} else if (member1(key, caar(arg3), fun) != NIL) {
1449 	    res = f_progn(cdar(arg3));
1450 	    break;
1451 	} else {
1452 	    arg3 = cdr(arg3);
1453 	}
1454     }
1455     return (res);
1456 }
1457 
1458 
1459 int
f_progn(int arglist)1460 f_progn(int arglist)
1461 {
1462     int             res;
1463 
1464     if (improper_list_p(arglist))
1465 	error(IMPROPER_ARGS, "progn", arglist);
1466     res = NIL;
1467     while (arglist != NIL) {
1468 	res = eval(car(arglist));
1469 	arglist = cdr(arglist);
1470     }
1471     return (res);
1472 }
1473 
1474 int
f_defclass(int arglist)1475 f_defclass(int arglist)
1476 {
1477     int             arg1,
1478                     arg2,
1479                     arg3,
1480                     arg4,
1481                     sc,
1482                     var,
1483                     val,
1484                     cl,
1485                     form,
1486                     initargs,
1487                     abstractp,
1488                     metaclass,
1489                     save;
1490 
1491     arg1 = car(arglist);	// class-name
1492     arg2 = cadr(arglist);	// super-class
1493     arg3 = caddr(arglist);	// slot-spec
1494     arg4 = cdddr(arglist);	// class-opt
1495 
1496     if (!symbolp(arg1))
1497 	error(NOT_SYM, "defclass", arg1);
1498     if (GET_OPT(arg1) == SYSTEM)
1499 	error(CANT_REDEFINE, "defclass", arg1);
1500     if (GET_OPT(arg1) == CONSTN)
1501 	error(CANT_MODIFY, "defclass", arg1);
1502     if (IS_FSUBR(GET_CAR(arg1)))
1503 	error(CANT_MODIFY, "defclass", arg1);
1504     if ((STRING_REF(arg1, 0) == '&') || (STRING_REF(arg1, 0) == ':'))
1505 	error(CANT_MODIFY, "defclass", arg1);
1506     if (!listp(arg2))
1507 	error(NOT_LIST, "defclass", arg2);
1508     if (has_same_p(arg2))
1509 	error(IMPROPER_ARGS, "defclass", arg2);
1510     if (has_sys_class_p(arg2))
1511 	error(IMPROPER_ARGS, "defclass", arg2);
1512     if (not_exist_class_p(arg2))
1513 	error(UNDEF_CLASS, "defclass", arg2);
1514     if (has_common_p(arg2))
1515 	error(HAS_COMMON_CLASS, "defclass", arg2);
1516     if (!listp(arg3))
1517 	error(NOT_LIST, "defclass", arg3);
1518     if (!top_flag && !ignore_topchk)
1519 	error(NOT_TOP_LEVEL, "defclass", arglist);
1520 
1521     sc = arg2;
1522     if (subclassp(GET_AUX(arg1), cobject))
1523 	redef_flag = true;	// flag for check redefinition of class
1524 
1525     var = NIL;
1526     val = UNDEF;
1527     initargs = NIL;
1528     save = ignore_topchk;
1529     ignore_topchk = 1;		// ignore toplevel check for defgeneric
1530     // defmethod
1531     SET_AUX(arg1, USER);	// temporary set USER to avoid undef
1532     // entity error of defmethod
1533     // finaly set-aux formal class
1534     while (!nullp(arg3)) {
1535 	int             sym,
1536 	                ls,
1537 	                reader,
1538 	                writer,
1539 	                accessor,
1540 	                boundp,
1541 	                initform,
1542 	                initarg,
1543 	                initform_flag,
1544 	                initarg_flag;
1545 
1546 	reader = writer = accessor = boundp = initform = initarg = NIL;
1547 	initform_flag = initarg_flag = 0;
1548 	if (!listp(car(arg3)))
1549 	    arg3 = list1(arg3);	// if form=(a :reader a-read) => ((a
1550 	// :reader a-read))
1551 	sym = caar(arg3);
1552 	if ((STRING_REF(sym, 0) == '&') || (STRING_REF(sym, 0) == ':'))
1553 	    error(IMPROPER_FORM, "defclass", sym);
1554 	ls = cdar(arg3);
1555 	if (!listp(car(arg3)))
1556 	    error(ILLEGAL_FORM, "defclass", arg3);
1557 
1558 	while (!nullp(ls)) {
1559 
1560 	    if (eqp(car(ls), makesym(":READER"))) {
1561 		reader = cadr(ls);
1562 		if (length(ls) < 2) {
1563 		    error(ILLEGAL_FORM, "defclass", arg3);
1564 		}
1565 		if (symbolp(reader) && STRING_REF(reader, 0) == ':') {
1566 		    error(IMPROPER_FORM, "defclass", arg3);
1567 		}
1568 		// (if (not (generic-function-p (function* name)))
1569 		// (defgeneric name (x)))
1570 		// (defmethod name ((x arg1))
1571 		// (let ((y (slot-value x 'var))) (if (dummyp y) (cerror
1572 		// "undefined" "reader")) y))
1573 		// (set-property 1 'reader 'read))
1574 		form = list3(makesym("IF"),
1575 			     list2(makesym("NOT"),
1576 				   list2(makesym("GENERIC-FUNCTION-P"),
1577 					 list2(makesym("FUNCTION*"),
1578 					       reader))),
1579 			     list3(makesym("DEFGENERIC"), reader,
1580 				   list1(makesym("x"))));
1581 		eval(form);
1582 		form =
1583 		    list4(makesym("DEFMETHOD"), reader,
1584 			  list1(list2(makesym("x"), arg1)),
1585 			  list4(makesym("LET"),
1586 				list1(list2
1587 				      (makesym("y"),
1588 				       list3(makesym("SLOT-VALUE"),
1589 					     makesym("x"),
1590 					     list2(makesym("QUOTE"),
1591 						   sym)))),
1592 				list3(makesym("IF"),
1593 				      list2(makesym("EISL-DUMMYP"),
1594 					    makesym("y")),
1595 				      list3(makesym("CERROR"),
1596 					    makestr("undefined"),
1597 					    makestr("reader"))),
1598 				makesym("y")));
1599 
1600 		eval(form);
1601 		form = list4(makesym("SET-PROPERTY"),
1602 			     makeint(1),
1603 			     list2(makesym("QUOTE"), reader),
1604 			     list2(makesym("QUOTE"), makesym("READ")));
1605 		eval(form);
1606 	    } else if (eqp(car(ls), makesym(":WRITER"))) {
1607 		writer = cadr(ls);
1608 		if (length(ls) < 2) {
1609 		    error(ILLEGAL_FORM, "defclass", arg3);
1610 		}
1611 		if (symbolp(writer) && STRING_REF(writer, 0) == ':') {
1612 		    error(IMPROPER_FORM, "defclass", arg3);
1613 		}
1614 		// (if (not (generic-function-p (function* name)))
1615 		// (defgeneric name (x y)))
1616 		// (defmethod name (x (y arg1))
1617 		// (setf (slot-value y 'var) x))
1618 		form = list3(makesym("IF"),
1619 			     list2(makesym("NOT"),
1620 				   list2(makesym("GENERIC-FUNCTION-P"),
1621 					 list2(makesym("FUNCTION*"),
1622 					       writer))),
1623 			     list3(makesym("DEFGENERIC"), writer,
1624 				   list2(makesym("x"),
1625 					 list2(makesym("y"), arg1))));
1626 		eval(form);
1627 		form =
1628 		    list4(makesym("DEFMETHOD"), writer,
1629 			  list2(makesym("x"), list2(makesym("y"), arg1)),
1630 			  list3(makesym("SETF"),
1631 				list3(makesym("SLOT-VALUE"), makesym("y"),
1632 				      list2(makesym("QUOTE"), sym)),
1633 				makesym("x")));
1634 		eval(form);
1635 	    } else if (eqp(car(ls), makesym(":ACCESSOR"))) {
1636 		accessor = cadr(ls);
1637 		if (length(ls) < 2) {
1638 		    error(ILLEGAL_FORM, "defclass", arg3);
1639 		}
1640 		if (symbolp(accessor) && STRING_REF(accessor, 0) == ':') {
1641 		    error(IMPROPER_FORM, "defclass", arg3);
1642 		}
1643 		// (if (not (generic-function-p (function* name)))
1644 		// (defgeneric name (x)))
1645 		// (defmethod name ((x arg1))
1646 		// (let ((y (slot-value x 'var))) (if (dummyp y) (error
1647 		// "undefined" "accessor") y)))
1648 		// (defmethod name ((x <null>)) for setf syntax
1649 		// 'var)
1650 		form = list3(makesym("IF"),
1651 			     list2(makesym("NOT"),
1652 				   list2(makesym("GENERIC-FUNCTION-P"),
1653 					 list2(makesym("FUNCTION*"),
1654 					       accessor))),
1655 			     list3(makesym("DEFGENERIC"), accessor,
1656 				   list1(makesym("x"))));
1657 		eval(form);
1658 		form =
1659 		    list4(makesym("DEFMETHOD"), accessor,
1660 			  list1(list2(makesym("x"), arg1)),
1661 			  list4(makesym("LET"),
1662 				list1(list2
1663 				      (makesym("y"),
1664 				       list3(makesym("SLOT-VALUE"),
1665 					     makesym("x"),
1666 					     list2(makesym("QUOTE"),
1667 						   sym)))),
1668 				list3(makesym("IF"),
1669 				      list2(makesym("EISL-DUMMYP"),
1670 					    makesym("y")),
1671 				      list3(makesym("CERROR"),
1672 					    makestr("undefined"),
1673 					    makestr("accessor"))),
1674 				makesym("y")));
1675 
1676 		eval(form);
1677 		form =
1678 		    list4(makesym("DEFMETHOD"), accessor,
1679 			  list1(list2(makesym("x"), makesym("<NULL>"))),
1680 			  list2(makesym("QUOTE"), sym));
1681 		eval(form);
1682 	    } else if (eqp(car(ls), makesym(":BOUNDP"))) {
1683 		boundp = cadr(ls);
1684 		if (nullp(boundp)) {
1685 		    error(ILLEGAL_FORM, "defclass", arg3);
1686 		}
1687 		if (symbolp(boundp) && STRING_REF(boundp, 0) == ':') {
1688 		    error(IMPROPER_FORM, "defclass", arg3);
1689 		}
1690 		// (if (not (generic-function-p (function* name)))
1691 		// (defgeneric name (x)))
1692 		// (defmethod name ((x arg1))
1693 		// (not (dummyp (slot-value x 'var))))
1694 		form = list3(makesym("IF"),
1695 			     list2(makesym("NOT"),
1696 				   list2(makesym("GENERIC-FUNCTION-P"),
1697 					 list2(makesym("FUNCTION*"),
1698 					       boundp))),
1699 			     list3(makesym("DEFGENERIC"), boundp,
1700 				   list1(makesym("x"))));
1701 		eval(form);
1702 		form =
1703 		    list4(makesym("DEFMETHOD"), boundp,
1704 			  list1(list2(makesym("x"), arg1)),
1705 			  list2(makesym("NOT"),
1706 				list2(makesym("EISL-DUMMYP"),
1707 				      list3(makesym("SLOT-VALUE"),
1708 					    makesym("x"),
1709 					    list2(makesym("QUOTE"),
1710 						  sym)))));
1711 		eval(form);
1712 	    } else if (eqp(car(ls), makesym(":INITFORM"))) {
1713 		initform = cadr(ls);
1714 		if (length(ls) < 2) {
1715 		    error(ILLEGAL_FORM, "defclass", arg3);
1716 		}
1717 		if (symbolp(initform) && STRING_REF(initform, 0) == ':') {
1718 		    error(IMPROPER_FORM, "defclass", arg3);
1719 		}
1720 		if (initform_flag) {
1721 		    error(ILLEGAL_FORM, "defclass", arg3);
1722 		}
1723 		initform = eval(initform);
1724 		val = initform;
1725 		initform_flag = 1;
1726 	    } else if (eqp(car(ls), makesym(":INITARG"))) {
1727 		initarg = cadr(ls);
1728 		if (nullp(initarg)) {
1729 		    error(ILLEGAL_FORM, "defclass", arg3);
1730 		}
1731 		if (symbolp(initarg) && STRING_REF(initarg, 0) == ':') {
1732 		    error(IMPROPER_FORM, "defclass", arg3);
1733 		}
1734 		if (initarg_flag) {
1735 		    error(ILLEGAL_FORM, "defclass", arg3);
1736 		}
1737 		initarg_flag = 1;
1738 	    } else
1739 		error(ILLEGAL_FORM, "defclass", ls);
1740 
1741 	    ls = cddr(ls);
1742 	}
1743 
1744 	var = cons(cons(caar(arg3), val), var);
1745 	initargs = cons(cons(initarg, sym), initargs);
1746 	arg3 = cdr(arg3);
1747     }
1748 
1749     abstractp = metaclass = NIL;
1750     int             abstractp_flag;
1751     abstractp_flag = UNDEF;
1752 
1753     while (!nullp(arg4)) {
1754 	int             ls;
1755 
1756 	if (!listp(car(arg4)))
1757 	    error(ILLEGAL_FORM, "defclass", arg4);
1758 	ls = car(arg4);
1759 	if (eqp(car(ls), makesym(":ABSTRACTP"))) {
1760 	    abstractp = cadr(ls);
1761 	    if (length(ls) != 2)
1762 		error(ILLEGAL_FORM, "defclass", arg4);
1763 	    if (abstractp != NIL && abstractp != T)
1764 		error(ILLEGAL_FORM, "defclass", arg4);
1765 	    if (abstractp_flag != UNDEF && abstractp != abstractp_flag)
1766 		error(ILLEGAL_FORM, "defclass", arg4);
1767 	    abstractp_flag = abstractp;
1768 	} else if (eqp(car(ls), makesym(":METACLASS"))) {
1769 	    metaclass = cadr(ls);
1770 	    if (length(ls) != 2)
1771 		error(ILLEGAL_FORM, "defclass", arg4);
1772 	    if (!eqp(metaclass, makesym("<STANDARD-CLASS>")))
1773 		error(ILLEGAL_FORM, "defclass", arg4);
1774 	} else {
1775 	    error(ILLEGAL_FORM, "defclass", ls);
1776 	}
1777 	arg4 = cdr(arg4);
1778     }
1779     cl = makeclass(GET_NAME(arg1), sc);
1780     if (abstractp == T) {
1781 	SET_OPT(cl, ABSTRACT);	// abstract-class;
1782     } else if (metaclass == T) {
1783 	SET_OPT(cl, METACLASS);	// meta-class;
1784     } else {
1785 	SET_OPT(cl, USER);	// standard-class;
1786     }
1787     SET_CDR(cl, var);
1788     SET_AUX(cl, initargs);
1789     SET_AUX(arg1, cl);
1790     ignore_topchk = save;	// restore toplevel check;
1791     return (arg1);
1792 }
1793 
1794 
1795 int
f_defgeneric(int arglist)1796 f_defgeneric(int arglist)
1797 {
1798     int             arg1,
1799                     arg2,
1800                     arg3,
1801                     val;
1802 
1803     arg1 = car(arglist);	// func-name
1804     arg2 = cadr(arglist);	// lambda-list
1805     arg3 = cddr(arglist);	// body
1806     if (symbolp(arg1) && GET_OPT(arg1) == CONSTN) {
1807 	error(CANT_MODIFY, "defgeneric", arg1);
1808     }
1809     if (symbolp(arg1) && (functionp(arg1) || subrp(arg1) || fsubrp(arg1))) {
1810 	error(CANT_MODIFY, "defgeneric", arg1);
1811     }
1812     if (symbolp(arg1) && (genericp(arg1) && eqp(arg1, makesym("CREATE")))) {
1813 	error(CANT_MODIFY, "defgeneric", arg1);
1814     }
1815     if (symbolp(arg1)
1816 	&& (STRING_REF(arg1, 0) == ':' || STRING_REF(arg1, 0) == '&')) {
1817 	error(WRONG_ARGS, "defgeneric", arg1);
1818     }
1819     if (!symbolp(arg1)
1820 	&& (listp(arg1)
1821 	    && !(length(arg1) == 2 && eqp(car(arg1), makesym("SETF"))
1822 		 && symbolp(cadr(arg1))))) {
1823 	error(ILLEGAL_FORM, "defgeneric", arg1);
1824     }
1825     if (!listp(arg2)) {
1826 	error(NOT_LIST, "defgeneric", arg2);
1827     }
1828     if (duplicate_list_p(arg2)) {
1829 	error(IMPROPER_ARGS, "defgeneric", arg2);
1830     }
1831     if (improper_list_p(arg2)) {
1832 	error(IMPROPER_ARGS, "defgeneric", arg2);
1833     }
1834     if (illegal_lambda_p(arg2)) {
1835 	error(ILLEGAL_ARGS, "defgeneric", arg2);
1836     }
1837     if (!top_flag && !ignore_topchk) {
1838 	error(NOT_TOP_LEVEL, "defgeneric", arglist);
1839     }
1840     // when (defgeneric (set foo) ...)
1841     if (listp(arg1)) {
1842 	arg1 = cadr(arg1);
1843     }
1844 
1845     if (!member(arg1, generic_list))
1846 	generic_list = hcons(arg1, generic_list);
1847 
1848     val = makegeneric(GET_NAME(arg1), arg2, arg3);
1849     SET_CAR(arg1, val);
1850     return (arg1);
1851 }
1852 
1853 int
f_defgeneric_star(int arglist)1854 f_defgeneric_star(int arglist)
1855 {
1856     int             arg1,
1857                     arg2,
1858                     arg3,
1859                     val;
1860 
1861     arg1 = car(arglist);	// func-name
1862     arg2 = cadr(arglist);	// lambda-list
1863     arg3 = cddr(arglist);	// body
1864     if (!symbolp(arg1))
1865 	error(NOT_SYM, "defgeneric", arg1);
1866     if (GET_OPT(arg1) == CONSTN)
1867 	error(CANT_MODIFY, "defgeneric", arg1);
1868     if (IS_FUNC(GET_CAR(arg1)))
1869 	error(CANT_MODIFY, "defgeneric", arg1);
1870     if (IS_SUBR(GET_CAR(arg1)))
1871 	error(CANT_MODIFY, "defgeneric", arg1);
1872     if (!listp(arg2))
1873 	error(NOT_LIST, "defgeneric", arg2);
1874 
1875     if (!member(arg1, generic_list))
1876 	generic_list = hcons(arg1, generic_list);
1877 
1878     val = makegeneric_star(arg2, arg3);
1879     SET_CAR(arg1, val);
1880     return (arg1);
1881 }
1882 
1883 /*
1884  * if Generic function, set CDR area method object with insert sorting.
1885  */
1886 int
f_defmethod(int arglist)1887 f_defmethod(int arglist)
1888 {
1889     int             arg1,
1890                     arg2,
1891                     gen;
1892 
1893     arg1 = car(arglist);	// method-name
1894     arg2 = cdr(arglist);	// parameter-profile
1895 
1896     if (symbolp(arg1) && (subrp(arg1) || fsubrp(arg1))) {
1897 	error(CANT_MODIFY, "defmethod", arg1);
1898     }
1899     if (symbolp(arg1) && (functionp(arg1) || macrop(arg1))) {
1900 	error(ILLEGAL_FORM, "defmethod", arg1);
1901     }
1902     if (symbolp(arg1)
1903 	&& (GET_CAR(arg1) == NIL && !member(arg1, generic_list))) {
1904 	error(UNDEF_FUN, "defmethod", arg1);
1905     }
1906     if (!symbolp(arg1)
1907 	&& (listp(arg1)
1908 	    && !(length(arg1) == 2 && eqp(car(arg1), makesym("SETF"))
1909 		 && symbolp(cadr(arg1))))) {
1910 	error(ILLEGAL_FORM, "defmethod", arg1);
1911     }
1912     // when (defmethod (set foo) ...)
1913     if (listp(arg1)) {
1914 	arg1 = cadr(arg1);
1915     }
1916 
1917     if (listp(car(arg2)) && illegal_lambda_p(car(arg2))) {
1918 	error(ILLEGAL_ARGS, "defmethod", arg2);
1919     }
1920     if (listp(car(arg2))
1921 	&& !unified_parameter_p(GET_CAR(GET_CAR(arg1)), car(arg2))) {
1922 	error(ILLEGAL_FORM, "defmethod", arg2);
1923     }
1924     if (listp(car(arg2)) && undef_parameter_p(car(arg2))) {
1925 	error(UNDEF_CLASS, "defmethod", arg2);
1926     }
1927     // if method-qualifier and method-combination of generic-function is
1928     // NIL -> error
1929     if (symbolp(car(arg2)) && method_qualifier_p(car(arg2))
1930 	&& GET_PROP(GET_CAR(arg1)) == NIL)
1931 	error(IMPROPER_ARGS, "defmethod", arg2);
1932     if (symbolp(car(arg2)) && !method_qualifier_p(car(arg2))) {
1933 	error(IMPROPER_ARGS, "defmethod", arg2);
1934     }
1935     // tests/ilos2.o error comment out
1936     // if (!top_flag && !ignore_topchk) {
1937     // error(NOT_TOP_LEVEL, "defmethod", arglist);
1938     // }
1939 
1940 
1941     gen = generic_func = GET_CAR(arg1);
1942     insert_method(makemethod(arg2), gen);
1943     generic_func = NIL;
1944     return (arg1);
1945 }
1946 
1947 int
f_ignore_errors(int arglist)1948 f_ignore_errors(int arglist)
1949 {
1950     volatile int    res;
1951 
1952     ignore_flag = true;
1953     TRY             res = f_progn(arglist);
1954     ELSE            res = NIL;
1955     END_TRY;
1956     ignore_flag = false;
1957     return res;
1958 }
1959 
1960 int
f_with_open_input_file(int arglist)1961 f_with_open_input_file(int arglist)
1962 {
1963     int             arg1,
1964                     arg2,
1965                     sym,
1966                     str,
1967                     val,
1968                     ep1,
1969                     res;
1970     FILE           *port;
1971 
1972     if (nullp(arglist) || atomp(arglist))
1973 	error(NOT_EXIST_ARG, "with-open-input-file", NIL);
1974     if (length(arglist) != 2)
1975 	error(IMPROPER_ARGS, "with-open-input-file", arglist);
1976     arg1 = car(arglist);
1977     arg2 = cdr(arglist);
1978     sym = car(arg1);		// stream-name;
1979     str = eval(cadr(arg1));	// file-name;
1980     if (!symbolp(sym))
1981 	error(NOT_SYM, "with-open-input-file", sym);
1982     if (!stringp(str))
1983 	error(NOT_STR, "with-open-input-file", str);
1984     const char     *fname = GET_NAME(str);
1985     port = fopen(fname, "r");
1986     if (port == NULL) {
1987 	error(CANT_OPEN, "with-open-input-file", str);
1988 	return NIL;
1989     }
1990     val = makestream(port, EISL_INPUT, Str_dup(fname, 1, 0, 1));
1991     ep1 = ep;
1992     addlexenv(sym, val);
1993     res = f_progn(arg2);
1994     fclose(port);
1995     ep = ep1;
1996     return (res);
1997 }
1998 
1999 int
f_with_open_output_file(int arglist)2000 f_with_open_output_file(int arglist)
2001 {
2002     int             arg1,
2003                     arg2,
2004                     sym,
2005                     str,
2006                     val,
2007                     ep1,
2008                     res;
2009     FILE           *port;
2010 
2011     if (nullp(arglist) || atomp(arglist))
2012 	error(NOT_EXIST_ARG, "with-open-output-file", NIL);
2013     if (length(arglist) != 2)
2014 	error(IMPROPER_ARGS, "with-open-output-file", arglist);
2015     arg1 = car(arglist);
2016     arg2 = cdr(arglist);
2017     sym = car(arg1);		// stream-name;
2018     str = eval(cadr(arg1));	// file-name;
2019     if (!symbolp(sym))
2020 	error(NOT_SYM, "with-open-output-file", sym);
2021     if (!stringp(str))
2022 	error(NOT_STR, "with-open-output-file", str);
2023     const char     *fname = GET_NAME(str);
2024     port = fopen(fname, "w");
2025     if (port == NULL) {
2026 	error(CANT_OPEN, "with-open-output-file", str);
2027 	return NIL;
2028     }
2029     val = makestream(port, EISL_OUTPUT, Str_dup(fname, 1, 0, 1));
2030     ep1 = ep;
2031     addlexenv(sym, val);
2032     res = f_progn(arg2);
2033     fclose(port);
2034     ep = ep1;
2035     return (res);
2036 }
2037 
2038 int
f_with_open_io_file(int arglist)2039 f_with_open_io_file(int arglist)
2040 {
2041     int             arg1,
2042                     arg2,
2043                     sym,
2044                     str,
2045                     val,
2046                     ep1,
2047                     res;
2048     FILE           *port;
2049 
2050     if (nullp(arglist) || atomp(arglist))
2051 	error(NOT_EXIST_ARG, "with-open-io-file", NIL);
2052     if (length(arglist) != 2)
2053 	error(IMPROPER_ARGS, "with-open-io-file", arglist);
2054     arg1 = car(arglist);
2055     arg2 = cdr(arglist);
2056     sym = car(arg1);		// stream-name;
2057     str = eval(cadr(arg1));	// file-name;
2058     if (!symbolp(sym))
2059 	error(NOT_SYM, "with-open-io-file", sym);
2060     if (!stringp(str))
2061 	error(NOT_STR, "with-open-io-file", str);
2062     const char     *fname = GET_NAME(str);
2063     port = fopen(fname, "r+");
2064     if (port == NULL) {
2065 	error(CANT_OPEN, "with-open-io-file", str);
2066 	return NIL;
2067     }
2068     val = makestream(port, EISL_OPEN, Str_dup(fname, 1, 0, 1));
2069     ep1 = ep;
2070     addlexenv(sym, val);
2071     res = f_progn(arg2);
2072     fclose(port);
2073     ep = ep1;
2074     return (res);
2075 }
2076 
2077 int
f_with_standard_input(int arglist)2078 f_with_standard_input(int arglist)
2079 {
2080     int             arg1,
2081                     arg2,
2082                     stream,
2083                     save,
2084                     res;
2085 
2086     arg1 = car(arglist);
2087     arg2 = cdr(arglist);
2088 
2089     stream = eval(arg1);
2090     if (!input_stream_p(stream))
2091 	error(NOT_STREAM, "with-standard-input, stream", stream);
2092 
2093     save = input_stream;
2094     input_stream = stream;
2095     res = f_progn(arg2);
2096     input_stream = save;
2097     return (res);
2098 }
2099 
2100 int
f_with_standard_output(int arglist)2101 f_with_standard_output(int arglist)
2102 {
2103     int             arg1,
2104                     arg2,
2105                     stream,
2106                     save,
2107                     res;
2108 
2109     arg1 = car(arglist);
2110     arg2 = cdr(arglist);
2111 
2112     stream = eval(arg1);
2113     if (!output_stream_p(stream))
2114 	error(NOT_STREAM, "with-standard-output, stream", stream);
2115 
2116     save = output_stream;
2117     output_stream = stream;
2118     res = f_progn(arg2);
2119     output_stream = save;
2120     return (res);
2121 }
2122 
2123 int
f_with_error_output(int arglist)2124 f_with_error_output(int arglist)
2125 {
2126     int             arg1,
2127                     arg2,
2128                     stream,
2129                     save,
2130                     res;
2131 
2132     arg1 = car(arglist);
2133     arg2 = cdr(arglist);
2134 
2135     stream = eval(arg1);
2136     if (!output_stream_p(stream))
2137 	error(NOT_STREAM, "with-error-output, stream", stream);
2138 
2139     save = output_stream;
2140     output_stream = stream;
2141     res = f_progn(arg2);
2142     output_stream = save;
2143     return (res);
2144 }
2145 
2146 int
f_with_handler(int arglist)2147 f_with_handler(int arglist)
2148 {
2149     int             arg1,
2150                     arg2,
2151                     res;
2152 
2153     arg1 = car(arglist);
2154     arg2 = cdr(arglist);
2155 
2156     error_handler = cons(eval(arg1), error_handler);
2157     res = f_progn(arg2);
2158     return (res);
2159 }
2160 
2161 int
f_convert(int arglist)2162 f_convert(int arglist)
2163 {
2164     int             arg1,
2165                     arg2;
2166 
2167     arg1 = car(arglist);
2168     arg2 = cadr(arglist);
2169     if (length(arglist) != 2)
2170 	error(IMPROPER_ARGS, "convert", arglist);
2171     if (improper_list_p(arglist))
2172 	error(IMPROPER_ARGS, "convert", arglist);
2173     if (!symbolp(arg2))
2174 	error(NOT_SYM, "convert", arg2);
2175     if (GET_OPT(arg2) != SYSTEM)
2176 	error(NOT_CLASS, "convert", arg2);
2177 
2178     arg1 = eval(arg1);
2179     return convert(arg1, arg2);
2180 }
2181 
2182 int
f_the(int arglist)2183 f_the(int arglist)
2184 {
2185     int             arg1,
2186                     arg2;
2187 
2188     arg1 = car(arglist);
2189     arg2 = cadr(arglist);
2190     if (length(arglist) != 2)
2191 	error(IMPROPER_ARGS, "the", arglist);
2192     if (improper_list_p(arglist))
2193 	error(IMPROPER_ARGS, "the", arglist);
2194 
2195     if (GET_AUX(arg1) != NIL)
2196 	return (eval(arg2));
2197     else
2198 	error(NOT_CLASS, "the", arg1);
2199 
2200     return (UNDEF);
2201 }
2202 
2203 int
f_assure(int arglist)2204 f_assure(int arglist)
2205 {
2206     int             arg1,
2207                     arg2;
2208 
2209     arg1 = car(arglist);
2210     arg2 = cadr(arglist);
2211     if (length(arglist) != 2)
2212 	error(IMPROPER_ARGS, "assure", arglist);
2213     if (improper_list_p(arglist))
2214 	error(IMPROPER_ARGS, "assure", arglist);
2215 
2216     arg2 = eval(arg2);
2217     if (GET_AUX(arg1) == GET_AUX(arg2))
2218 	return (arg2);
2219     else if (subclassp(GET_AUX(arg2), GET_AUX(arg1)))
2220 	return (arg2);
2221     else
2222 	error(CANT_ASSURE, "assure", arg2);
2223 
2224     return (UNDEF);
2225 }
2226 
2227 double
getETime()2228 getETime()
2229 {
2230     struct timeval  tv;
2231     gettimeofday(&tv, NULL);
2232     return tv.tv_sec + (double) tv.tv_usec * 1e-6;
2233 }
2234 
2235 
2236 
2237 int
f_time(int arglist)2238 f_time(int arglist)
2239 {
2240     int             arg1;
2241     double          st,
2242                     en;
2243 
2244     arg1 = car(arglist);
2245     if (length(arglist) != 1)
2246 	error(WRONG_ARGS, "time", arglist);
2247 
2248     st = getETime();
2249     eval(arg1);
2250     en = getETime();
2251     Fmt_print("Elapsed Time(second)=%.6f\n", en - st);
2252     return (UNDEF);
2253 }
2254 
2255 int
f_trace(int arglist)2256 f_trace(int arglist)
2257 {
2258 
2259     if (nullp(arglist)) {
2260 	return (trace_list);
2261     } else {
2262 	while (!nullp(arglist)) {
2263 	    if (!symbolp(car(arglist)))
2264 		error(NOT_SYM, "trace", car(arglist));
2265 	    if (!member(car(arglist), trace_list)) {
2266 		SET_TR(car(arglist), 1);
2267 		trace_list = cons(car(arglist), trace_list);
2268 	    }
2269 	    arglist = cdr(arglist);
2270 	}
2271 	return (T);
2272     }
2273 }
2274 
2275 int
f_untrace(int arglist)2276 f_untrace(int arglist)
2277 {
2278 
2279     if (nullp(arglist)) {
2280 	while (!nullp(trace_list)) {
2281 	    SET_TR(car(trace_list), 0);	// reset trace tag of symbol
2282 	    SET_TR(GET_CAR(car(trace_list)), 0);	// reset trace
2283 	    // nest level
2284 	    trace_list = cdr(trace_list);
2285 	}
2286     } else {
2287 	while (!nullp(arglist)) {
2288 	    if (!symbolp(car(arglist)))
2289 		error(NOT_SYM, "untrace", car(arglist));
2290 	    SET_TR(car(arglist), 0);
2291 	    SET_TR(GET_CAR(car(arglist)), 0);
2292 	    arglist = cdr(arglist);
2293 	}
2294 	trace_list = remove_list(trace_list, arglist);
2295     }
2296     return (T);
2297 }
2298 
2299 int
f_defmodule(int arglist)2300 f_defmodule(int arglist)
2301 {
2302     int             arg1,
2303                     arg2,
2304                     exports;
2305 
2306     arg1 = car(arglist);	// module name
2307     arg2 = cdr(arglist);	// body
2308     exports = NIL;
2309 
2310     while (!nullp(arg2)) {
2311 	int             sexp;
2312 
2313 	sexp = car(arg2);
2314 	if (symbolp(car(sexp)) && HAS_NAME(car(sexp), "DEFPUBLIC"))
2315 	    exports = cons(cadr(sexp), exports);
2316 
2317 	eval(modulesubst(car(arg2), arg1, exports));
2318 	arg2 = cdr(arg2);
2319     }
2320     return (T);
2321 }
2322 
2323 
2324 int
modulesubst(int addr,int module,int fname)2325 modulesubst(int addr, int module, int fname)
2326 {
2327     int             temp;
2328 
2329     if (IS_NIL(addr) || IS_T(addr))
2330 	return (addr);
2331     else if (numberp(addr))
2332 	return (addr);
2333     else if (vectorp(addr))
2334 	return (addr);
2335     else if (arrayp(addr))
2336 	return (addr);
2337     else if (stringp(addr))
2338 	return (addr);
2339     else if (charp(addr))
2340 	return (addr);
2341     else if (class_symbol_p(addr))
2342 	return (addr);
2343     else if (symbolp(addr)) {
2344 	if (!member(addr, fname) && !eqp(addr, makesym(":REST"))
2345 	    && !eqp(addr, makesym("&REST")))
2346 	    return (modulesubst1(addr, module));
2347 	else
2348 	    return (addr);
2349     } else if (listp(addr)) {
2350 	if ((symbolp(car(addr))) && (HAS_NAME(car(addr), "QUOTE"))) {
2351 	    temp = cadr(addr);
2352 	    if (listp(temp) && symbolp(car(temp))
2353 		&& (HAS_NAME(car(temp), "UNQUOTE")))
2354 		return (cons
2355 			(car(addr),
2356 			 modulesubst(cdr(addr), module, fname)));
2357 	    else
2358 		return (addr);
2359 	} else if ((symbolp(car(addr)))
2360 		   && (HAS_NAME(car(addr), "QUASI-QUOTE")))
2361 	    return (cons
2362 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2363 	else if ((symbolp(car(addr))) && (HAS_NAME(car(addr), "UNQUOTE")))
2364 	    return (cons
2365 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2366 	else if ((symbolp(car(addr)))
2367 		 && (HAS_NAME(car(addr), "UNQUOTE-SPLICING")))
2368 	    return (cons
2369 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2370 	else if (subrp(car(addr)))
2371 	    return (cons
2372 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2373 	else if ((symbolp(car(addr)))
2374 		 && (HAS_NAME(car(addr), "DEFPUBLIC")))
2375 	    return (cons
2376 		    (makesym("DEFUN"),
2377 		     cons(cadr(addr),
2378 			  modulesubst(cddr(addr), module, fname))));
2379 	else if ((symbolp(car(addr))) && (HAS_NAME(car(addr), "DEFUN")))
2380 	    return (cons
2381 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2382 	else if ((symbolp(car(addr))) && (HAS_NAME(car(addr), ":METHOD")))
2383 	    return (cons
2384 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2385 	else if ((symbolp(car(addr))) && (HAS_NAME(car(addr), "CASE")))
2386 	    return (cons
2387 		    (car(addr),
2388 		     cons(modulesubst(cadr(addr), module, fname),
2389 			  modulesubst_case(cddr(addr), module, fname))));
2390 	else if ((symbolp(car(addr)))
2391 		 && (HAS_NAME(car(addr), "CASE-USING")))
2392 	    return (cons
2393 		    (car(addr),
2394 		     cons(modulesubst(cadr(addr), module, fname),
2395 			  modulesubst_case(cddr(addr), module, fname))));
2396 	else if (fsubrp(car(addr)))
2397 	    return (cons
2398 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2399 	else if (macrop(car(addr)))
2400 	    return (cons
2401 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2402 	else if (genericp(car(addr)))
2403 	    return (cons
2404 		    (car(addr), modulesubst(cdr(addr), module, fname)));
2405 	else
2406 	    return (cons
2407 		    (modulesubst(car(addr), module, fname),
2408 		     modulesubst(cdr(addr), module, fname)));
2409 
2410     }
2411     return (T);
2412 }
2413 
2414 int
modulesubst1(int x,int module)2415 modulesubst1(int x, int module)
2416 {
2417     char            str[SYMSIZE];
2418 
2419     Fmt_sfmt(str, SYMSIZE, "%s::%s", GET_NAME(module), GET_NAME(x));
2420     return (makesym(str));
2421 }
2422 
2423 
2424 int
modulesubst_case(int addr,int module,int fname)2425 modulesubst_case(int addr, int module, int fname)
2426 {
2427     int             bodies,
2428                     newbodies;
2429 
2430     bodies = addr;
2431     newbodies = NIL;
2432 
2433     while (!nullp(bodies)) {
2434 	int             body,
2435 	                newbody;
2436 
2437 	body = car(bodies);
2438 	newbody = cons(car(body), modulesubst(cdr(body), module, fname));
2439 	newbodies = cons(newbody, newbodies);
2440 
2441 	bodies = cdr(bodies);
2442     }
2443     newbodies = reverse(newbodies);
2444     return (newbodies);
2445 }
2446