1 /*
2 * Special Forms, Control Structures, Evaluator Related Stuff for CLISP
3 * Bruno Haible 1990-2005, 2016-2017
4 * Sam Steingold 1998-2009, 2011
5 * German comments translated into English: Stefan Kain 2002-09-28
6 */
7
8 #include "lispbibl.c"
9
10 /* (SYSTEM::%EXIT [errorp]) leaves the system */
11 LISPFUN(exit,seclass_default,0,1,norest,nokey,0,NIL) {
12 var object errorp = STACK_0;
13 final_exitcode = missingp(errorp) ? 0 :
14 (uint_p(errorp) ? I_to_uint(errorp) : 1);
15 quit();
16 }
17
18 LISPSPECFORM(eval_when, 1,0,body)
19 { /* (EVAL-WHEN ({situation}) {form}), CLTL p. 69 */
20 var object situations = STACK_1; /* list of situations */
21 /* search symbol EVAL or list (NOT COMPILE) in it: */
22 while (consp(situations)) {
23 var object situation = Car(situations);
24 if (eq(situation,S(eval)) /* symbol EVAL found? */
25 || eq(situation,S(Kexecute)))
26 goto found;
27 if (consp(situation) && eq(Car(situation),S(not))) {
28 situation = Cdr(situation);
29 if (consp(situation) && nullp(Cdr(situation))
30 && (eq(Car(situation),S(compile)) /* list (NOT COMPILE) found? */
31 || eq(Car(situation),S(Kcompile_toplevel))))
32 goto found;
33 }
34 situations = Cdr(situations);
35 }
36 /* symbol EVAL not found */
37 VALUES1(NIL);
38 skipSTACK(2);
39 return;
40 found: { /* symbol EVAL found */
41 var object body = popSTACK();
42 skipSTACK(1);
43 implicit_progn(body,NIL); /* evaluate body */
44 }
45 }
46
47 LISPSPECFORM(quote, 1,0,nobody)
48 { /* (QUOTE object) == 'object, CLTL p. 86 */
49 VALUES1(popSTACK()); /* argument as value */
50 }
51
52 LISPSPECFORM(function, 1,1,nobody)
53 { /* (FUNCTION funname), CLTL. p. 87
54 either (FUNCTION symbol)
55 or (FUNCTION (LAMBDA . lambdabody))
56 or (FUNCTION name (LAMBDA . lambdabody)) */
57 if (!boundp(STACK_0)) { /* 1 argument */
58 var object name = STACK_1;
59 if (consp(name) && eq(Car(name),S(lambda))) {
60 VALUES1(get_closure(Cdr(name),S(Klambda),false,&aktenv));
61 } else {
62 STACK_1 = check_funname(source_program_error,S(function),STACK_1);
63 var object fun = sym_function(STACK_1,aktenv.fun_env);
64 if (!functionp(fun)) {
65 if (functionmacrop(fun))
66 fun = TheFunctionMacro(fun)->functionmacro_function;
67 else
68 fun = check_fdefinition(STACK_1,S(function));
69 }
70 VALUES1(fun);
71 }
72 } else { /* 2 arguments */
73 STACK_1 = check_funname(source_program_error,S(function),STACK_1);
74 while (!(consp(STACK_0) && eq(Car(STACK_0),S(lambda)))) {
75 pushSTACK(NIL); /* no PLACE */
76 pushSTACK(STACK_1); /* SOURCE-PROGRAM-ERROR slot DETAIL */
77 pushSTACK(STACK_0); pushSTACK(S(function));
78 check_value(source_program_error,
79 GETTEXT("~S: ~S should be a lambda expression"));
80 STACK_0 = value1;
81 }
82 VALUES1(get_closure(Cdr(STACK_0),STACK_1,false,&aktenv));
83 }
84 skipSTACK(2);
85 }
86
87 LISPFUNNR(symbol_value,1)
88 { /* (SYMBOL-VALUE symbol), CLTL p. 90 */
89 STACK_0 = check_symbol(STACK_0);
90 value1 = Symbol_value(STACK_0);
91 if (!boundp(value1)) {
92 check_variable_value_replacement(&STACK_0,true); /* sets value1 */
93 if (eq(T,value2)) /* STORE-VALUE */
94 Symbol_value(STACK_0) = value1;
95 }
96 skipSTACK(1); mv_count = 1;
97 }
98
99 LISPFUNNR(symbol_function,1)
100 { /* (SYMBOL-FUNCTION symbol), CLTL p. 90 */
101 var object symbol = check_symbol(popSTACK());
102 var object val = Symbol_function(symbol);
103 if (!boundp(val))
104 val = check_fdefinition(symbol,S(symbol_function));
105 VALUES1(val);
106 }
107
108 /* UP: just like GET-FUNNAME-SYMBOL (see init.lisp),
109 except that it does not create the new symbol when there is none yet
110 and does not issue a warning when the SETF symbol is shadowed
111 can trigger GC */
funname_to_symbol(object symbol)112 local maygc object funname_to_symbol (object symbol) {
113 if (!funnamep(symbol))
114 symbol = check_funname_replacement(type_error,TheSubr(subr_self)->name,symbol);
115 if (!symbolp(symbol)) /* (get ... 'SYS::SETF-FUNCTION) */
116 symbol = get(Car(Cdr(symbol)),S(setf_function));
117 return symbol;
118 }
119
120 LISPFUNNS(fdefinition,1)
121 { /* (FDEFINITION funname), CLTL2 p. 120 */
122 var object symbol = funname_to_symbol(STACK_0);
123 if (!symbolp(symbol))
124 VALUES1(check_fdefinition(STACK_0,TheSubr(subr_self)->name));
125 else {
126 var object val = Symbol_function(symbol);
127 if (!boundp(val))
128 val = check_fdefinition(STACK_0,TheSubr(subr_self)->name);
129 VALUES1(val);
130 }
131 skipSTACK(1);
132 }
133
134 LISPFUNNR(boundp,1)
135 { /* (BOUNDP symbol), CLTL p. 90 */
136 var object symbol = check_symbol(popSTACK());
137 VALUES_IF(boundp(Symbol_value(symbol)));
138 }
139
140 LISPFUNNR(fboundp,1)
141 { /* (FBOUNDP symbol), CLTL p. 90, CLTL2 p. 120 */
142 var object symbol = funname_to_symbol(popSTACK());
143 VALUES_IF(symbolp(symbol) && /* should be a symbol */
144 boundp(Symbol_function(symbol)));
145 }
146
147 LISPFUNNF(special_operator_p,1)
148 { /* (SPECIAL-OPERATOR-P symbol), was (SPECIAL-FORM-P symbol), CLTL p. 91 */
149 var object symbol = check_symbol(popSTACK());
150 var object obj = Symbol_function(symbol);
151 VALUES_IF(fsubrp(obj));
152 }
153
154 /* UP: Check the body of a SETQ- or PSETQ-form.
155 > caller: Caller (a symbol)
156 > STACK_0: Body
157 < result: true if symbol-macros have to be expanded.
158 can trigger GC */
check_setq_body(object caller)159 local maygc bool check_setq_body (object caller) {
160 pushSTACK(STACK_0); /* save body */
161 while (consp(STACK_0)) {
162 var object sym = check_symbol_non_constant(Car(STACK_0),caller);
163 Car(STACK_0) = sym;
164 if (sym_macrop(sym)) {
165 skipSTACK(1); /* drop body */
166 return true;
167 }
168 STACK_0 = Cdr(STACK_0);
169 if (atomp(STACK_0)) {
170 if (!nullp(STACK_0))
171 error_dotted_form(STACK_1,TheFsubr(subr_self)->name);
172 /* STACK_0 == SOURCE-PROGRAM-ERROR slot DETAIL */
173 pushSTACK(STACK_1); pushSTACK(TheFsubr(subr_self)->name);
174 error(source_program_error,GETTEXT("~S: odd number of arguments: ~S"));
175 }
176 STACK_0 = Cdr(STACK_0);
177 }
178 /* body is finished. */
179 if (!nullp(STACK_0))
180 error_dotted_form(STACK_1,TheFsubr(subr_self)->name);
181 skipSTACK(1); /* drop body */
182 return false;
183 }
184
185 LISPSPECFORM(setq, 0,0,body)
186 { /* (SETQ {var form}), CLTL p. 91 */
187 if (check_setq_body(S(setq))) {
188 var object form = allocate_cons();
189 Car(form) = S(setf); Cdr(form) = popSTACK(); /* turn SETQ into SETF */
190 eval(form);
191 } else {
192 var object body = popSTACK();
193 if (consp(body)) {
194 do {
195 var object symbol = Car(body); /* variable */
196 body = Cdr(body);
197 pushSTACK(Cdr(body)); /* save remaining list */
198 pushSTACK(symbol); /* save symbol */
199 eval(Car(body)); /* evaluate next form */
200 symbol = popSTACK();
201 value1 = setq(symbol,value1); /* execute assignment */
202 body = popSTACK();
203 } while (consp(body));
204 /* value1 is the last evaluation result. */
205 } else
206 value1 = NIL; /* default value at (SETQ) */
207 mv_count=1;
208 }
209 }
210
211 LISPSPECFORM(psetq, 0,0,body)
212 { /* (PSETQ {var form}), CLTL p. 92 */
213 if (check_setq_body(S(psetq))) {
214 var object form = allocate_cons();
215 Car(form) = S(psetf); Cdr(form) = popSTACK(); /* turn PSETQ into PSETF */
216 eval(form);
217 } else {
218 var object body = popSTACK();
219 var uintL body_length = llength(body)/2; /* number of pairs (var form) */
220 if (body_length > 0) {
221 get_space_on_STACK(body_length*2*sizeof(gcv_object_t));
222 {
223 var uintL count = body_length;
224 do {
225 pushSTACK(Car(body)); /* push variable on stack */
226 body = Cdr(body);
227 pushSTACK(Cdr(body)); /* remaining list on stack */
228 eval(Car(body)); /* evaluate next form */
229 body = STACK_0;
230 STACK_0 = value1; /* its result in the stack */
231 } while (--count);
232 }
233 {
234 var uintL count = body_length;
235 do {
236 var object val = popSTACK(); /* value */
237 var object sym = popSTACK(); /* symbol */
238 setq(sym,val); /* execute assignment */
239 } while (--count);
240 }
241 }
242 VALUES1(NIL);
243 }
244 }
245
246 /* (SETF (SYMBOL-VALUE symbol) value) = (SET symbol value), CLTL p. 92 */
247 LISPFUNN(set,2)
248 {
249 var object symbol = check_symbol_non_constant(STACK_1,S(set));
250 VALUES1(Symbol_value(symbol) = STACK_0);
251 skipSTACK(2);
252 }
253
254 LISPFUNN(makunbound,1)
255 { /* (MAKUNBOUND symbol), CLTL p. 92 */
256 var object symbol = check_symbol_non_constant(popSTACK(),S(makunbound));
257 Symbol_value(symbol) = unbound;
258 VALUES1(symbol);
259 }
260
261 LISPFUNN(fmakunbound,1)
262 { /* (FMAKUNBOUND symbol), CLTL p. 92, CLTL2 p. 123 */
263 var object symbol = funname_to_symbol(STACK_0);
264 var object funname = popSTACK();
265 if (!symbolp(symbol)) /* should be a symbol */
266 goto undef; /* otherwise undefined */
267 {
268 var object obj = Symbol_function(symbol);
269 if (fsubrp(obj)) {
270 pushSTACK(symbol);
271 pushSTACK(S(fmakunbound));
272 error(error_condition,GETTEXT("~S: the special operator definition of ~S must not be removed"));
273 }
274 }
275 { Symbol_function(symbol) = unbound; }
276 undef:
277 VALUES1(funname);
278 }
279
280 LISPFUN(apply,seclass_default,2,0,rest,nokey,0,NIL)
281 { /* (APPLY function {arg} arglist), CLTL p. 107 */
282 rest_args_pointer skipSTACKop 1; /* BEFORE */
283 apply(Before(rest_args_pointer), /* function */
284 argcount, /* number of {arg} on the stack */
285 popSTACK()); /* arglist */
286 skipSTACK(1); /* remove function from the stack */
287 }
288
289 LISPFUN(funcall,seclass_default,1,0,rest,nokey,0,NIL)
290 { /* (FUNCALL function {arg}), CLTL p. 108 */
291 funcall(Before(rest_args_pointer),argcount); skipSTACK(1);
292 }
293
294 LISPSPECFORM(progn, 0,0,body)
295 { /* (PROGN {form}), CLTL p. 109 */
296 implicit_progn(popSTACK(),NIL);
297 }
298
299 /* Macro: Evaluates the forms of a form list.
300 implicit_prog();
301 > -(STACK): form list
302 increases STACK by 1
303 can trigger GC */
304 #define implicit_prog() \
305 do { while (mconsp(STACK_0)) { \
306 var object forms = STACK_0; \
307 STACK_0 = Cdr(forms); \
308 eval(Car(forms)); /* evaluate next form */ \
309 } \
310 skipSTACK(1); \
311 } while(0)
312
313 LISPSPECFORM(prog1, 1,0,body)
314 { /* (PROG1 form1 {form}), CLTL p. 109 */
315 STACK_1 = (eval(STACK_1),value1); /* evaluate form1, save value */
316 implicit_prog();
317 VALUES1(popSTACK()); /* return saved value */
318 }
319
320 LISPSPECFORM(prog2, 2,0,body)
321 { /* (PROG2 form1 form2 {form}), CLTL p. 109 */
322 eval(STACK_2); /* evaluate form1 */
323 eval(STACK_1); STACK_2 = value1; /* evaluate form2, save value */
324 STACK_1 = STACK_0; skipSTACK(1);
325 implicit_prog();
326 VALUES1(popSTACK()); /* return saved value */
327 }
328
329 /* call parse_dd() and maybe complain about doc-string
330 parse_doc_decl(body);
331 > body: whole Body
332 can trigger GC */
parse_doc_decl(object body,bool permit_doc_string)333 local maygc object parse_doc_decl (object body, bool permit_doc_string) {
334 pushSTACK(NIL); /* place for (COMPILE name) */
335 pushSTACK(body);
336 STACK_1 = parse_dd(body);
337 if (!permit_doc_string && !nullp(value3)) {
338 pushSTACK(value1); pushSTACK(value2); pushSTACK(value3); /* save */
339 pushSTACK(NIL); pushSTACK(STACK_(0+3+1));
340 STACK_1 = CLSTEXT("doc-string is not allowed here and will be ignored: ~S");
341 funcall(S(warn),2);
342 value3 = popSTACK(); value2 = popSTACK(); value1 = popSTACK();
343 }
344 skipSTACK(1);
345 return popSTACK();
346 }
347
348 /* get the 5 environment objects to the stack
349 adds 5 elements to the STACK
350 can trigger GC */
aktenv_to_stack(void)351 local maygc inline void aktenv_to_stack (void) {
352 /* nest current environment, push on STACK */
353 var gcv_environment_t* stack_env = nest_aktenv();
354 #if !defined(STACK_UP)
355 /* and transfer here */
356 var object my_var_env = stack_env->var_env;
357 var object my_fun_env = stack_env->fun_env;
358 var object my_block_env = stack_env->block_env;
359 var object my_go_env = stack_env->go_env;
360 var object my_decl_env = stack_env->decl_env;
361 skipSTACK(5); /* and take away from STACK again */
362 pushSTACK(my_var_env); /* second argument */
363 pushSTACK(my_fun_env); /* third argument */
364 pushSTACK(my_block_env); /* fourth argument */
365 pushSTACK(my_go_env); /* fifth argument */
366 pushSTACK(my_decl_env); /* sixth argument */
367 #endif
368 }
369
370 /* UP for LET, LET*, LOCALLY, MULTIPLE-VALUE-BIND, SYMBOL-MACROLET:
371 Compiles the current form and executes it in compiled state.
372 compile_eval_form()
373 > in STACK: EVAL-frame with the form
374 > closure_name: name or unbound
375 < mv_count/mv_space: Values
376 can trigger GC */
compile_eval_form(object closure_name)377 local maygc Values compile_eval_form (object closure_name)
378 { /* execute (SYS::COMPILE-FORM form venv fenv benv genv denv) :
379 get the whole form from the EVAL-frame in the stack: */
380 var object form = STACK_(frame_form);
381 var gcv_object_t *closure_name_ = /* save closure_name */
382 boundp(closure_name) ? (pushSTACK(closure_name),&STACK_0) : NULL;
383 pushSTACK(form); /* as first argument */
384 aktenv_to_stack();
385 var uintC argcount = 6;
386 if (NULL != closure_name_) {
387 pushSTACK(*closure_name_);
388 argcount = 7;
389 }
390 funcall(S(compile_form),argcount);
391 /* call the freshly compiled closure with 0 arguments: */
392 funcall(value1,0);
393 if (NULL != closure_name_) skipSTACK(1); /* drop closure_name_ */
394 }
395
396 /* signal a correctable error for a broken LET variable spec
397 can trigger GC */
check_varspec(object varspec,object caller)398 local maygc object check_varspec (object varspec, object caller) {
399 pushSTACK(NIL); /* no PLACE */
400 pushSTACK(varspec); /* SOURCE-PROGRAM-ERROR slot DETAIL */
401 pushSTACK(varspec); pushSTACK(caller);
402 check_value(source_program_error,
403 GETTEXT("~S: illegal variable specification ~S"));
404 return value1;
405 }
406
407 /* the variables declared special appear on the stack twice:
408 with binding SPECDECL (added when processing declarations)
409 and the actual value (added when processing bindings).
410 here we activate the SPECDECL bindings:
411 Find the SPECDECL binding for the symbol
412 > spec_pointer & spec_count are returned by make_variable_frame()
413 < return the pointer to the flags (or symbol+flags)
414 i.e., something suitable to SET_BIT,
415 or NULL if no such binding is found */
specdecled_(object symbol,gcv_object_t * spec_pointer,uintL spec_count)416 global gcv_object_t* specdecled_ (object symbol, gcv_object_t* spec_pointer,
417 uintL spec_count) {
418 spec_pointer = STACKpointable(spec_pointer);
419 do {
420 spec_pointer skipSTACKop -varframe_binding_size;
421 if (
422 #ifdef NO_symbolflags
423 eq(*(spec_pointer STACKop varframe_binding_sym),symbol)
424 && eq(*(spec_pointer STACKop varframe_binding_mark),Fixnum_0)
425 #else
426 eq(*(spec_pointer STACKop varframe_binding_sym),symbol_without_flags(symbol))
427 #endif
428 && eq(*(spec_pointer STACKop varframe_binding_value),specdecl))
429 return spec_pointer STACKop varframe_binding_mark;
430 } while (--spec_count);
431 return NULL;
432 }
433
434 /* UP for LET, LET*, LOCALLY, MULTIPLE-VALUE-BIND, SYMBOL-MACROLET:
435 Analyzes the variables and declarations, builds up a variable binding-
436 frame and extends VENV and possibly also DENV by a frame.
437 make_variable_frame(caller,varspecs,&bind_ptr,&bind_count,&spec_ptr,&spec_count)
438 > object caller: Caller, a symbol
439 > object varspecs: list of variable-specifiers
440 > object value2: list of declaration-specifiers
441 > object value1: list ({form}) of forms
442 < stack layout: variable binding frame, Env-binding-frame, ({form}).
443 < gcv_object_t* bind_ptr: pointer to the first "genuine" binding.
444 < uintC bind_count: number of "genuine" bindings.
445 < gcv_object_t* spec_ptr: pointer to the first SPECDECL binding.
446 < uintC spec_count: number of SPECDECL bindings.
447 changes STACK (STACK_0<-value1=({form}) + bindings requiring 2 unwind calls)
448 can trigger GC */
make_variable_frame(object caller,object varspecs,gcv_object_t ** bind_ptr_,uintC * bind_count_,gcv_object_t ** spec_ptr_,uintC * spec_count_)449 local /*maygc*/ void make_variable_frame
450 (object caller, object varspecs, gcv_object_t** bind_ptr_, uintC* bind_count_,
451 gcv_object_t** spec_ptr_, uintC* spec_count_)
452 {
453 GCTRIGGER4(caller,varspecs,value1,value2);
454 var object declarations = value2;
455 { /* build up variable binding frame: */
456 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
457 /* First. store the special-declared and impdependent-declared
458 variables from declarations in the stack: */
459 var gcv_object_t* spec_pointer = args_end_pointer;
460 var uintL spec_count = 0; /* number of SPECIAL-references */
461 {
462 var object declspecs = declarations;
463 while (consp(declspecs)) {
464 var object declspec = Car(declspecs); /* next declaration */
465 if (consp(declspec)) {
466 var object decl_identifier = Car(declspec);
467 if (eq(decl_identifier,S(special)) || eq(decl_identifier,S(implementation_dependent))) { /* (SPECIAL ) or (SYS::IMPLEMENTATION-DEPENDENT ) */
468 while (consp( declspec = Cdr(declspec) )) {
469 var object declsym = Car(declspec); /* next declared item */
470 if (!symbolp(declsym)) { /* should be a symbol */
471 pushSTACK(value1); pushSTACK(value2); /* save */
472 pushSTACK(caller); pushSTACK(varspecs); /* save */
473 pushSTACK(declarations); pushSTACK(declspecs); /* save */
474 pushSTACK(decl_identifier); /* save */
475 pushSTACK(declspec); /* save */
476 declsym = check_symbol_in_declaration(declsym,Car(declspec),caller);
477 declspec = popSTACK(); /* restore */
478 Car(declspec) = declsym;
479 decl_identifier = popSTACK(); /* restore */
480 declspecs = popSTACK(); declarations = popSTACK(); /* restore */
481 varspecs = popSTACK(); caller = popSTACK(); /* restore */
482 value2 = popSTACK(); value1 = popSTACK(); /* restore */
483 }
484 if (eq(decl_identifier,S(special))) {
485 /* store special-declared symbol in stack: */
486 pushSTACK(specdecl); /* #<SPECDECL> as "value" */
487 pushSTACK_symbolwithflags(declsym,0); /* Symbol inactive */
488 #if defined(MULTITHREAD)
489 /* this is locally declared special variable. make it per thread
490 if not already.*/
491 if (TheSymbol(declsym)->tls_index == SYMBOL_TLS_INDEX_NONE) {
492 /* this call is may gc now */
493 pushSTACK(value1); pushSTACK(value2); /* save */
494 pushSTACK(caller); pushSTACK(varspecs); /* save */
495 pushSTACK(declarations); pushSTACK(declspecs); /* save */
496 pushSTACK(decl_identifier); pushSTACK(declspec); /* save */
497 add_per_thread_special_var(declsym);
498 declspec = popSTACK(); decl_identifier = popSTACK(); /* restore */
499 declspecs = popSTACK(); declarations = popSTACK(); /* restore */
500 varspecs = popSTACK(); caller = popSTACK(); /* restore */
501 value2 = popSTACK(); value1 = popSTACK(); /* restore */
502 }
503 #endif
504 } else if (eq(decl_identifier,S(implementation_dependent))) {
505 /* store impdependent-declared symbol in stack: */
506 pushSTACK(impdependent); /* #<IMPLEMENTATION-DEPENDENT> as "value" */
507 pushSTACK_symbolwithflags(declsym,wbit(active_bit_o)); /* Symbol active */
508 }
509 check_STACK();
510 spec_count++;
511 }
512 }
513 }
514 declspecs = Cdr(declspecs);
515 }
516 *spec_count_ = spec_count;
517 *spec_ptr_ = spec_pointer;
518 }
519 *bind_ptr_ = args_end_pointer; /* pointer to first "genuine" binding */
520 { /* Then store the "genuine" variable bindings (the variable
521 and its unevaluated init at a time) in the stack: */
522 var uintL var_count = 0; /* number of variable bindings */
523 {
524 while (consp(varspecs)) {
525 var object varspec = Car(varspecs); /* next varspec */
526 /* split up in symbol and init: */
527 var object symbol;
528 var object init;
529 retry_check_varspec:
530 if (symbolp(varspec) && !eq(caller,S(symbol_macrolet))) {
531 symbol = varspec; init = unbound;
532 } else if /* one-/two-element list, with symbol as CAR ? */
533 (consp(varspec)
534 && !eq(caller, S(multiple_value_bind))
535 && (symbol = Car(varspec), varspec = Cdr(varspec),
536 symbolp(symbol)
537 && ( /* two elements? */
538 (consp(varspec) && nullp(Cdr(varspec))
539 && (init = Car(varspec), true))
540 || /* one-element (allowed at LET, LET* according to X3J13 vote <182> ) */
541 (nullp(varspec) && !eq(caller,S(symbol_macrolet))
542 && (init = NIL, true))))) {
543 /* now init = Car(varspec) or = NIL */
544 } else {
545 pushSTACK(value1); pushSTACK(value2); /* save */
546 pushSTACK(caller); pushSTACK(declarations); /* save */
547 pushSTACK(varspecs); /* save */
548 varspec = check_varspec(Car(varspecs),caller);
549 varspecs = popSTACK(); Car(varspecs) = varspec; /* restore */
550 declarations = popSTACK(); caller = popSTACK(); /* restore */
551 value2 = popSTACK(); value1 = popSTACK(); /* restore */
552 goto retry_check_varspec;
553 }
554 pushSTACK(init); /* init and */
555 pushSTACK_symbolwithflags(symbol,0); /* store variable */
556 check_STACK();
557 /* determine, if static or dynamic binding: */
558 var bool specdecled = /* variable is declared special? */
559 (specdecled_p(symbol,spec_pointer,spec_count) != NULL);
560 if (eq(caller,S(symbol_macrolet))) {
561 if (special_var_p(TheSymbol(symbol))) {
562 pushSTACK(symbol);
563 pushSTACK(caller);
564 error(program_error,GETTEXT("~S: symbol ~S has been declared SPECIAL and may not be re-defined as a SYMBOL-MACRO"));
565 }
566 if (specdecled) {
567 pushSTACK(symbol); /* SOURCE-PROGRAM-ERROR slot DETAIL */
568 pushSTACK(symbol); pushSTACK(caller);
569 error(source_program_error,GETTEXT("~S: symbol ~S must not be declared SPECIAL and defined a SYMBOL-MACRO at the same time"));
570 }
571 /* static binding */
572 } else {
573 if (constant_var_p(TheSymbol(symbol))) {
574 pushSTACK(value1); pushSTACK(value2); /* save */
575 pushSTACK(caller); pushSTACK(varspecs); /* save */
576 pushSTACK(declarations);
577 symbol = check_symbol_non_constant(symbol,caller);
578 declarations = popSTACK(); varspecs = popSTACK(); /* restore */
579 caller = popSTACK();
580 value2 = popSTACK(); value1 = popSTACK(); /* restore */
581 ASSERT(!constant_var_p(TheSymbol(symbol)));
582 STACK_(varframe_binding_sym) = symbol;
583 }
584 if (specdecled || special_var_p(TheSymbol(symbol))) {
585 /* bind dynamically */
586 #if (varframe_binding_mark == varframe_binding_sym)
587 STACK_(varframe_binding_mark) = SET_BIT(symbol,dynam_bit_o);
588 #else
589 STACK_(varframe_binding_mark) = SET_BIT(Fixnum_0,dynam_bit_o);
590 #endif
591 } else {
592 /* bind statically */
593 }
594 }
595 varspecs = Cdr(varspecs);
596 var_count++;
597 }
598 }
599 *bind_count_ = var_count;
600 var_count += spec_count; /* total number of symbol/value pairs */
601 if (var_count > (uintC)(~(uintC)0)) { /* does it fit into a uintC ? */
602 pushSTACK(unbound); /* SOURCE-PROGRAM-ERROR slot DETAIL */
603 pushSTACK(caller);
604 error(source_program_error,
605 GETTEXT("~S: too many variables and/or declarations"));
606 }
607 pushSTACK(aktenv.var_env); /* current VAR_ENV as NEXT_ENV */
608 pushSTACK(fake_gcv_object(var_count)); /* number of bindings */
609 finish_frame(VAR);
610 }
611 }
612 /* The variable binding frame is now finished. */
613 var gcv_object_t* var_frame_ptr = STACK; /* pointer to variable binding frame */
614 { /* build up VENV binding frame: */
615 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
616 /* first extend DENV by the necessary declspecs: */
617 var object denv = aktenv.decl_env;
618 pushSTACK(value1); /* save ({form}) */
619 pushSTACK(declarations);
620 while (mconsp(STACK_0)) {
621 var object declspecs = STACK_0;
622 STACK_0 = Cdr(declspecs);
623 var object declspec = Car(declspecs); /* next Declspec */
624 if (consp(declspec)) { /* should be a cons */
625 if (!eq(Car(declspec),S(special))) /* we have treated (SPECIAL ...) already */
626 denv = augment_decl_env(declspec,denv); /* process everything else */
627 }
628 }
629 skipSTACK(1);
630 var object forms = popSTACK();
631 /* now build the frame: */
632 if (eq(denv,aktenv.decl_env)) {
633 pushSTACK(aktenv.var_env);
634 finish_frame(ENV1V);
635 } else {
636 pushSTACK(aktenv.decl_env);
637 pushSTACK(aktenv.var_env);
638 finish_frame(ENV2VD);
639 aktenv.decl_env = denv;
640 }
641 /* VENV-binding frame is finished. */
642 aktenv.var_env = make_framepointer(var_frame_ptr); /* pointer to variable binding frame */
643 pushSTACK(forms);
644 }
645 }
646
647 /* activate the bindings created by make_variable_frame()
648 > frame_pointer, count: values returned from make_variable_frame()
649 count must be positive */
activate_bindings(gcv_object_t * frame_pointer,uintC count)650 local void activate_bindings (gcv_object_t* frame_pointer, uintC count) {
651 do {
652 frame_pointer skipSTACKop -varframe_binding_size;
653 var gcv_object_t* markptr = &Before(frame_pointer);
654 if (as_oint(*markptr) & wbit(dynam_bit_o)) { /* binding dynamic? */
655 var object symbol = *(markptr STACKop varframe_binding_sym); /* variable */
656 var object newval = *(markptr STACKop varframe_binding_value); /* new value */
657 *(markptr STACKop varframe_binding_value) = Symbolflagged_value(symbol); /* save old value in frame */
658 Symbolflagged_value(symbol) = newval; /* new value */
659 }
660 *markptr = SET_BIT(*markptr,active_bit_o); /* activate binding */
661 } while (--count);
662 }
663 /* activate all SPECDECL declarations */
activate_specdecls(gcv_object_t * spec_ptr,uintC spec_count)664 global void activate_specdecls (gcv_object_t* spec_ptr, uintC spec_count) {
665 do {
666 spec_ptr skipSTACKop -varframe_binding_size;
667 var gcv_object_t* markptr = &Before(spec_ptr);
668 *markptr = SET_BIT(*markptr,active_bit_o); /* activate binding */
669 } while (--spec_count);
670 }
671
672 LISPSPECFORM(let, 1,0,body)
673 { /* (LET ({varspec}) {decl} {form}), CLTL p. 110 */
674 /* separate {decl} {form}: */
675 var object compile_name = parse_doc_decl(STACK_0,false);
676 if (!eq(Fixnum_0,compile_name)) { /* declaration (COMPILE) ? */
677 /* yes -> compile form: */
678 skipSTACK(2); return_Values compile_eval_form(compile_name);
679 } else {
680 skipSTACK(1);
681 /* build variable binding frame, extend VAR_ENV : */
682 var gcv_object_t *bind_ptr, *spec_ptr;
683 var uintC bind_count, spec_count;
684 make_variable_frame(S(let),popSTACK(),&bind_ptr,&bind_count,
685 &spec_ptr,&spec_count);
686 if (bind_count > 0) {
687 { /* Then, evaluate the initialization forms: */
688 var gcv_object_t* frame_pointer = bind_ptr;
689 var uintC count = bind_count;
690 do {
691 var gcv_object_t* initptr = &NEXT(frame_pointer);
692 var object init = *initptr; /* next init */
693 *initptr = (!boundp(init) ? NIL : (eval(init),value1)); /* evaluate, NIL as default */
694 frame_pointer skipSTACKop -(varframe_binding_size-1);
695 } while (--count);
696 }
697 activate_bindings(bind_ptr,bind_count);
698 }
699 if (spec_count > 0) activate_specdecls(spec_ptr,spec_count);
700 /* interpret body: */
701 implicit_progn(popSTACK(),NIL);
702 /* unwind frames: */
703 unwind(); /* unwind VENV binding frame */
704 unwind(); /* unwind variable binding frame */
705 }
706 }
707
708 LISPSPECFORM(letstar, 1,0,body)
709 { /* (LET* ({varspec}) {decl} {form}), CLTL p. 111 */
710 /* separate {decl} {form} : */
711 var object compile_name = parse_doc_decl(STACK_0,false);
712 if (!eq(Fixnum_0,compile_name)) { /* declaration (COMPILE) ? */
713 /* yes -> compile form: */
714 skipSTACK(2); return_Values compile_eval_form(compile_name);
715 } else {
716 skipSTACK(1);
717 /* build variable binding frame, extend VAR_ENV : */
718 var gcv_object_t *bind_ptr, *spec_ptr;
719 var uintC bind_count, spec_count;
720 make_variable_frame(S(letstar),popSTACK(),&bind_ptr,&bind_count,
721 &spec_ptr,&spec_count);
722 /* Then, evaluate the initialization forms and activate the bindings */
723 if (bind_count > 0) {
724 var gcv_object_t* frame_pointer = bind_ptr;
725 var uintC count = bind_count;
726 do {
727 var gcv_object_t* initptr = &Next(frame_pointer);
728 frame_pointer skipSTACKop -varframe_binding_size;
729 var gcv_object_t* markptr = &Before(frame_pointer);
730 var object init = *initptr; /* next init */
731 var object newval = (!boundp(init) ? NIL : (eval(init),value1)); /* evaluate, NIL as default */
732 if (as_oint(*markptr) & wbit(dynam_bit_o)) { /* binding dynamic? */
733 var object symbol = *(markptr STACKop varframe_binding_sym); /* variable */
734 *initptr = Symbolflagged_value(symbol); /* save old value in frame */
735 Symbolflagged_value(symbol) = newval; /* new value */
736 activate_specdecl(symbol,spec_ptr,spec_count);
737 } else {
738 *initptr = newval; /* new value into the frame */
739 }
740 *markptr = SET_BIT(*markptr,active_bit_o); /* activate binding */
741 } while (--count);
742 }
743 if (spec_count > 0) activate_specdecls(spec_ptr,spec_count);
744 /* interpret body: */
745 implicit_progn(popSTACK(),NIL);
746 /* unwind frames: */
747 unwind(); /* unwind VENV-binding frame */
748 unwind(); /* unwind variable binding frame */
749 }
750 }
751
752 /* call make_variable_frame + activate_bindings + activate_specdecls
753 Analyzes the variables and declarations, builds up a variable binding-
754 frame and extends VENV and poss. also DENV by a frame.
755 make_vframe_activate(void)
756 call it after parse_doc_decl, then the inputs are correct:
757 > object value2: list of declaration-specifiers
758 > object value1: list ({form}) of forms
759 changes STACK (STACK_0<-value1=({form}) + 2 bindings requiring 2 unwind calls)
760 can trigger GC */
make_vframe_activate(void)761 local /*maygc*/ void make_vframe_activate (void) {
762 GCTRIGGER2(value1,value2);
763 var gcv_object_t *bind_ptr, *spec_ptr;
764 var uintC bind_count, spec_count;
765 make_variable_frame(TheFsubr(subr_self)->name,NIL,&bind_ptr,&bind_count,
766 &spec_ptr,&spec_count);
767 if (bind_count) activate_bindings(bind_ptr,bind_count);
768 if (spec_count) activate_specdecls(spec_ptr,spec_count);
769 }
770
771 LISPSPECFORM(locally, 0,0,body)
772 { /* (LOCALLY {decl} {form}), CLTL2 p. 221 */
773 /* separate {decl} {form} : */
774 var object compile_name = parse_doc_decl(STACK_0,false);
775 skipSTACK(1);
776 if (!eq(Fixnum_0,compile_name)) { /* declaration (COMPILE) ? */
777 /* yes -> compile form: */
778 return_Values compile_eval_form(compile_name);
779 } else { /* build variable binding frame, extend VAR_ENV : */
780 make_vframe_activate();
781 /* interpret body: */
782 implicit_progn(popSTACK(),NIL);
783 /* unwind frames: */
784 unwind(); /* unwind VENV-binding frame */
785 unwind(); /* unwind variable binding frame */
786 }
787 }
788
789 LISPSPECFORM(compiler_let, 1,0,body)
790 { /* (COMPILER-LET ({varspec}) {form}), CLTL p. 112 */
791 var gcv_object_t* varspecs_ = &STACK_1;
792 var object varspecs = *varspecs_; /* list of variables */
793 var uintL varcount = llength(varspecs); /* number of variables */
794 get_space_on_STACK(varcount*3*sizeof(gcv_object_t));
795 /* evaluate varspecs: */
796 var gcv_object_t* val_pointer = args_end_pointer; /* pointer to values */
797 while (consp(varspecs)) {
798 var object varspec = Car(varspecs);
799 var object symbol;
800 retry_check_varspec:
801 if (consp(varspec)) { /* varspec is a Cons */
802 pushSTACK(varspec); pushSTACK(varspecs); /* save */
803 symbol = check_symbol_non_constant(Car(varspec),S(compiler_let));
804 varspecs = popSTACK(); varspec = popSTACK(); /* restore */
805 varspec = Cdr(varspec);
806 if (consp(varspec) && nullp(Cdr(varspec))) {
807 varspec = Car(varspec); /* Initform = second list element */
808 } else if (nullp(varspec)) { /* allowed by X3J13 vote <182> */
809 /* varspec = NIL; */ /* Initform = NIL */
810 } else {
811 pushSTACK(varspecs); /* save */
812 varspec = check_varspec(Car(varspecs),S(compiler_let));
813 varspecs = popSTACK(); Car(varspecs) = varspec; /* restore */
814 goto retry_check_varspec;
815 }
816 pushSTACK(Cdr(varspecs));
817 eval_noenv(varspec); /* evaluate initform */
818 varspecs = STACK_0;
819 STACK_0 = value1; /* and into the stack */
820 } else {
821 pushSTACK(varspecs); /* save */
822 symbol = check_symbol_non_constant(varspec,S(compiler_let));
823 varspecs = popSTACK(); /* restore */
824 pushSTACK(NIL); /* NIL as value into the stack */
825 varspecs = Cdr(varspecs);
826 }
827 }
828 varspecs = *varspecs_;
829 { /* build Frame: */
830 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
831 while (consp(varspecs)) {
832 var object varspec = Car(varspecs);
833 if (consp(varspec))
834 varspec = Car(varspec);
835 pushSTACK(Symbol_thread_value(varspec)); /* old value of the variables */
836 pushSTACK(varspec); /* variable */
837 varspecs = Cdr(varspecs);
838 }
839 finish_frame(DYNBIND);
840 }
841 /* frame finished, now change the values of the variables: */
842 varspecs = *varspecs_;
843 {
844 var gcv_object_t* valptr = val_pointer;
845 while (consp(varspecs)) {
846 var object varspec = Car(varspecs);
847 if (consp(varspec))
848 varspec = Car(varspec);
849 Symbol_thread_value(varspec) = NEXT(valptr); /* assign new value to the variables */
850 varspecs = Cdr(varspecs);
851 }
852 }
853 /* now evaluate the forms: */
854 implicit_progn(*(varspecs_ STACKop -1),NIL);
855 /* unwind binding frame: */
856 unwind();
857 /* clean up stack: */
858 set_args_end_pointer(val_pointer);
859 skipSTACK(2);
860 }
861
862 LISPSPECFORM(progv, 2,0,body)
863 { /* (PROGV symbollist valuelist {form}), CLTL p. 112 */
864 STACK_2 = (eval(STACK_2),value1); /* evaluate symbol list */
865 var object valuelist = (eval(STACK_1),value1); /* evaluate value list */
866 var object varlist = STACK_2;
867 STACK_2 = STACK_0; /* save body */
868 skipSTACK(2);
869 var gcv_object_t *body_ = &STACK_0;
870 progv(varlist,valuelist); /* build frame */
871 implicit_progn(*body_,NIL); /* evaluate body */
872 unwind(); /* unwind frame */
873 skipSTACK(1); /* drop body */
874 }
875
876 /* error-message at FLET/LABELS, if there is no function specification.
877 > caller: Caller, a symbol
878 > obj: erroneous function specification */
error_funspec(object caller,object obj)879 local _Noreturn void error_funspec (object caller, object obj) {
880 pushSTACK(obj); /* SOURCE-PROGRAM-ERROR slot DETAIL */
881 pushSTACK(obj); pushSTACK(caller);
882 error(source_program_error,GETTEXT("~S: ~S is not a function specification"));
883 }
884
885 /* UP: Finishes a FLET/MACROLET.
886 finish_flet(top_of_frame,body,ignore_declarations);
887 > stack layout: [top_of_frame] def1 name1 ... defn namen [STACK]
888 > top_of_frame: pointer to frame
889 > body: list of forms
890 > accept_declarations: flag: if true, declarations are respected
891 (for FLET & MACROLET), otherwise C_declare barfs (for FUNCTION-MACRO-LET)
892 < mv_count/mv_space: values
893 can trigger GC */
finish_flet(gcv_object_t * top_of_frame,object body,bool accept_declarations)894 local maygc Values finish_flet (gcv_object_t* top_of_frame, object body,
895 bool accept_declarations) {
896 {
897 var uintL bindcount = /* number of bindings */
898 STACK_item_count(STACK,top_of_frame) / 2;
899 pushSTACK(aktenv.fun_env); /* current FUN_ENV as NEXT_ENV */
900 pushSTACK(fake_gcv_object(bindcount));
901 finish_frame(FUN);
902 }
903 /* function binding frame is finished.
904 build FENV-binding frame: */
905 {
906 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
907 pushSTACK(aktenv.fun_env);
908 finish_frame(ENV1F);
909 /* FENV-binding frame is finished.
910 extend FUN_ENV:
911 top_of_frame = pointer to the function binding frame */
912 aktenv.fun_env = make_framepointer(top_of_frame);
913 }
914 /* allow declarations, as per ANSI CL */
915 if (accept_declarations) {
916 parse_doc_decl(body,false); /* ignore to_compile */
917 make_vframe_activate();
918 body = popSTACK();
919 }
920 /* execute forms: */
921 implicit_progn(body,NIL);
922 if (accept_declarations) {
923 unwind(); /* unwind VENV-binding frame */
924 unwind(); /* unwind variable binding frame */
925 }
926 unwind(); /* unwind FENV binding frame */
927 unwind(); /* unwind function binding frame */
928 }
929
930 LISPSPECFORM(flet, 1,0,body)
931 { /* (FLET ({funspec}) {form}), CLTL p. 113 */
932 var object body = popSTACK(); /* ({form}) */
933 var object funspecs = popSTACK(); /* ({funspec}) */
934 /* build function binding frame: */
935 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
936 while (consp(funspecs)) {
937 pushSTACK(body); /* save form list */
938 pushSTACK(Cdr(funspecs)); /* remaining funspecs */
939 funspecs = Car(funspecs); /* next funspec = (name . lambdabody) */
940 /* should be a cons, whose CAR is a symbol and whose CDR is a cons: */
941 if (!consp(funspecs)) {
942 error_spec:
943 error_funspec(S(flet),funspecs);
944 }
945 var object name = Car(funspecs);
946 if (!funnamep(name)) {
947 pushSTACK(funspecs);
948 name = check_funname_replacement(source_program_error,S(flet),name);
949 funspecs = popSTACK();
950 }
951 var object lambdabody = Cdr(funspecs);
952 if (!consp(lambdabody))
953 goto error_spec;
954 pushSTACK(name); /* save name */
955 /* turn lambdabody into a closure: */
956 var object fun = get_closure(lambdabody,name,true,&aktenv);
957 name = popSTACK();
958 funspecs = popSTACK(); /* remaining funspecs */
959 body = popSTACK();
960 /* into the frame: */
961 pushSTACK(fun); /* as "value" the closure */
962 pushSTACK(name); /* name, binding is automatically active */
963 }
964 return_Values finish_flet(top_of_frame,body,true);
965 }
966
967 LISPSPECFORM(labels, 1,0,body)
968 { /* (LABELS ({funspec}) {form}), CLTL p. 113 */
969 /* We can dispense with the construction of a function binding frame,
970 because when creating the first closure, the environment is nested anyway
971 and thereby this function binding frame would be written into a vector.
972 nest the current FUN_ENV: */
973 pushSTACK(nest_fun(aktenv.fun_env));
974 /* determine the number of funspecs and test the syntax: */
975 var uintL veclength = 1; /* = 2 * (number of funspecs) + 1 */
976 {
977 pushSTACK(STACK_(1+1)); /* funspecs */
978 while (consp(STACK_0)) {
979 var object funspec = Car(STACK_0);
980 /* should be a cons, whose CAR is a symbol and whose CDR is a cons: */
981 if (!consp(funspec)) {
982 error_spec:
983 error_funspec(S(labels),funspec);
984 }
985 var object name = Car(funspec);
986 if (!funnamep(name)) {
987 pushSTACK(funspec);
988 name = check_funname_replacement(source_program_error,S(labels),name);
989 funspec = popSTACK();
990 }
991 var object lambdabody = Cdr(funspec);
992 if (!consp(lambdabody))
993 goto error_spec;
994 STACK_0 = Cdr(STACK_0);
995 veclength += 2;
996 }
997 skipSTACK(1); /* funspecs */
998 }
999 /* allocate vector of suitable length and store the names: */
1000 var object vec = allocate_vector(veclength);
1001 {
1002 var gcv_object_t* ptr = &TheSvector(vec)->data[0];
1003 var object funspecs = STACK_(1+1);
1004 while (consp(funspecs)) {
1005 *ptr++ = Car(Car(funspecs)); /* next name */
1006 ptr++; /* function remains NIL for the time being */
1007 funspecs = Cdr(funspecs);
1008 }
1009 *ptr++ = popSTACK(); /* nested FUN_ENV as last vector-element */
1010 }
1011 var object body = popSTACK(); /* form list */
1012 var object funspecs = popSTACK();
1013 { /* build FENV binding frame: */
1014 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
1015 pushSTACK(aktenv.fun_env);
1016 finish_frame(ENV1F);
1017 }
1018 /* extend FUN_ENV: */
1019 aktenv.fun_env = vec;
1020 /* create closures and put into the vector: */
1021 pushSTACK(body);
1022 pushSTACK(vec);
1023 {
1024 var uintL index = 1; /* index into the vector */
1025 while (consp(funspecs)) {
1026 pushSTACK(Cdr(funspecs)); /* remaining funspecs */
1027 var object funspec = Car(funspecs);
1028 /* create closure: */
1029 var object fun = get_closure(Cdr(funspec),Car(funspec),true,&aktenv);
1030 funspecs = popSTACK();
1031 TheSvector(STACK_0)->data[index] = fun; /* put into the vector */
1032 index += 2;
1033 }
1034 }
1035 skipSTACK(1); /* forget vector */
1036 /* allow declarations, as per ANSI CL */
1037 parse_doc_decl(popSTACK(),false); /* ignore to_compile */
1038 make_vframe_activate();
1039 /* execute forms: */
1040 implicit_progn(popSTACK(),NIL);
1041 unwind(); /* unwind VENV-binding frame */
1042 unwind(); /* unwind variable binding frame */
1043 unwind(); /* unwind FENV binding frame */
1044 }
1045
1046 LISPSPECFORM(macrolet, 1,0,body)
1047 { /* (MACROLET ({macrodef}) {form}), CLTL p. 113 */
1048 var object body = popSTACK(); /* ({form}) */
1049 var object macrodefs = popSTACK(); /* ({macrodef}) */
1050 /* build macrobinding frame: */
1051 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
1052 while (consp(macrodefs)) {
1053 pushSTACK(body); /* save form list */
1054 pushSTACK(Cdr(macrodefs)); /* remaining macrodefs */
1055 macrodefs = Car(macrodefs); /* next macrodef = (name . lambdabody) */
1056 /* should be a cons, whose CAR is a symbol and whose CDR is a cons: */
1057 if (!consp(macrodefs)) {
1058 error_spec:
1059 pushSTACK(macrodefs); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1060 pushSTACK(macrodefs); pushSTACK(S(macrolet));
1061 error(source_program_error,
1062 GETTEXT("~S: ~S is not a macro specification"));
1063 }
1064 var object name = Car(macrodefs);
1065 if (!symbolp(name)) {
1066 pushSTACK(name); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1067 pushSTACK(name); pushSTACK(S(macrolet));
1068 error(source_program_error,
1069 GETTEXT("~S: macro name ~S should be a symbol"));
1070 }
1071 if (!mconsp(Cdr(macrodefs)))
1072 goto error_spec;
1073 pushSTACK(name); /* save */
1074 /* build macro-expander: (SYSTEM::MAKE-MACRO-EXPANDER macrodef nil env) */
1075 pushSTACK(macrodefs);
1076 pushSTACK(NIL);
1077 {
1078 aktenv_to_stack();
1079 { /* Add a MACROLET cons to the venv part of env: */
1080 var object new_cons = allocate_cons();
1081 Car(new_cons) = S(macrolet); Cdr(new_cons) = STACK_4;
1082 STACK_4 = new_cons;
1083 }
1084 { /* Add a MACROLET cons to the fenv part of env: */
1085 var object new_cons = allocate_cons();
1086 Car(new_cons) = S(macrolet); Cdr(new_cons) = STACK_3;
1087 STACK_3 = new_cons;
1088 }
1089 var object vec = vectorof(5);
1090 pushSTACK(vec);
1091 }
1092 funcall(S(make_macro_expander),3);
1093 name = popSTACK();
1094 macrodefs = popSTACK(); /* remaining macrodefs */
1095 body = popSTACK();
1096 /* into the frame: */
1097 pushSTACK(value1); /* as "value" the cons with the expander */
1098 pushSTACK(name); /* name, binding is automatically active */
1099 }
1100 return_Values finish_flet(top_of_frame,body,true);
1101 }
1102
1103 LISPSPECFORM(function_macro_let, 1,0,body)
1104 { /* (SYSTEM::FUNCTION-MACRO-LET ({(name fun-lambdabody macro-full-lambdabody)})
1105 {form})
1106 is similar to FLET, except that alternative macro definitions
1107 are provided for every function. */
1108 var object body = popSTACK(); /* ({form}) */
1109 var object funmacspecs = popSTACK(); /* {(name fun-lambdabody macro-full-lambdabody)} */
1110 /* build FunctionMacro bindings frame : */
1111 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
1112 while (consp(funmacspecs)) {
1113 pushSTACK(body); /* save form list */
1114 pushSTACK(Cdr(funmacspecs)); /* remaining funmacspecs */
1115 funmacspecs = Car(funmacspecs);
1116 /* next (name fun-lambdabody macro-lambdabody) should be
1117 a list of length 3, whose CAR is a symbol
1118 and whose further list elements are conses: */
1119 if (!consp(funmacspecs)) {
1120 error_spec:
1121 pushSTACK(funmacspecs); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1122 pushSTACK(funmacspecs); pushSTACK(S(function_macro_let));
1123 error(source_program_error,
1124 GETTEXT("~S: ~S is not a function and macro specification"));
1125 }
1126 var object name = Car(funmacspecs);
1127 if (!symbolp(name)) {
1128 pushSTACK(name); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1129 pushSTACK(name); pushSTACK(S(function_macro_let));
1130 error(source_program_error,
1131 GETTEXT("~S: function and macro name ~S should be a symbol"));
1132 }
1133 if (!(mconsp(Cdr(funmacspecs)) && mconsp(Car(Cdr(funmacspecs)))
1134 && mconsp(Cdr(Cdr(funmacspecs)))
1135 && mconsp(Car(Cdr(Cdr(funmacspecs))))
1136 && nullp(Cdr(Cdr(Cdr(funmacspecs))))))
1137 goto error_spec;
1138 pushSTACK(name); /* save name */
1139 pushSTACK(Car(Cdr(funmacspecs))); /* fun-lambdabody */
1140 pushSTACK(Car(Cdr(Cdr(funmacspecs)))); /* macro-full-lambdabody */
1141 /* turn fun-lambdabody into a closure: */
1142 STACK_1 = get_closure(STACK_1,name,false,&aktenv);
1143 { /* build macro-expander:
1144 (SYSTEM::MAKE-FUNMACRO-EXPANDER name macro-full-lambdabody) */
1145 pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); funcall(S(make_funmacro_expander),2);
1146 pushSTACK(value1); C_macro_expander();
1147 STACK_0 = value1;
1148 }
1149 /* collect both: */
1150 C_make_function_macro();
1151 name = popSTACK();
1152 funmacspecs = popSTACK(); /* remaining funmacspecs */
1153 body = popSTACK();
1154 /* into the Frame: */
1155 pushSTACK(value1); /* as "value" the FunctionMacro */
1156 pushSTACK(name); /* name, binding is automatically active */
1157 }
1158 return_Values finish_flet(top_of_frame,body,false);
1159 }
1160
1161 LISPSPECFORM(symbol_macrolet, 1,0,body)
1162 { /* (SYMBOL-MACROLET ({(var expansion)}) {decl} {form}), CLTL2 p. 155 */
1163 /* separate {decl} {form} : */
1164 var object compile_name = parse_doc_decl(STACK_0,false);
1165 if (!eq(Fixnum_0,compile_name)) { /* declaration (COMPILE) ? */
1166 /* yes -> compile form: */
1167 skipSTACK(2); return_Values compile_eval_form(compile_name);
1168 } else {
1169 skipSTACK(1);
1170 /* build variable binding frame, extend VAR_ENV : */
1171 var gcv_object_t *bind_ptr, *spec_ptr;
1172 var uintC bind_count, spec_count;
1173 make_variable_frame(S(symbol_macrolet),popSTACK(),&bind_ptr,&bind_count,
1174 &spec_ptr,&spec_count);
1175 /* then form the symbol-macros and activate the bindings: */
1176 if (bind_count > 0) {
1177 var gcv_object_t* frame_pointer = bind_ptr;
1178 var uintC count = bind_count;
1179 do {
1180 var gcv_object_t* initptr = &NEXT(frame_pointer);
1181 var object sm = allocate_symbolmacro();
1182 TheSymbolmacro(sm)->symbolmacro_expansion = *initptr;
1183 *initptr = sm;
1184 frame_pointer skipSTACKop -(varframe_binding_size-1);
1185 Before(frame_pointer) = SET_BIT(Before(frame_pointer),active_bit_o);
1186 } while (--count);
1187 }
1188 if (spec_count) activate_specdecls(spec_ptr,spec_count);
1189 /* interpret body: */
1190 implicit_progn(popSTACK(),NIL);
1191 /* unwind frames: */
1192 unwind(); /* unwind VENV-binding frame */
1193 unwind(); /* unwind variable-binding-frame */
1194 }
1195 }
1196
1197 LISPSPECFORM(if, 2,1,nobody)
1198 { /* (IF test form1 [form2]), CLTL p. 115 */
1199 eval(STACK_2); /* evaluate condition */
1200 var object form;
1201 if (!nullp(value1)) {
1202 form = STACK_1; skipSTACK(3); /* evaluate form1 */
1203 } else {
1204 form = STACK_0; skipSTACK(3); /* evaluate form2 */
1205 if (!boundp(form)) {
1206 VALUES1(NIL); return; /* not supplied -> NIL */
1207 }
1208 }
1209 eval(form);
1210 }
1211
1212 LISPSPECFORM(when, 1,0,body)
1213 { /* (WHEN test {form}), CLTL p. 115 */
1214 eval(STACK_1); /* evaluate condition */
1215 if (!nullp(value1)) {
1216 var object body = STACK_0;
1217 skipSTACK(2);
1218 implicit_progn(body,NIL);
1219 } else {
1220 skipSTACK(2);
1221 VALUES1(NIL);
1222 }
1223 }
1224
1225 LISPSPECFORM(unless, 1,0,body)
1226 { /* (UNLESS test {form}), CLTL p. 115 */
1227 eval(STACK_1); /* evaluate condition */
1228 if (nullp(value1)) {
1229 var object body = STACK_0;
1230 skipSTACK(2);
1231 implicit_progn(body,NIL);
1232 } else {
1233 skipSTACK(2);
1234 VALUES1(NIL);
1235 }
1236 }
1237
1238 LISPSPECFORM(cond, 0,0,body)
1239 { /* (COND {(bed {form})}), CLTL p. 116 */
1240 while (mconsp(STACK_0)) {
1241 var object clause = STACK_0; /* clause-list */
1242 STACK_0 = Cdr(clause); /* save remaining clauses */
1243 clause = Car(clause); /* next clause */
1244 if (!consp(clause)) { /* should be a cons */
1245 pushSTACK(clause); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1246 pushSTACK(clause); pushSTACK(S(cond));
1247 error(source_program_error,GETTEXT("~S: clause ~S should be a list"));
1248 }
1249 pushSTACK(Cdr(clause)); /* save clause rest */
1250 eval(Car(clause)); /* evaluate condition */
1251 if (!nullp(value1))
1252 goto eval_clause;
1253 skipSTACK(1); /* try next */
1254 }
1255 /* no condition was satisfied. */
1256 VALUES1(NIL); skipSTACK(1); return;
1257 eval_clause: { /* found a true condition: */
1258 var object clause_rest = popSTACK(); /* clause rest */
1259 skipSTACK(1);
1260 implicit_progn(clause_rest,value1); /* evaluate */
1261 }
1262 }
1263
1264 LISPSPECFORM(case, 1,0,body)
1265 { /* (CASE keyform {(keys {form})}), CLTL p. 117 */
1266 eval(STACK_1); /* evaluate keyform */
1267 var object value = value1;
1268 var object clauses = STACK_0;
1269 var object clause;
1270 skipSTACK(2);
1271 while (consp(clauses)) {
1272 clause = Car(clauses); /* next clause */
1273 clauses = Cdr(clauses);
1274 if (!consp(clause)) { /* should be a cons */
1275 pushSTACK(clause); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1276 pushSTACK(clause); pushSTACK(S(case));
1277 error(source_program_error,GETTEXT("~S: missing key list: ~S"));
1278 }
1279 var object keys = Car(clause);
1280 if (eq(keys,T) || eq(keys,S(otherwise))) {
1281 if (nullp(clauses))
1282 goto eval_clause;
1283 pushSTACK(clauses); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1284 pushSTACK(keys); pushSTACK(S(case));
1285 error(source_program_error,
1286 GETTEXT("~S: the ~S clause must be the last one"));
1287 } else {
1288 if (listp(keys)) {
1289 while (consp(keys)) {
1290 if (eql(Car(keys),value))
1291 goto eval_clause;
1292 keys = Cdr(keys);
1293 }
1294 } else {
1295 if (eql(keys,value))
1296 goto eval_clause;
1297 }
1298 }
1299 }
1300 /* no condition was satisfied. */
1301 VALUES1(NIL); return;
1302 eval_clause: { /* found a true condition: */
1303 var object clause_rest = Cdr(clause); /* clause-rest */
1304 implicit_progn(clause_rest,NIL); /* evaluate */
1305 }
1306 }
1307
1308 LISPSPECFORM(block, 1,0,body)
1309 { /* (BLOCK name {form}), CLTL p. 119 */
1310 var object name = check_symbol(STACK_1);
1311 var object body = STACK_0; skipSTACK(2);
1312 var sp_jmp_buf returner; /* return point */
1313 { /* build block-frame: */
1314 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
1315 pushSTACK(name); /* block-name */
1316 pushSTACK(aktenv.block_env); /* current BLOCK_ENV as NEXT_ENV */
1317 finish_entry_frame(IBLOCK,returner,, goto block_return; );
1318 }
1319 { /* build BENV-frame: */
1320 var gcv_object_t* top_of_frame = STACK;
1321 pushSTACK(aktenv.block_env);
1322 finish_frame(ENV1B);
1323 /* extend BLOCK_ENV (top_of_frame = pointer to the block-frame) */
1324 aktenv.block_env = make_framepointer(top_of_frame);
1325 }
1326 /* execute body: */
1327 implicit_progn(body,NIL);
1328 unwind(); /* unwind BENV-binding frame */
1329 block_return: /* we jump to this label, if the BLOCK-Frame
1330 has caught a RETURN-FROM. */
1331 unwind(); /* unwind BLOCK-frame */
1332 }
1333
1334 /* error-message, if a block has already been left.
1335 error_block_left(name);
1336 > name: block-name */
error_block_left(object name)1337 global _Noreturn void error_block_left (object name) {
1338 pushSTACK(name);
1339 pushSTACK(S(return_from));
1340 error(control_error,GETTEXT("~S: the block named ~S has already been left"));
1341 }
1342
1343 LISPSPECFORM(return_from, 1,1,nobody)
1344 { /* (RETURN-FROM name [result]), CLTL p. 120 */
1345 var object name = check_symbol(STACK_1);
1346 /* traverse BLOCK_ENV: */
1347 var object env = aktenv.block_env; /* current BLOCK_ENV */
1348 var gcv_object_t* FRAME;
1349 while (framepointerp(env)) {
1350 /* env is a frame-pointer to a IBLOCK-frame in the stack. */
1351 FRAME = TheFramepointer(env);
1352 if (framecode(FRAME_(0)) & bit(nested_bit_t)) {
1353 /* frame already nested */
1354 env = FRAME_(frame_next_env); break;
1355 }
1356 if (eq(FRAME_(frame_name),name))
1357 goto found;
1358 env = FRAME_(frame_next_env);
1359 }
1360 /* env is an Alist. */
1361 while (consp(env)) {
1362 var object block_cons = Car(env);
1363 if (eq(Car(block_cons),name)) {
1364 env = Cdr(block_cons);
1365 if (eq(env,disabled)) /* block still active? */
1366 error_block_left(name);
1367 goto found;
1368 }
1369 env = Cdr(env);
1370 }
1371 { /* env is done. */
1372 pushSTACK(name); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1373 pushSTACK(name); pushSTACK(S(return_from));
1374 error(source_program_error,
1375 GETTEXT("~S: no block named ~S is currently visible"));
1376 }
1377 found: /* found block-frame: env */
1378 FRAME = uTheFramepointer(env); /* pointer to that frame */
1379 /* produce values, with which the block will be left: */
1380 var object result = popSTACK();
1381 skipSTACK(1);
1382 if (boundp(result)) { /* result supplied? */
1383 eval(result);
1384 } else {
1385 VALUES1(NIL);
1386 }
1387 /* jump to the found block-frame and unwind it: */
1388 unwind_upto(FRAME);
1389 }
1390
1391 /* UP: append LIST to the "accumulation set" STACK_1 (head)/STACK_0 (tail)
1392 set_last_inplace() is "NCONC"
1393 set_last_copy() is "APPEND" [can trigger GC]
1394 modifies */
set_last_inplace(object list)1395 local inline void set_last_inplace (object list) {
1396 if (!consp(STACK_0)) STACK_1=STACK_0=list; /* init */
1397 else Cdr(STACK_0) = list; /* insert as (cdr (last totallist)) */
1398 if (consp(list)) {
1399 var object list1;
1400 while (1) { /* list is a cons */
1401 list1 = Cdr(list);
1402 if (atomp(list1)) break;
1403 list = list1;
1404 }
1405 STACK_0 = list; /* (last totallist) <- (last list) */
1406 }
1407 }
set_last_copy(object list)1408 local inline maygc void set_last_copy (object list) {
1409 if (consp(list)) {
1410 pushSTACK(list);
1411 pushSTACK(allocate_cons());
1412 pushSTACK(STACK_0);
1413 /* stack layout: head, tail, list, copy, tail */
1414 Car(STACK_0) = Car(STACK_2);
1415 while (consp(Cdr(STACK_2))) {
1416 STACK_2 = Cdr(STACK_2);
1417 var object new_cons = allocate_cons();
1418 Cdr(STACK_0) = new_cons; STACK_0 = new_cons;
1419 Car(STACK_0) = Car(STACK_2);
1420 }
1421 Cdr(STACK_0) = Cdr(STACK_2); /* atom */
1422 if (!consp(STACK_(0+3))) {
1423 STACK_(1+3) = STACK_1; /* init head */
1424 STACK_(0+3) = STACK_0; /* init tail */
1425 } else {
1426 Cdr(STACK_(0+3)) = STACK_1; /* insert as (cdr (last totallist)) */
1427 STACK_(0+3) = STACK_0;
1428 }
1429 skipSTACK(3);
1430 } else {
1431 if (!consp(STACK_0)) STACK_1=STACK_0=list; /* init */
1432 else Cdr(STACK_0) = list; /* insert as (cdr (last totallist)) */
1433 }
1434 }
1435
1436 /* We build the functions MAPCAR & MAPLIST in two versions:
1437 The first one builds the list in reversed order, then has to reverse it.
1438 The second one works in the forward direction. */
1439 /* #define MAP_REVERSES */
1440
1441 #ifdef MAP_REVERSES
1442
1443 /* macro for MAPCAR and MAPLIST */
1444 #define MAPCAR_MAPLIST_BODY(listaccess) \
1445 { var gcv_object_t* args_pointer = rest_args_pointer STACKop 2; \
1446 argcount++; /* argcount := number of lists on the stack */ \
1447 /* reserve space for the function call arguments: */ \
1448 get_space_on_STACK(sizeof(gcv_object_t)*(uintL)argcount); \
1449 pushSTACK(NIL); /* start of the result list */ \
1450 {var gcv_object_t* ergptr = &STACK_0; /* pointer to it */ \
1451 /* traverse all lists in parallel: */ \
1452 while (1) { var gcv_object_t* argptr = args_pointer; \
1453 var object fun = NEXT(argptr); \
1454 var uintC count = argcount; \
1455 do { \
1456 var gcv_object_t* next_list_ = &NEXT(argptr); \
1457 var object next_list = *next_list_; \
1458 if (endp(next_list)) goto done; /* a list ended -> done */ \
1459 pushSTACK(listaccess(next_list)); /* as argument on the stack */ \
1460 *next_list_ = Cdr(next_list); /* shorten list */ \
1461 } while (--count); \
1462 funcall(fun,argcount); /* call function */ \
1463 pushSTACK(value1); \
1464 {var object new_cons = allocate_cons(); /* new cons */ \
1465 Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0; \
1466 STACK_0 = new_cons; /* lengthen the result list */ \
1467 }} \
1468 done: \
1469 VALUES1(nreverse(*ergptr)); /* reverse result list */ \
1470 set_args_end_pointer(args_pointer); /* clean up STACK */ \
1471 }}
1472
1473 #else
1474
1475 /* macro for MAPCAR and MAPLIST */
1476 #define MAPCAR_MAPLIST_BODY(listaccess) \
1477 { var gcv_object_t* args_pointer = rest_args_pointer STACKop 2; \
1478 argcount++; /* argcount := number of lists on the stack */ \
1479 /* reserve space for the function call arguments: */ \
1480 get_space_on_STACK(sizeof(gcv_object_t)*(uintL)argcount); \
1481 /* start total list: */ \
1482 pushSTACK(NIL); /* total list */ \
1483 pushSTACK(NIL); /* (last totallist) */ \
1484 {var gcv_object_t *ret=&STACK_1; /* remember the total list*/ \
1485 /* traverse all lists in parallel: */ \
1486 while (1) { var gcv_object_t* argptr = args_pointer; \
1487 var object fun = NEXT(argptr); \
1488 var uintC count = argcount; \
1489 do { \
1490 var gcv_object_t* next_list_ = &NEXT(argptr); \
1491 var object next_list = *next_list_; \
1492 if (endp(next_list)) goto done; /* a list ended -> done */ \
1493 pushSTACK(listaccess(next_list)); /* as argument on the stack */ \
1494 *next_list_ = Cdr(next_list); /* shorten list */ \
1495 } while (--count); \
1496 funcall(fun,argcount); /* call function */ \
1497 pushSTACK(value1); \
1498 {var object new_cons = allocate_cons(); /* new cons */ \
1499 Car(new_cons) = popSTACK(); /* new_cons = (LIST (FUNCALL ...)) */ \
1500 if (nullp(STACK_1)) STACK_1 = STACK_0 = new_cons; /* init */ \
1501 else { Cdr(STACK_0) = new_cons; STACK_0 = new_cons; } /* append */ \
1502 }} \
1503 done: \
1504 VALUES1(*ret); /* result list-cons */ \
1505 set_args_end_pointer(args_pointer); /* clean up STACK */ \
1506 }}
1507
1508 #endif
1509
1510 /* macro for MAPC and MAPL */
1511 #define MAPC_MAPL_BODY(listaccess) \
1512 { var gcv_object_t* args_pointer = rest_args_pointer STACKop 2; \
1513 argcount++; /* argcount := number of lists on the stack */ \
1514 /* reserve space for the function call arguments: */ \
1515 get_space_on_STACK(sizeof(gcv_object_t)*(uintL)argcount); \
1516 pushSTACK(BEFORE(rest_args_pointer)); /* save first list argument */ \
1517 {var gcv_object_t* ergptr = &STACK_0; /* pointer to it */ \
1518 /* traverse all lists in parallel: */ \
1519 while (1) { var gcv_object_t* argptr = args_pointer; \
1520 var object fun = NEXT(argptr); \
1521 var uintC count = argcount; \
1522 do { \
1523 var gcv_object_t* next_list_ = &NEXT(argptr); \
1524 var object next_list = *next_list_; \
1525 if (endp(next_list)) goto done; /* a list ended -> done */ \
1526 pushSTACK(listaccess(next_list)); /* as argument on the stack */ \
1527 *next_list_ = Cdr(next_list); /* shorten list */ \
1528 } while (--count); \
1529 funcall(fun,argcount); /* call function */ \
1530 } \
1531 done: \
1532 VALUES1(*ergptr); /* first list as value */ \
1533 set_args_end_pointer(args_pointer); /* clean up STACK */ \
1534 }}
1535
1536 /* macro for MAPCAN and MAPCON
1537 no MAP_REVERSES version is provided because NRECONC drops
1538 the last atom in dotted lists, e.g., (mapcan #'identity '(1))
1539 returns NIL when it should return 1:
1540 (apply (function nconc) (mapcar (function identity) (quote (1)))) => 1 */
1541 #define MAPCAN_MAPCON_BODY(listaccess,append_function) \
1542 { var gcv_object_t* args_pointer = rest_args_pointer STACKop 2; \
1543 argcount++; /* argcount := number of lists on the stack */ \
1544 /* reserve space for the function call arguments: */ \
1545 get_space_on_STACK(sizeof(gcv_object_t)*(uintL)argcount); \
1546 /* start total list: */ \
1547 pushSTACK(NIL); /* total list */ \
1548 pushSTACK(NIL); /* (last totallist) */ \
1549 {var gcv_object_t *ret=&STACK_1; /* remember the total list*/ \
1550 /* traverse all lists in parallel: */ \
1551 while (1) { var gcv_object_t* argptr = args_pointer; \
1552 var object fun = NEXT(argptr); \
1553 var uintC count = argcount; \
1554 do { \
1555 var gcv_object_t* next_list_ = &NEXT(argptr); \
1556 var object next_list = *next_list_; \
1557 if (endp(next_list)) goto done; /* a list ended -> done */ \
1558 pushSTACK(listaccess(next_list)); /* as argument on the stack */ \
1559 *next_list_ = Cdr(next_list); /* shorten list */ \
1560 } while (--count); \
1561 funcall(fun,argcount); /* call function */ \
1562 append_function(value1); \
1563 } \
1564 done: \
1565 VALUES1(*ret); /* result list */ \
1566 set_args_end_pointer(args_pointer); /* clean up STACK */ \
1567 }}
1568
1569 #define Identity
1570
1571 LISPFUN(mapcar,seclass_default,2,0,rest,nokey,0,NIL)
1572 /* (MAPCAR fun list {list}), CLTL p. 128 */
MAPCAR_MAPLIST_BODY(Car)1573 MAPCAR_MAPLIST_BODY(Car)
1574
1575 LISPFUN(maplist,seclass_default,2,0,rest,nokey,0,NIL)
1576 /* (MAPLIST fun list {list}), CLTL p. 128 */
1577 MAPCAR_MAPLIST_BODY(Identity)
1578
1579 LISPFUN(mapc,seclass_default,2,0,rest,nokey,0,NIL)
1580 /* (MAPC fun list {list}), CLTL p. 128 */
1581 MAPC_MAPL_BODY(Car)
1582
1583 LISPFUN(mapl,seclass_default,2,0,rest,nokey,0,NIL)
1584 /* (MAPL fun list {list}), CLTL p. 128 */
1585 MAPC_MAPL_BODY(Identity)
1586
1587 LISPFUN(mapcan,seclass_default,2,0,rest,nokey,0,NIL)
1588 /* (MAPCAN fun list {list}), CLTL p. 128 */
1589 MAPCAN_MAPCON_BODY(Car,set_last_inplace)
1590
1591 LISPFUN(mapcon,seclass_default,2,0,rest,nokey,0,NIL)
1592 /* (MAPCON fun list {list}), CLTL p. 128 */
1593 MAPCAN_MAPCON_BODY(Identity,set_last_inplace)
1594
1595 LISPFUN(mapcap,seclass_default,2,0,rest,nokey,0,NIL)
1596 /* (EXT:MAPCAP fun list {list}) */
1597 MAPCAN_MAPCON_BODY(Car,set_last_copy)
1598
1599 LISPFUN(maplap,seclass_default,2,0,rest,nokey,0,NIL)
1600 /* (EXT:MAPLAP fun list {list}) */
1601 MAPCAN_MAPCON_BODY(Identity,set_last_copy)
1602
1603 LISPSPECFORM(tagbody, 0,0,body)
1604 { /* (TAGBODY {tag | statement}), CLTL p. 130 */
1605 var object body = popSTACK();
1606 { /* build GENV-frame: */
1607 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
1608 pushSTACK(aktenv.go_env);
1609 finish_frame(ENV1G);
1610 }
1611 /* build TAGBODY-frame: */
1612 var gcv_object_t* top_of_frame = STACK; /* pointer to frame */
1613 /* parse body and store tags in stack: */
1614 var uintL tagcount = 0;
1615 {
1616 var object body_rest = body;
1617 while (consp(body_rest)) {
1618 var object item = Car(body_rest);
1619 body_rest = Cdr(body_rest);
1620 /* as tags are considered: symbols and numbers
1621 (like in compiler), Conses are statements. */
1622 if (atomp(item)) {
1623 if (numberp(item) || symbolp(item)) {
1624 /* store label in stack: */
1625 check_STACK();
1626 pushSTACK(body_rest); /* body-rest after the label */
1627 pushSTACK(item);
1628 tagcount++;
1629 } else {
1630 pushSTACK(item); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1631 pushSTACK(item); pushSTACK(S(tagbody));
1632 error(source_program_error,GETTEXT("~S: ~S is neither tag nor form"));
1633 }
1634 }
1635 }
1636 }
1637 if (tagcount>0) {
1638 var sp_jmp_buf returner; /* return point */
1639 pushSTACK(aktenv.go_env); /* current GO_ENV as NEXT_ENV */
1640 finish_entry_frame(ITAGBODY,returner,, goto go_entry; );
1641 /* extend GO_ENV: */
1642 { aktenv.go_env = make_framepointer(STACK); }
1643 if (false) {
1644 go_entry: /* we jump to this label, if this frame has caught a GO. */
1645 body = value1; /* the formlist is passed as value1. */
1646 }
1647 /* process statements: */
1648 pushSTACK(body);
1649 while (mconsp(STACK_0)) {
1650 var object body_rest = STACK_0;
1651 STACK_0 = Cdr(body_rest); /* remaining body */
1652 body_rest = Car(body_rest); /* next item */
1653 if (consp(body_rest)) {
1654 eval(body_rest); /* form -> evaluate */
1655 }
1656 }
1657 skipSTACK(1); /* forget body */
1658 unwind(); /* unwind TAGBODY-frame */
1659 unwind(); /* unwind GENV-frame */
1660 } else {
1661 /* body without -> only PROGN with value NIL */
1662 skipSTACK(2); /* unwind GENV-frame again, GENV is unchanged */
1663 pushSTACK(body); implicit_prog();
1664 }
1665 VALUES1(NIL);
1666 }
1667
1668 LISPSPECFORM(go, 1,0,nobody)
1669 { /* (GO tag), CLTL p. 133 */
1670 GC_SAFE_POINT(); /* in case of infinite loops we need a way to break */
1671 var object tag = popSTACK();
1672 if (!(numberp(tag) || symbolp(tag))) {
1673 pushSTACK(tag); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1674 pushSTACK(tag); pushSTACK(S(go));
1675 error(source_program_error,GETTEXT("~S: illegal tag ~S"));
1676 }
1677 /* peruse GO_ENV: */
1678 var object env = aktenv.go_env; /* current GO_ENV */
1679 var gcv_object_t* FRAME;
1680 while (framepointerp(env)) {
1681 /* env is a frame-pointer to a ITAGBODY-frame in the stack. */
1682 FRAME = uTheFramepointer(env);
1683 if (framecode(FRAME_(0)) & bit(nested_bit_t)) {
1684 /* frame already nested */
1685 env = FRAME_(frame_next_env); break;
1686 }
1687 /* search tags in unnested ITAGBODY-frame: */
1688 var gcv_object_t* bind_ptr = &FRAME_(frame_bindings); /* pointer below the tag bindings */
1689 var gcv_object_t* bindend_ptr = STACKpointable(topofframe(FRAME_(0))); /* pointer above the tag bindings */
1690 do {
1691 if (eql(*bind_ptr,tag)) { /* tag found? */
1692 value1 = *(bind_ptr STACKop 1); /* fetch formlist from frame */
1693 goto found;
1694 }
1695 bind_ptr skipSTACKop 2;
1696 } while (bind_ptr != bindend_ptr);
1697 env = FRAME_(frame_next_env);
1698 }
1699 /* env is an Alist. */
1700 while (consp(env)) {
1701 var object tagbody_cons = Car(env);
1702 var object tagbody_vec = Car(tagbody_cons); /* tag-vector */
1703 var gcv_object_t* tagptr = &TheSvector(tagbody_vec)->data[0];
1704 var uintL index = 0;
1705 var uintL count = Svector_length(tagbody_vec);
1706 do {
1707 if (eql(*tagptr++,tag)) { /* tag found? */
1708 env = Cdr(tagbody_cons);
1709 if (eq(env,disabled)) { /* tagbody still active? */
1710 pushSTACK(tag);
1711 pushSTACK(S(go));
1712 error(control_error,
1713 GETTEXT("~S: tagbody for tag ~S has already been left"));
1714 }
1715 FRAME = uTheFramepointer(env); /* pointer to the (still active!) frame */
1716 value1 = FRAME_(frame_bindings+2*index+1); /* formlist */
1717 goto found;
1718 }
1719 index++;
1720 } while (--count);
1721 env = Cdr(env);
1722 }
1723 { /* env is finished. */
1724 pushSTACK(tag); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1725 pushSTACK(tag); pushSTACK(S(go));
1726 error(source_program_error,
1727 GETTEXT("~S: no tag named ~S is currently visible"));
1728 }
1729 found: /* tagbody-frame found. FRAME is pointing to it (without typeinfo),
1730 value1 is the liste of the forms to be executed. */
1731 mv_count=1; /* formlist value1 is passed */
1732 /* jump to the found tagbody-frame and continue there: */
1733 unwind_upto(FRAME);
1734 }
1735
1736 /* error-message, when there are too many values
1737 error_mv_toomany(caller);
1738 > caller: Caller, a symbol */
error_mv_toomany(object caller)1739 modexp _Noreturn void error_mv_toomany (object caller) {
1740 pushSTACK(caller);
1741 error(error_condition,GETTEXT("~S: too many return values"));
1742 }
1743
1744 LISPFUN(values,seclass_no_se,0,0,rest,nokey,0,NIL)
1745 { /* (VALUES {arg}), CLTL p. 134
1746 [not foldable, in order to avoid infinite loop!]*/
1747 if (argcount >= mv_limit)
1748 error_mv_toomany(S(values));
1749 STACK_to_mv(argcount);
1750 }
1751
1752 LISPFUNNR(values_list,1)
1753 { /* (VALUES-LIST list), CLTL p. 135 */
1754 list_to_mv(popSTACK(), error_mv_toomany(S(values_list)); );
1755 }
1756
1757 LISPSPECFORM(multiple_value_list, 1,0,nobody)
1758 { /* (MULTIPLE-VALUE-LIST form), CLTL p. 135 */
1759 eval(popSTACK()); /* evaluate form */
1760 mv_to_list(); /* pack values into list */
1761 VALUES1(popSTACK()); /* return list */
1762 }
1763
1764 LISPSPECFORM(multiple_value_call, 1,0,body)
1765 { /* (MULTIPLE-VALUE-CALL fun {form}), CLTL p. 135 */
1766 var gcv_object_t* fun_ = &STACK_1;
1767 *fun_ = (eval(*fun_),value1); /* evaluate function */
1768 var object forms = popSTACK(); /* formlist */
1769 var uintL argcount = 0; /* number of arguments so far */
1770 while (consp(forms)) {
1771 pushSTACK(Cdr(forms)); /* remaining forms */
1772 eval(Car(forms)); /* evaluate next form */
1773 forms = popSTACK();
1774 /* put its values into the stack: */
1775 argcount += (uintL)mv_count;
1776 mv_to_STACK();
1777 }
1778 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
1779 error_too_many_args(S(multiple_value_call),*fun_,argcount,ca_limit_1);
1780 funcall(*fun_,argcount); /* call function */
1781 skipSTACK(1);
1782 }
1783
1784 LISPSPECFORM(multiple_value_prog1, 1,0,body)
1785 { /* (MULTIPLE-VALUE-PROG1 form {form}), CLTL p. 136 */
1786 eval(STACK_1); /* evaluate first form */
1787 var object body = popSTACK();
1788 skipSTACK(1);
1789 var uintC mvcount = mv_count; /* number of values */
1790 mv_to_STACK(); /* all values into the stack */
1791 pushSTACK(body); implicit_prog();
1792 STACK_to_mv(mvcount); /* fetch all values again from the stack */
1793 }
1794
1795 LISPSPECFORM(multiple_value_bind, 2,0,body)
1796 { /* (MULTIPLE-VALUE-BIND ({var}) values-form {decl} {form}), CLTL p. 136 */
1797 /* separate {decl} {form} : */
1798 var object compile_name = parse_doc_decl(STACK_0,false);
1799 if (!eq(Fixnum_0,compile_name)) { /* declaration (COMPILE) ? */
1800 /* yes -> compile form: */
1801 skipSTACK(2); return_Values compile_eval_form(compile_name);
1802 } else {
1803 var object varlist = STACK_2;
1804 STACK_2 = STACK_1;
1805 skipSTACK(2);
1806 /* build variable binding frame, extend VAR_ENV : */
1807 var gcv_object_t* form_ = &STACK_0;
1808 var gcv_object_t *bind_ptr, *spec_ptr;
1809 var uintC bind_count, spec_count;
1810 make_variable_frame(S(multiple_value_bind),varlist,&bind_ptr,&bind_count,
1811 &spec_ptr,&spec_count);
1812 /* stack layout: values-form, variable binding frame,
1813 env-binding-frame, ({form}).
1814 now evaluate values-form: */
1815 eval(*form_);
1816 /* Macro for binding variables in the variable-frame: binds
1817 the next variable to value, decreases frame_pointer by 2 resp. 3. */
1818 #define bind_next_var(value) \
1819 { var gcv_object_t* valptr = &Next(frame_pointer); \
1820 frame_pointer skipSTACKop -varframe_binding_size; \
1821 {var gcv_object_t* markptr = &Before(frame_pointer); \
1822 if (as_oint(*markptr) & wbit(dynam_bit_o)) { /* dynamic binding: */ \
1823 var object sym = *(markptr STACKop varframe_binding_sym); /* var */ \
1824 *valptr = Symbolflagged_value(sym); /* old val into the frame */ \
1825 Symbolflagged_value(sym) = (value); /* new value into the value cell */ \
1826 activate_specdecl(sym,spec_ptr,spec_count); \
1827 } else /* static binding : */ \
1828 *valptr = (value); /* new value into the frame */ \
1829 *markptr = SET_BIT(*markptr,active_bit_o); /* activate binding */ \
1830 }}
1831 /* bind the r:=bind_count variables to the s:=mv_count values:
1832 (if there are not enough variables: discard remaining values;
1833 if there are not enough values: fill with NIL.)
1834 here, r>=0 and s>=0. */
1835 {
1836 var gcv_object_t* frame_pointer = bind_ptr;
1837 var uintC r = bind_count;
1838 var object* mv_pointer;
1839 var uintC s = mv_count;
1840 if (r==0) goto ok; /* no variables? */
1841 if (s==0) goto fill; /* no values? */
1842 /* still min(r,s)>0 values to bind: */
1843 #if !defined(VALUE1_EXTRA)
1844 mv_pointer = &mv_space[0];
1845 #else
1846 bind_next_var(value1);
1847 if (--r == 0) goto ok; /* no more variables? */
1848 if (--s == 0) goto fill; /* no more values? */
1849 mv_pointer = &mv_space[1];
1850 #endif
1851 /* still min(r,s)>0 values to bind: */
1852 while (1) {
1853 bind_next_var(*mv_pointer++);
1854 if (--r == 0) goto ok; /* no more variables? */
1855 if (--s == 0) goto fill; /* no more values? */
1856 }
1857 fill: /* still bind r>0 variables to NIL */
1858 do { bind_next_var(NIL); } while (--r);
1859 ok: ;
1860 }
1861 if (spec_count > 0) activate_specdecls(spec_ptr,spec_count);
1862 /* interpret body: */
1863 implicit_progn(popSTACK(),NIL);
1864 /* unwind frames: */
1865 unwind(); /* unwind VENV binding frame */
1866 unwind(); /* unwind variable-binding-frame */
1867 skipSTACK(1);
1868 }
1869 }
1870 #undef bind_next_var
1871
1872 LISPSPECFORM(multiple_value_setq, 2,0,nobody)
1873 { /* (MULTIPLE-VALUE-SETQ ({var}) form), CLTL p. 136 */
1874 /* check variable list: */
1875 var gcv_object_t* firstvarptr = args_end_pointer;
1876 var uintL varcount = 0;
1877 {
1878 var gcv_object_t* varlistr_ = &STACK_1;
1879 while (consp(*varlistr_)) {
1880 var object symbol = /* next variable */
1881 check_symbol_non_constant(Car(*varlistr_),S(multiple_value_setq));
1882 *varlistr_ = Cdr(*varlistr_);
1883 varcount++;
1884 pushSTACK(symbol);
1885 check_STACK();
1886 if (sym_macrop(symbol)) /* and not a symbol-macro */
1887 goto expand;
1888 }
1889 if (false) {
1890 expand: /* turn MULTIPLE-VALUE-SETQ into MULTIPLE-VALUE-SETF */
1891 dotimespL(varcount,varcount, {
1892 var object new_cons = allocate_cons();
1893 Car(new_cons) = popSTACK(); Cdr(new_cons) = *varlistr_;
1894 *varlistr_ = new_cons;
1895 });
1896 /* stack layout: varlist, form. */
1897 pushSTACK(STACK_0); STACK_1 = STACK_2; STACK_2 = S(multiple_value_setf);
1898 var object newform = listof(3);
1899 eval(newform);
1900 return;
1901 }
1902 }
1903 eval(Before(firstvarptr)); /* evaluate form */
1904 /* Write values into the stack (needed because setq() can trigger GC): */
1905 var gcv_object_t* mvptr = args_end_pointer;
1906 mv_to_STACK();
1907 /* Perform the assignments: */
1908 var uintL valcount = mv_count; /* number of values */
1909 {
1910 var uintL remaining = valcount; /* number of values that are still available */
1911 var gcv_object_t* varptr = firstvarptr;
1912 dotimesL(varcount,varcount, {
1913 var object value;
1914 if (remaining>0) {
1915 value = NEXT(mvptr); remaining--; /* next value */
1916 } else {
1917 value = NIL; /* NIL, if all values are consumed */
1918 }
1919 setq(NEXT(varptr),value); /* assign to the next variable */
1920 });
1921 }
1922 /* Return the first among the multiple values as the only value: */
1923 VALUES1(valcount > 0 ? (object)STACK_(valcount-1) : NIL);
1924 set_args_end_pointer(firstvarptr STACKop 2); /* clean up STACK */
1925 }
1926
1927 LISPSPECFORM(catch, 1,0,body)
1928 { /* (CATCH tag {form}), CLTL p. 139 */
1929 STACK_1 = (eval(STACK_1),value1); /* evaluate tag */
1930 /* finish building of CATCH-frame: */
1931 var object body = popSTACK(); /* ({form}) */
1932 var gcv_object_t* top_of_frame = STACK STACKop 1; /* pointer above frame */
1933 var sp_jmp_buf returner; /* memorize return point */
1934 finish_entry_frame(CATCH,returner,, goto catch_return; );
1935 /* execute body: */
1936 implicit_progn(body,NIL);
1937 catch_return: /* we jump to this label, if the catch-frame built
1938 above has caught a throw. */
1939 skipSTACK(3); /* unwind CATCH-frame */
1940 }
1941
1942 LISPSPECFORM(unwind_protect, 1,0,body)
1943 { /* (UNWIND-PROTECT form {cleanup}), CLTL p. 140 */
1944 var object cleanup = popSTACK();
1945 var object form = popSTACK();
1946 /* build UNWIND-PROTECT-frame: */
1947 pushSTACK(cleanup);
1948 var gcv_object_t* top_of_frame = STACK;
1949 var sp_jmp_buf returner; /* return point */
1950 finish_entry_frame(UNWIND_PROTECT,returner,, goto throw_save; );
1951 /* evaluate protected form: */
1952 eval(form);
1953 { /* Cleanup after normal termination of the protected form: */
1954 /* unwind UNWIND-PROTECT-frame: */
1955 skipSTACK(2);
1956 cleanup = popSTACK();
1957 /* save values: */
1958 var uintC mvcount = mv_count;
1959 mv_to_STACK();
1960 /* process cleanup-forms: */
1961 pushSTACK(cleanup); implicit_prog();
1962 /* write back values: */
1963 STACK_to_mv(mvcount);
1964 }
1965 return;
1966 throw_save: /* we jump to this label, if the Unwind-Protect-Frame
1967 built above has kept a throw.
1968 save unwind_protect_to_save and jump to it in the end. */
1969 {
1970 var restartf_t fun = unwind_protect_to_save.fun;
1971 var gcv_object_t* arg = unwind_protect_to_save.upto_frame;
1972 /* Cleanup: */
1973 /* unwind UNWIND-PROTECT-frame: */
1974 skipSTACK(2);
1975 cleanup = popSTACK();
1976 /* save values: */
1977 var uintC mvcount = mv_count;
1978 mv_to_STACK();
1979 /* process cleanup-forms: */
1980 pushSTACK(cleanup); implicit_prog();
1981 /* write back values: */
1982 STACK_to_mv(mvcount);
1983 /* and jump further: */
1984 fun(arg);
1985 }
1986 }
1987
1988 LISPSPECFORM(throw, 2,0,nobody)
1989 { /* (THROW tag result), CLTL p. 142 */
1990 STACK_1 = (eval(STACK_1),value1); /* evaluate tag */
1991 eval(popSTACK()); /* evaluate result */
1992 var object tag = popSTACK(); /* evaluated tag */
1993 throw_to(tag); /* try to throw to this tag */
1994 /* failed. */
1995 pushSTACK(tag);
1996 pushSTACK(S(throw));
1997 error(control_error,GETTEXT("~S: there is no CATCHer for tag ~S"));
1998 }
1999
2000 LISPFUNN(driver,1)
2001 { /* (SYS::DRIVER fun) builds a driver-frame, that calls the function
2002 fun (with 0 arguments) each time. fun is executed in a endless loop
2003 that can be aborted with GO or THROW . */
2004 var gcv_object_t* top_of_frame = STACK; /* pointer above frame */
2005 var sp_jmp_buf returner; /* remember entry point */
2006 finish_entry_frame(DRIVER,returner,,;);
2007 /* this is the entry point. */
2008 while (1) { funcall(STACK_(0+2),0); } /* call fun, endless loop */
2009 }
2010
2011 LISPFUNN(unwind_to_driver,1)
2012 { /* (SYS::UNWIND-TO-DRIVER top-p)
2013 UNWIND to the next Driver-Frame or to the top. */
2014 var object arg = popSTACK();
2015 if (nullp(arg))
2016 reset(1);
2017 else if (uint32_p(arg))
2018 reset(I_to_uint32(arg));
2019 else
2020 reset(0);
2021 }
2022
2023 /* Checks an optional macroexpansion-environment in STACK_0.
2024 > STACK_0: argument
2025 < STACK_0: macroexpansions-environment #(venv fenv)
2026 can trigger GC */
test_env(void)2027 local maygc void test_env (void) {
2028 var object arg = STACK_0;
2029 if (missingp(arg)) { /* required by ANSI CL sections 3.1.1.3.1, 3.1.1.4 */
2030 arg = allocate_vector(2); /* vector #(nil nil) as default */
2031 } else while (!(simple_vector_p(arg) && (Svector_length(arg) == 2))) {
2032 pushSTACK(NIL); /* no PLACE */
2033 pushSTACK(arg); /* TYPE-ERROR slot DATUM */
2034 pushSTACK(O(type_svector2)); /* TYPE-ERROR slot EXPECTED-TYPE */
2035 pushSTACK(arg);
2036 check_value(type_error,
2037 GETTEXT("Argument ~S is not a macroexpansion environment"));
2038 arg = value1;
2039 }
2040 STACK_0 = arg;
2041 }
2042
2043 LISPFUN(macro_function,seclass_read,1,1,norest,nokey,0,NIL)
2044 { /* (MACRO-FUNCTION symbol [env]), CLTL p. 144;
2045 Issue MACRO-FUNCTION-ENVIRONMENT:YES */
2046 test_env();
2047 var object symbol = check_symbol(STACK_1);
2048 var object env = STACK_0; skipSTACK(2);
2049 var object fundef = sym_function(symbol,TheSvector(env)->data[1]);
2050 if (fsubrp(fundef)) {
2051 /* a FSUBR -> search in property list: (GET symbol 'SYS::MACRO) */
2052 var object got = get(symbol,S(macro)); /* search */
2053 if (!boundp(got)) /* not found? */
2054 goto nil;
2055 value1 = got;
2056 } else if (macrop(fundef)) { /* #<MACRO expander> ? */
2057 value1 = TheMacro(fundef)->macro_expander;
2058 } else { /* SUBR/Closure/FunctionMacro/#<UNBOUND> -> no macrodefinition */
2059 nil:
2060 value1 = NIL;
2061 }
2062 mv_count=1;
2063 }
2064
2065 LISPFUN(macroexpand,seclass_default,1,1,norest,nokey,0,NIL)
2066 { /* (MACROEXPAND form [env]), CLTL p. 151 */
2067 test_env();
2068 var object env = popSTACK();
2069 var object form = STACK_0;
2070 STACK_0 = env; /* save env */
2071 macroexp0(form,env); /* expand */
2072 if (!nullp(value2)) { /* something happened? */
2073 /* yes -> expand to death: */
2074 do { macroexp0(value1,STACK_0);
2075 } while (!nullp(value2));
2076 value2 = T;
2077 }
2078 mv_count=2; skipSTACK(1);
2079 }
2080
2081 LISPFUN(macroexpand_1,seclass_default,1,1,norest,nokey,0,NIL)
2082 { /* (MACROEXPAND-1 form [env]), CLTL p. 151 */
2083 test_env();
2084 var object env = popSTACK();
2085 var object form = popSTACK();
2086 macroexp0(form,env); /* expand one time */
2087 mv_count=2;
2088 }
2089
2090 LISPSPECFORM(declare, 0,0,body)
2091 { /* (DECLARE {decl-spec}), CLTL p. 153 */
2092 /* ({decl-spec}) already in STACK_0 */
2093 pushSTACK(STACK_0); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2094 error(source_program_error,GETTEXT("declarations ~S are not allowed here"));
2095 }
2096
2097 LISPSPECFORM(the, 2,0,nobody)
2098 { /* (THE value-type form), CLTL p. 161 */
2099 eval(STACK_0); /* evaluate form */
2100 mv_to_list(); /* build value list and save */
2101 /* stack layout: value-type, form, values.
2102 call (SYS::%THE values (SYS::TYPE-FOR-DISCRIMINATION value-type))
2103 for type-check: */
2104 pushSTACK(STACK_0);
2105 pushSTACK(STACK_(2+1)); funcall(S(type_for_discrimination),1);
2106 pushSTACK(value1);
2107 funcall(S(pthe),2);
2108 if (nullp(value1)) { /* type-check failed */
2109 pushSTACK(STACK_0); /* TYPE-ERROR slot DATUM */
2110 pushSTACK(STACK_(2+1)); /* TYPE-ERROR slot EXPECTED-TYPE */
2111 pushSTACK(STACK_(2+2)); /* value-type */
2112 pushSTACK(STACK_(0+3)); /* values */
2113 pushSTACK(STACK_(1+4)); /* form */
2114 pushSTACK(S(the));
2115 error(type_error,
2116 GETTEXT("~S: ~S evaluated to the values ~S, not of type ~S"));
2117 }
2118 /* type-check OK -> return values: */
2119 list_to_mv(popSTACK(), { error_mv_toomany(S(the)); } );
2120 skipSTACK(2);
2121 }
2122
2123 LISPFUNN(proclaim,1)
2124 { /* (PROCLAIM decl-spec) */
2125 if (!consp(STACK_0/*declspec*/)) {
2126 pushSTACK(S(proclaim));
2127 error(error_condition,GETTEXT("~S: bad declaration ~S"));
2128 }
2129 var object decltyp = Car(STACK_0/*declspec*/); /* declaration type */
2130 if (eq(decltyp,S(special))) { /* SPECIAL */
2131 while (!endp( STACK_0/*declspec*/ = Cdr(STACK_0/*declspec*/) )) {
2132 var object symbol =
2133 check_symbol_not_symbol_macro(Car(STACK_0/*declspec*/));
2134 if (!keywordp(symbol))
2135 clear_const_flag(TheSymbol(symbol));
2136 set_special_flag(TheSymbol(symbol));
2137 #if defined(MULTITHREAD)
2138 /* MT: add to the threads (empty) if not already there */
2139 if (TheSymbol(symbol)->tls_index == SYMBOL_TLS_INDEX_NONE)
2140 add_per_thread_special_var(symbol);
2141 #endif
2142 }
2143 } else if (eq(decltyp,S(notspecial))) { /* NOTSPECIAL */
2144 while (!endp( STACK_0/*declspec*/ = Cdr(STACK_0/*declspec*/) )) {
2145 var object symbol = check_symbol(Car(STACK_0/*declspec*/));
2146 if (!keywordp(symbol)) clear_const_flag(TheSymbol(symbol));
2147 clear_special_flag(TheSymbol(symbol));
2148 }
2149 } else if (eq(decltyp,S(declaration))) { /* DECLARATION */
2150 while (!endp( STACK_0/*declspec*/ = Cdr(STACK_0/*declspec*/) )) {
2151 pushSTACK(Car(STACK_0/*declspec*/)); pushSTACK(TheSubr(subr_self)->name);
2152 funcall(S(check_not_type),2);
2153 var object symbol = value1;
2154 /* (PUSHNEW symbol (cdr declaration-types)) : */
2155 if (nullp(memq(symbol,Cdr(O(declaration_types))))) {
2156 pushSTACK(symbol);
2157 {
2158 var object new_cons = allocate_cons();
2159 var object list = O(declaration_types);
2160 Car(new_cons) = popSTACK(); Cdr(new_cons) = Cdr(list);
2161 Cdr(list) = new_cons;
2162 }
2163 }
2164 }
2165 } else if (eq(decltyp,S(inline)) || eq(decltyp,S(notinline))) {
2166 pushSTACK(decltyp); /* INLINE, NOTINLINE */
2167 while (!endp( STACK_1/*declspec*/ = Cdr(STACK_1/*declspec*/) )) {
2168 var object symbol = check_funname(source_program_error,S(proclaim),
2169 Car(STACK_1/*declspec*/));
2170 /*(SYS::%PUT (SYS::GET-FUNNAME-SYMBOL symbol) 'SYS::INLINABLE decltyp)*/
2171 pushSTACK(symbol); funcall(S(get_funname_symbol),1); pushSTACK(value1);
2172 pushSTACK(S(inlinable)); pushSTACK(STACK_2)/*decltyp*/;
2173 funcall(L(put),3);
2174 }
2175 skipSTACK(1); /*decltyp*/
2176 } else if (eq(decltyp,S(constant_inline))
2177 || eq(decltyp,S(constant_notinline))) {
2178 pushSTACK(decltyp); /* CONSTANT-INLINE, CONSTANT-NOTINLINE */
2179 while (!endp( STACK_1/*declspec*/ = Cdr(STACK_1/*declspec*/) )) {
2180 var object symbol = check_symbol(Car(STACK_1/*declspec*/));
2181 /* (SYS::%PUT symbol 'SYS::CONSTANT-INLINABLE decltyp) : */
2182 pushSTACK(symbol); pushSTACK(S(constant_inlinable));
2183 pushSTACK(STACK_2)/*decltyp*/; funcall(L(put),3);
2184 }
2185 skipSTACK(1); /*decltyp*/
2186 } else if (eq(decltyp,S(optimize))) {
2187 pushSTACK(Cdr(STACK_0)); funcall(S(note_optimize),1);
2188 } else { /* check that the declspec is a proper list */
2189 pushSTACK(STACK_0/*declspec*/); funcall(L(list_length_proper),1);
2190 }
2191 VALUES1(NIL); skipSTACK(1);
2192 }
2193
2194 LISPFUNN(eval,1)
2195 { /* (EVAL form), CLTL p. 321 */
2196 eval_noenv(popSTACK()); /* evaluate form in empty environment */
2197 }
2198
2199 LISPSPECFORM(load_time_value, 1,1,nobody)
2200 { /* (LOAD-TIME-VALUE form [read-only-p]), CLTL2 p. 680 */
2201 var object form = STACK_1;
2202 skipSTACK(2); /* ignore read-only-p */
2203 eval_noenv(form); /* evaluate form in empty environment */
2204 mv_count=1;
2205 }
2206
2207 /* UP: Checks an optional environment-argument for EVALHOOK and APPLYHOOK.
2208 test_optional_env_arg(&env5);
2209 < env5: 5 components of the environment
2210 increases STACK by 1 */
test_optional_env_arg(environment_t * env5)2211 local void test_optional_env_arg (environment_t* env5) {
2212 var object env = popSTACK(); /* env-argument */
2213 if (!boundp(env)) { /* not supplied -> void environment */
2214 env5->var_env = NIL;
2215 env5->fun_env = NIL;
2216 env5->block_env = NIL;
2217 env5->go_env = NIL;
2218 env5->decl_env = O(top_decl_env);
2219 } else if (simple_vector_p(env) && (Svector_length(env) == 5)) {
2220 /* a simple-vector of length 5 */
2221 env5->var_env = TheSvector(env)->data[0];
2222 env5->fun_env = TheSvector(env)->data[1];
2223 env5->block_env = TheSvector(env)->data[2];
2224 env5->go_env = TheSvector(env)->data[3];
2225 env5->decl_env = TheSvector(env)->data[4];
2226 } else
2227 error_environment(env);
2228 }
2229
2230 LISPFUN(evalhook,seclass_default,3,1,norest,nokey,0,NIL)
2231 { /* (EVALHOOK form evalhookfn applyhookfn [env]), CLTL p. 323 */
2232 var environment_t env5;
2233 test_optional_env_arg(&env5); /* env-argument after env5 */
2234 var object applyhookfn = popSTACK();
2235 var object evalhookfn = popSTACK();
2236 var object form = popSTACK();
2237 bindhooks(evalhookfn,applyhookfn); /* bind *EVALHOOK* and *APPLYHOOK* */
2238 /* build environment-frame: */
2239 make_ENV5_frame();
2240 /* set current environments: */
2241 aktenv.var_env = env5.var_env ;
2242 aktenv.fun_env = env5.fun_env ;
2243 aktenv.block_env = env5.block_env;
2244 aktenv.go_env = env5.go_env ;
2245 aktenv.decl_env = env5.decl_env ;
2246 /* evaluate form bypassing *EVALHOOK* and *APPLYHOOK* : */
2247 eval_no_hooks(form);
2248 unwind(); /* unwind environment-frame */
2249 unwind(); /* unwind binding frame for *EVALHOOK* / *APPLYHOOK* */
2250 }
2251
2252 LISPFUN(applyhook,seclass_default,4,1,norest,nokey,0,NIL)
2253 { /* (APPLYHOOK function args evalhookfn applyhookfn [env]), CLTL p. 323 */
2254 var environment_t env5;
2255 test_optional_env_arg(&env5); /* env-Argument after env5 */
2256 var object applyhookfn = popSTACK();
2257 var object evalhookfn = popSTACK();
2258 var object args = popSTACK();
2259 var object fun = popSTACK();
2260 bindhooks(evalhookfn,applyhookfn); /* bind *EVALHOOK* and *APPLYHOOK* */
2261 /* build environment-frame: */
2262 make_ENV5_frame();
2263 /* set current environments: */
2264 aktenv.var_env = env5.var_env ;
2265 aktenv.fun_env = env5.fun_env ;
2266 aktenv.block_env = env5.block_env;
2267 aktenv.go_env = env5.go_env ;
2268 aktenv.decl_env = env5.decl_env ;
2269 { /* save fun & args: */
2270 pushSTACK(fun); pushSTACK(args);
2271 var gcv_object_t* fun_ = &STACK_1;
2272 var gcv_object_t* args_ = &STACK_0;
2273 /* evaluate each argument and store on the stack: */
2274 var uintC argcount = 0;
2275 while (consp(args)) {
2276 pushSTACK(Cdr(args)); /* remaining argument list */
2277 eval_no_hooks(Car(args)); /* evaluate next arg */
2278 args = STACK_0; STACK_0 = value1; /* store value in stack */
2279 argcount++;
2280 if (argcount==0) /* overflow? */
2281 error_too_many_args(S(applyhook),*fun_,llength(*args_),
2282 (uintC)~(uintC)0);
2283 }
2284 funcall(*fun_,argcount); /* apply function */
2285 skipSTACK(1);
2286 }
2287 unwind(); /* unwind environment-frame */
2288 unwind(); /* unwind binding frame for *EVALHOOK* / *APPLYHOOK* */
2289 }
2290
2291 /* check whether the form is a constant */
form_constant_p(object form)2292 local bool form_constant_p (object form) {
2293 if (symbolp(form))
2294 return constant_var_p(TheSymbol(form));
2295 if (consp(form)) {
2296 var object head = Car(form);
2297 if (eq(head,S(quote))) return true;
2298 if (!funnamep(head)) return false; /* what's this form? */
2299 /* cf. funname_to_symbol */
2300 var object fdef = head;
2301 if (!symbolp(fdef))
2302 /* (get ... 'SYS::SETF-FUNCTION) */
2303 fdef = get(Car(Cdr(fdef)),S(setf_function));
2304 if (!symbolp(fdef))
2305 /* Use of (setf foo) before it's defined. */
2306 return false;
2307 fdef = Symbol_function(fdef);
2308 if ((cclosurep(fdef) && (Cclosure_seclass(fdef) == seclass_foldable))
2309 || (subrp(fdef) && (TheSubr(fdef)->seclass == seclass_foldable))) {
2310 check_SP();
2311 while (1) {
2312 form = Cdr(form);
2313 if (nullp(form)) return true; /* list is over */
2314 if (!consp(form)) return false; /* invalid form */
2315 if (!form_constant_p(Car(form))) return false;
2316 }
2317 }
2318 return false;
2319 }
2320 /* self-evaluating objects, i.e., (NOT (OR symbol cons)), are constants */
2321 return true;
2322 }
2323
2324 LISPFUN(constantp,seclass_read,1,1,norest,nokey,0,NIL)
2325 { /* (CONSTANTP expr [env]), CLTL p. 324 */
2326 skipSTACK(1); /* environment is not used */
2327 VALUES_IF(form_constant_p(popSTACK()));
2328 }
2329
2330 /* (SYS::GLOBAL-SYMBOL-MACRO-P symbol) tests if the symbol is a global
2331 symbol macro, defined through DEFINE-SYMBOL-MACRO. */
2332 LISPFUNNR(global_symbol_macro_p,1)
2333 {
2334 var object symbol = check_symbol(popSTACK());
2335 VALUES_IF(symmacro_var_p(TheSymbol(symbol)));
2336 }
2337
2338 /* (FUNCTION-SIDE-EFFECT fun) -> seclass, fdefinition, name */
2339 LISPFUNNR(function_side_effect,1)
2340 { /* This function is called at compile time, so the argument does not have to
2341 be a function, it may be a variable name whose value will be some function
2342 at run time. Therefore we never signal errors, just return *SECLASS-DIRTY*. */
2343 var object fdef = popSTACK();
2344 var object name = unbound;
2345 if (consp(fdef) && consp(Cdr(fdef))
2346 && (eq(S(quote),Car(fdef)) || eq(S(function),Car(fdef))))
2347 fdef = Car(Cdr(fdef));
2348 if (funnamep(fdef)) {
2349 name = fdef;
2350 /* cf. funname_to_symbol */
2351 if (!symbolp(fdef))
2352 /* (get ... 'SYS::SETF-FUNCTION) */
2353 fdef = get(Car(Cdr(fdef)),S(setf_function));
2354 }
2355 if (symbolp(fdef))
2356 fdef = Symbol_function(fdef);
2357 /* If the argument was a function object, then we have it now. */
2358 var seclass_t seclass = seclass_default;
2359 if (subrp(fdef))
2360 seclass = (seclass_t)TheSubr(fdef)->seclass;
2361 else if (cclosurep(fdef))
2362 seclass = (seclass_t)Cclosure_seclass(fdef);
2363 if (!boundp(name) && boundp(fdef)) {
2364 if (subrp(fdef))
2365 name = TheSubr(fdef)->name;
2366 else if (closurep(fdef))
2367 name = Closure_name(fdef);
2368 }
2369 VALUES3(seclass_object(seclass),
2370 boundp(fdef) ? fdef : NIL,
2371 boundp(name) ? name : NIL);
2372 }
2373
2374 LISPFUNNR(function_name_p,1)
2375 { /* (SYS::FUNCTION-NAME-P expr) recognizes function name */
2376 var object arg = popSTACK();
2377 VALUES_IF(funnamep(arg));
2378 }
2379
2380 LISPFUNN(check_function_name,2)
2381 { /* (SYS::CHECK-FUNCTION-NAME funname caller)
2382 checks whether the funname argument is a function name, giving the user the
2383 opportunity to correct it if it is not. Returns the corrected function name. */
2384 VALUES1(check_funname(source_program_error,STACK_0,STACK_1));
2385 skipSTACK(2);
2386 }
2387
2388 LISPFUNN(check_symbol,2)
2389 { /* (SYS::CHECK-SYMBOL symbol caller)
2390 checks whether the symbol argument is a symbol, giving the user the
2391 opportunity to correct it if it is not. Returns the corrected symbol. */
2392 var gcv_object_t *sym_ = &STACK_1;
2393 var gcv_object_t *caller_ = &STACK_0;
2394 while (!symbolp(*sym_)) {
2395 pushSTACK(NIL); /* no PLACE */
2396 pushSTACK(*sym_); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2397 pushSTACK(*sym_); pushSTACK(*caller_);
2398 check_value(source_program_error,GETTEXT("~S: ~S is not a symbol"));
2399 *sym_ = value1;
2400 }
2401 VALUES1(*sym_);
2402 skipSTACK(2);
2403 }
2404
2405 LISPFUN(parse_body,seclass_default,1,1,norest,nokey,0,NIL)
2406 { /* (SYS::PARSE-BODY body [docstring-allowed])
2407 parses body, recognizes declarations, returns four values:
2408 1. body-rest, all forms after the declarations
2409 2. list of occurred declspecs
2410 3. docstring (only if docstring-allowed=T ) or NIL
2411 4. (COMPILE name) -> name; (COMPILE) -> Fixnum_1; none -> Fixnum_0
2412 (docstring-allowed should be = NIL or T) */
2413 value4 = parse_doc_decl(STACK_1/*body*/,!missingp(STACK_0));
2414 if (!boundp(value4)) value4 = Fixnum_1;
2415 /* got 3 values from parse_dd(): ({form}), declspecs, doc */
2416 mv_count = 4;
2417 skipSTACK(2);
2418 }
2419
2420 LISPFUNN(keyword_test,2)
2421 { /* (SYSTEM::KEYWORD-TEST arglist kwlist)
2422 determines, if all keywords in the list kwlist occur
2423 in the argument-list arglist (a keyword/value - list) or if there
2424 is a keyword/value-pair :ALLOW-OTHER-KEYS with value /= NIL .
2425 if not, error. */
2426 var object arglist = STACK_1;
2427 { /* check number of arguments: */
2428 var uintL argcount = llength(arglist);
2429 if (argcount % 2) {
2430 pushSTACK(arglist);
2431 /* ANSI CL 3.5.1.6. wants a PROGRAM-ERROR here. */
2432 error(program_error,
2433 GETTEXT("keyword argument list ~S has an odd length"));
2434 }
2435 }
2436 { /* search, if there is :ALLOW-OTHER-KEYS : */
2437 var object arglistr = arglist;
2438 while (consp(arglistr)) {
2439 if (eq(Car(arglistr),S(Kallow_other_keys)) && !nullp(Car(Cdr(arglistr))))
2440 goto done;
2441 arglistr = Cdr(Cdr(arglistr));
2442 }
2443 }
2444 { /* check whether all specified keywords occur in kwlist: */
2445 var object arglistr = arglist;
2446 while (consp(arglistr)) {
2447 var object key = Car(arglistr); arglistr = Cdr(arglistr);
2448 var object val = Car(arglistr); arglistr = Cdr(arglistr);
2449 if (eq(key,S(Kallow_other_keys))) {
2450 if (nullp(val)) break; /* need check */
2451 else goto done; /* no check */
2452 }
2453 }
2454 for (arglistr = arglist; consp(arglistr); ) {
2455 var object key = Car(arglistr); arglistr = Cdr(arglistr);
2456 var object val = Car(arglistr); arglistr = Cdr(arglistr);
2457 if (!eq(key,S(Kallow_other_keys))
2458 && nullp(memq(key,STACK_0))) { /* not found */
2459 pushSTACK(key); /* KEYWORD-ERROR Slot DATUM */
2460 pushSTACK(key);
2461 pushSTACK(STACK_(0+2));
2462 pushSTACK(val);
2463 pushSTACK(key);
2464 { /* `(MEMBER ,@kwlist) = KEYWORD-ERROR Slot EXPECTED-TYPE */
2465 var object type = allocate_cons();
2466 Car(type) = S(member); Cdr(type) = STACK_(0+5);
2467 STACK_3 = type;
2468 }
2469 error(keyword_error,
2470 GETTEXT("Illegal keyword/value pair ~S, ~S in argument list.\n"
2471 "The allowed keywords are ~S"));
2472 }
2473 }
2474 }
2475 done:
2476 skipSTACK(2);
2477 VALUES1(NIL);
2478 }
2479
2480 LISPSPECFORM(and, 0,0,body)
2481 { /* (AND {form}), CLTL p. 82 */
2482 var object body = popSTACK();
2483 if (atomp(body)) {
2484 VALUES1(T); /* (AND) -> T */
2485 } else {
2486 while (1) {
2487 pushSTACK(Cdr(body));
2488 eval(Car(body)); /* evaluate form */
2489 body = popSTACK();
2490 if (atomp(body))
2491 break; /* at the end: return values of the last form */
2492 if (nullp(value1)) {
2493 mv_count=1; break; /* prematurely: 1 value NIL */
2494 }
2495 }
2496 }
2497 }
2498
2499 LISPSPECFORM(or, 0,0,body)
2500 { /* (OR {form}), CLTL p. 83 */
2501 var object body = popSTACK();
2502 if (atomp(body)) {
2503 VALUES1(NIL); /* (OR) -> NIL */
2504 } else {
2505 while (1) {
2506 pushSTACK(Cdr(body));
2507 eval(Car(body)); /* evaluate form */
2508 body = popSTACK();
2509 if (atomp(body))
2510 break; /* at the end: return values of the last form */
2511 if (!nullp(value1)) {
2512 mv_count=1; break; /* prematurely: 1 value /=NIL */
2513 }
2514 }
2515 }
2516 }
2517
2518 LISPFUN(xor,seclass_foldable,0,0,rest,nokey,0,NIL)
2519 { /* (XOR {form}) returns either 2 values: the unique non-NIL value
2520 and its index in the argument list; or NIL */
2521 VALUES1(NIL); /* for the case of all NILs*/
2522 while (argcount) {
2523 var object arg = popSTACK();
2524 if (!nullp(arg)) {
2525 if (!nullp(value1)) {
2526 VALUES1(NIL);
2527 skipSTACK(--argcount);
2528 return;
2529 } else
2530 VALUES2(arg,fixnum(argcount));
2531 }
2532 argcount--;
2533 }
2534 }
2535
2536 /* From now on, the table macro has a different use: */
2537 #undef LISPSPECFORM
2538
2539 /* table of all Fsubr-functions: */
2540 global const struct fsubr_tab_ fsubr_tab = {
2541 #define LISPSPECFORM LISPSPECFORM_D
2542 #include "fsubr.c"
2543 #undef LISPSPECFORM
2544 };
2545