1 /*
2 * EVAL, APPLY and bytecode interpreter for CLISP
3 * Bruno Haible 1990-2008, 2016-2017
4 * Sam Steingold 1998-2012, 2016-2017
5 * German comments translated into English: Stefan Kain 2001-08-13
6 */
7 #include "lispbibl.c"
8
9 /* function-table:
10 In this table only SUBRS are listed, which may be inlined by the compiler.
11 In FUNTAB1 and FUNTAB2 SUBRs without Rest-Parameter (i.e. with
12 fixed number of arguments known at compile-time) are listed.
13 In FUNTABR SUBRs with Rest-Parameter are listed. */
14 #define _(name) &subr_tab.D_##name /* address of SUBR name, like L(name) */
15 /* FUNTAB1 and FUNTAB2, first: */
16 local const Subr FUNTAB[] = {
17 /* SPVW : 0 SUBRs */
18 /* EVAL : 3 SUBRs */
19 _(funtabref), _(subr_info), _(special_variable_p),
20 /* ARRAY : 30-2 SUBRs */
21 _(copy_simple_vector), /* _(svref), _(psvstore), */ _(row_major_aref),
22 _(row_major_store), _(array_element_type), _(array_rank),
23 _(array_dimension), _(array_dimensions), _(array_total_size),
24 _(adjustable_array_p), _(bit_and), _(bit_ior), _(bit_xor), _(bit_eqv),
25 _(bit_nand), _(bit_nor), _(bit_andc1), _(bit_andc2), _(bit_orc1),
26 _(bit_orc2), _(bit_not), _(array_has_fill_pointer_p), _(fill_pointer),
27 _(set_fill_pointer), _(vector_push), _(vector_pop), _(vector_push_extend),
28 _(make_array), _(adjust_array),
29 /* CHARSTRG : 54 SUBRs */
30 _(standard_char_p), _(graphic_char_p), _(string_char_p), _(alpha_char_p),
31 _(upper_case_p), _(lower_case_p), _(both_case_p), _(digit_char_p),
32 _(alphanumericp), _(char_code), _(code_char), _(character), _(char_upcase),
33 _(char_downcase), _(digit_char), _(char_int), _(int_char), _(char_name),
34 _(char), _(schar), _(store_char), _(store_schar),
35 _(string_eq), _(cs_string_eq), _(string_noteq), _(cs_string_noteq),
36 _(string_less), _(cs_string_less), _(string_greater), _(cs_string_greater),
37 _(string_ltequal), _(cs_string_ltequal),
38 _(string_gtequal), _(cs_string_gtequal), _(string_equal),
39 _(string_not_equal), _(string_lessp), _(string_greaterp),
40 _(string_not_greaterp), _(string_not_lessp), _(search_string_eq),
41 _(search_string_equal), _(make_string), _(string_both_trim),
42 _(nstring_upcase), _(string_upcase), _(nstring_downcase),
43 _(string_downcase), _(nstring_capitalize), _(string_capitalize),
44 _(string), _(cs_string), _(name_char), _(substring),
45 /* CONTROL : 25-2 SUBRs */
46 _(symbol_value), /* _(symbol_function), */ _(fdefinition), _(boundp),
47 _(fboundp), _(special_operator_p), _(set), _(makunbound), _(fmakunbound),
48 /* _(values_list), */ _(driver), _(unwind_to_driver), _(macro_function),
49 _(macroexpand), _(macroexpand_1), _(proclaim), _(eval),
50 _(evalhook), _(applyhook), _(constantp), _(function_side_effect),
51 _(function_name_p),_(parse_body), _(keyword_test), _(check_function_name),
52 /* DEBUG : 0 SUBRs */
53 /* ERROR : 1 SUBR */
54 _(invoke_debugger),
55 /* HASHTABL : 11 SUBRs */
56 _(make_hash_table), _(gethash), _(puthash), _(remhash), _(maphash),
57 _(clrhash), _(hash_table_count), _(hash_table_iterator),
58 _(hash_table_iterate), _(class_gethash), _(sxhash),
59 /* IO : 38 SUBRs */
60 _(copy_readtable), _(set_syntax_from_char), _(set_macro_character),
61 _(get_macro_character), _(make_dispatch_macro_character),
62 _(set_dispatch_macro_character), _(get_dispatch_macro_character),
63 _(readL), _(read_preserving_whitespace), _(read_delimited_list),
64 _(read_line), _(read_char), _(unread_char), _(peek_char), _(listenL),
65 _(read_char_no_hang), _(clear_input), _(read_from_string), _(parse_integer),
66 _(whitespacep), _(writeL), _(prin1), _(print), _(pprint), _(princ),
67 _(write_to_string), _(prin1_to_string), _(princ_to_string), _(write_char),
68 _(write_string), _(write_line), _(terpri), _(fresh_line), _(elastic_newline),
69 _(finish_output), _(force_output), _(clear_output), _(line_position),
70 /* LIST : 84-36=48 SUBRs */
71 /* _(car), _(cdr), _(caar), _(cadr), _(cdar), _(cddr), _(caaar), _(caadr),
72 _(cadar), _(caddr), _(cdaar), _(cdadr), _(cddar), _(cdddr), _(caaaar),
73 _(caaadr), _(caadar), _(caaddr), _(cadaar), _(cadadr), _(caddar),
74 _(cadddr), _(cdaaar), _(cdaadr), _(cdadar), _(cdaddr), _(cddaar),
75 _(cddadr), _(cdddar), _(cddddr), _(cons), */ _(tree_equal), _(endp),
76 _(list_length), _(nth), /* _(first), _(second), _(third), _(fourth), */
77 _(fifth), _(sixth), _(seventh), _(eighth), _(ninth), _(tenth), /* _(rest), */
78 _(nthcdr), _(last), _(make_list), _(copy_list), _(copy_alist), _(memq),
79 _(copy_tree), _(revappend), _(nreconc), _(list_nreverse), _(butlast),
80 _(nbutlast), _(ldiff), _(rplaca), _(prplaca), _(rplacd), _(prplacd),
81 _(subst), _(subst_if), _(subst_if_not), _(nsubst), _(nsubst_if),
82 _(nsubst_if_not), _(sublis), _(nsublis), _(member), _(member_if),
83 _(member_if_not), _(tailp), _(adjoin), _(acons), _(pairlis), _(assoc),
84 _(assoc_if), _(assoc_if_not), _(rassoc), _(rassoc_if), _(rassoc_if_not),
85 /* MISC : 10 SUBRs */
86 _(lisp_implementation_type), _(lisp_implementation_version),
87 _(software_type), _(software_version), _(identity), _(get_universal_time),
88 _(get_internal_run_time), _(get_internal_real_time), _(psleep), _(pptime),
89 /* PACKAGE : 32 SUBRs */
90 _(make_symbol), _(find_package), _(package_name), _(package_nicknames),
91 _(rename_package), _(package_use_list), _(package_used_by_list),
92 _(package_shadowing_symbols), _(list_all_packages), _(intern), _(cs_intern),
93 _(find_symbol), _(cs_find_symbol), _(unintern), _(export), _(unexport),
94 _(import), _(shadowing_import), _(shadow), _(cs_shadow),
95 _(use_package), _(unuse_package),
96 _(make_package), _(cs_make_package), _(pin_package),
97 _(find_all_symbols), _(cs_find_all_symbols),
98 _(map_symbols), _(map_external_symbols), _(map_all_symbols),
99 _(pfind_package), _(re_export),
100 /* PATHNAME : 27 SUBRs */
101 _(parse_namestring), _(pathname), _(pathnamehost), _(pathnamedevice),
102 _(pathnamedirectory), _(pathnamename), _(pathnametype),
103 _(pathnameversion), _(file_namestring), _(directory_namestring),
104 _(host_namestring), _(merge_pathnames), _(enough_namestring),
105 _(make_pathname), _(namestring), _(truename), _(probe_file),
106 _(delete_file), _(rename_file), _(open), _(directory), _(cd),
107 _(make_directory), _(delete_directory), _(file_write_date), _(file_author),
108 _(savemem),
109 /* PREDTYPE : 48-3 SUBRs */
110 /* _(eq), */ _(eql), _(equal), _(equalp), _(consp), _(atom), _(symbolp),
111 _(stringp), _(numberp), _(compiled_function_p), /* _(null), _(not), */
112 _(closurep), _(listp), _(integerp), _(fixnump), _(rationalp), _(floatp),
113 _(short_float_p), _(single_float_p), _(double_float_p), _(long_float_p),
114 _(realp), _(complexp), _(streamp), _(random_state_p), _(readtablep),
115 _(hash_table_p), _(pathnamep), _(logical_pathname_p), _(characterp),
116 _(functionp), _(packagep), _(arrayp), _(simple_array_p), _(bit_vector_p),
117 _(vectorp), _(simple_vector_p), _(simple_string_p), _(simple_bit_vector_p),
118 _(type_of), _(class_of), _(find_class), _(coerce), _(typep_class),
119 _(defined_class_p), _(proper_list_p), _(pcompiled_function_p),
120 /* RECORD : 29 SUBRs */
121 _(record_ref), _(record_store), _(record_length), _(structure_ref),
122 _(structure_store), _(make_structure), _(copy_structure),
123 _(structure_type_p), _(closure_name), _(closure_codevec),
124 _(closure_consts), _(make_closure), _(make_macro),
125 _(copy_generic_function), _(make_load_time_eval),
126 _(function_macro_function), _(structure_object_p), _(std_instance_p),
127 _(slot_value), _(set_slot_value), _(slot_boundp), _(slot_makunbound),
128 _(slot_exists_p), _(macrop), _(macro_expander), _(symbol_macro_p),
129 _(symbol_macro_expand),
130 _(standard_instance_access), _(set_standard_instance_access),
131 /* SEQUENCE : 40-1 SUBRs */
132 _(sequencep), _(elt), _(setelt), _(subseq), _(copy_seq), _(length),
133 _(reverse), _(nreverse), _(make_sequence), _(reduce), _(fill),
134 _(replace), _(remove), _(remove_if), _(remove_if_not), _(delete),
135 _(delete_if), _(delete_if_not), _(remove_duplicates),
136 _(delete_duplicates), _(substitute), _(substitute_if),
137 _(substitute_if_not), _(nsubstitute), _(nsubstitute_if),
138 _(nsubstitute_if_not), _(find), _(find_if), _(find_if_not), _(position),
139 _(position_if), _(position_if_not), _(count), _(count_if),
140 _(count_if_not), _(mismatch), _(search), _(sort), /* _(stable_sort), */
141 _(merge),
142 /* STREAM : 24 SUBRs */
143 _(file_stream_p), _(make_synonym_stream), _(synonym_stream_p),
144 _(broadcast_stream_p), _(concatenated_stream_p), _(make_two_way_stream),
145 _(two_way_stream_p), _(make_echo_stream), _(echo_stream_p),
146 _(make_string_input_stream), _(string_input_stream_index),
147 _(make_string_output_stream), _(get_output_stream_string),
148 _(make_string_push_stream), _(string_stream_p), _(input_stream_p),
149 _(output_stream_p), _(built_in_stream_element_type),
150 _(stream_external_format), _(built_in_stream_close), _(read_byte),
151 _(write_byte), _(file_position), _(file_length),
152 /* SYMBOL : 15 SUBRs */
153 _(putd), _(proclaim_constant), _(get), _(getf), _(get_properties),
154 _(putplist), _(put), _(remprop), _(symbol_package), _(symbol_plist),
155 _(symbol_name), _(cs_symbol_name), _(keywordp), _(gensym), _(gensym),
156 /* LISPARIT : 84 SUBRs */
157 _(decimal_string), _(zerop), _(plusp), _(minusp), _(oddp), _(evenp),
158 _(plus_one), _(minus_one), _(conjugate), _(exp), _(expt), _(log),
159 _(sqrt), _(isqrt), _(abs), _(phase), _(signum), _(sin), _(cos), _(tan),
160 _(cis), _(asin), _(acos), _(atan), _(sinh), _(cosh), _(tanh), _(asinh),
161 _(acosh), _(atanh), _(float), _(rational), _(rationalize), _(numerator),
162 _(denominator), _(floor), _(ceiling), _(truncate), _(round), _(mod),
163 _(rem), _(ffloor), _(fceiling), _(ftruncate), _(fround), _(decode_float),
164 _(scale_float), _(float_radix), _(float_sign), _(float_digits),
165 _(float_precision), _(integer_decode_float), _(complex), _(realpart),
166 _(imagpart), _(lognand), _(lognor), _(logandc1), _(logandc2), _(logorc1),
167 _(logorc2), _(boole), _(lognot), _(logtest), _(logbitp), _(ash),
168 _(logcount), _(integer_length), _(byte), _(bytesize), _(byteposition),
169 _(ldb), _(ldb_test), _(mask_field), _(dpb), _(deposit_field), _(random),
170 _(make_random_state), _(factorial), _(exquo), _(long_float_digits),
171 _(set_long_float_digits), _(log2), _(log10),
172 /* ENCODING: 1 SUBRs */
173 _(encodingp),
174 }; /* that were 512 = 556 - 44 SUBRs.
175 (- (+ 0 3 30 54 25 0 1 11 38 84 10 32 27 48 29 40 24 15 84 1)
176 (+ 0 0 2 0 2 0 0 0 0 36 0 0 0 3 0 1 0 0 0 0)) */
177 /* Now FUNTABR : */
178 local const Subr FUNTABR[] = {
179 /* SPVW : 0 SUBRs */
180 /* EVAL : 0 SUBRs */
181 /* ARRAY : 7 SUBRs */
182 _(vector), _(aref), _(store), _(array_in_bounds_p),
183 _(array_row_major_index), _(bit), _(sbit),
184 /* CHARSTRG : 13 SUBRs */
185 _(char_eq), _(char_noteq), _(char_less), _(char_greater),
186 _(char_ltequal), _(char_gtequal), _(char_equal), _(char_not_equal),
187 _(char_lessp), _(char_greaterp), _(char_not_greaterp), _(char_not_lessp),
188 _(string_concat),
189 /* CONTROL : 10 SUBRs */
190 _(apply), _(funcall), _(mapcar), _(maplist), _(mapc),
191 _(mapl), _(mapcan), _(mapcap), _(mapcon), _(values),
192 /* DEBUG : 0 SUBRs */
193 /* ERROR : 2 SUBRs */
194 _(error), _(error_of_type),
195 /* HASHTABL : 1 SUBR */
196 _(class_tuple_gethash),
197 /* IO : 0 SUBRs */
198 /* LIST : 4 SUBRs */
199 _(list), _(liststar), _(append), _(nconc),
200 /* MISC : 0 SUBRs */
201 /* PACKAGE : 0 SUBRs */
202 /* PATHNAME : 0 SUBRs */
203 /* PREDTYPE : 0 SUBRs */
204 /* RECORD : 1 SUBR */
205 _(pallocate_instance),
206 /* SEQUENCE : 7 SUBRs */
207 _(concatenate), _(map), _(map_into), _(some), _(every), _(notany),
208 _(notevery),
209 /* STREAM : 2 SUBRs */
210 _(make_broadcast_stream), _(make_concatenated_stream),
211 /* SYMBOL : 0 SUBRs */
212 /* LISPARIT : 19 SUBRs */
213 _(numequal), _(numunequal), _(smaller), _(greater), _(ltequal),
214 _(gtequal), _(max), _(min), _(plus), _(minus), _(star), _(slash), _(gcd),
215 _(xgcd), _(lcm), _(logior), _(logxor), _(logand), _(logeqv)
216 }; /* That were (+ 0 0 7 13 10 0 2 1 0 4 0 0 0 0 1 7 2 0 19) = 66 SUBRs. */
217 #undef _
218 #define FUNTAB1 (&FUNTAB[0])
219 #define FUNTAB2 (&FUNTAB[256])
220 #define FUNTAB_length (sizeof(FUNTAB)/sizeof(Subr))
221 #define FUNTABR_length (sizeof(FUNTABR)/sizeof(Subr))
222
223 #if defined(DEBUG_SPVW)
check_funtab(void)224 local void check_funtab (void) {
225 uintL i;
226 for (i=0; i < FUNTAB_length; i++)
227 if (FUNTAB[i]->rest_flag != subr_norest) {
228 nobject_out(stdout,FUNTAB[i]->name);
229 printf("=FUNTAB[%lu] accepts &rest\n",(unsigned long)i);
230 }
231 for (i=0; i < FUNTABR_length; i++)
232 if (FUNTABR[i]->rest_flag != subr_rest) {
233 nobject_out(stdout,FUNTABR[i]->name);
234 printf("=FUNTABR[%lu] does NOT accept &rest\n",(unsigned long)i);
235 }
236 printf("FUNTAB_length=%ld\n",(long)FUNTAB_length);
237 if (FUNTAB_length > 512) print(" *** - > 512!\n");
238 printf("FUNTABR_length=%ld\n",(long)FUNTABR_length);
239 if (FUNTABR_length > 256) print(" *** - > 256!\n");
240 }
241 #endif
242
243 /* argument-type-tokens for compiled closures: */
244 typedef enum {
245 cclos_argtype_default,
246 cclos_argtype_0_0,
247 cclos_argtype_1_0,
248 cclos_argtype_2_0,
249 cclos_argtype_3_0,
250 cclos_argtype_4_0,
251 cclos_argtype_5_0,
252 cclos_argtype_0_1,
253 cclos_argtype_1_1,
254 cclos_argtype_2_1,
255 cclos_argtype_3_1,
256 cclos_argtype_4_1,
257 cclos_argtype_0_2,
258 cclos_argtype_1_2,
259 cclos_argtype_2_2,
260 cclos_argtype_3_2,
261 cclos_argtype_0_3,
262 cclos_argtype_1_3,
263 cclos_argtype_2_3,
264 cclos_argtype_0_4,
265 cclos_argtype_1_4,
266 cclos_argtype_0_5,
267 cclos_argtype_0_0_rest,
268 cclos_argtype_1_0_rest,
269 cclos_argtype_2_0_rest,
270 cclos_argtype_3_0_rest,
271 cclos_argtype_4_0_rest,
272 cclos_argtype_0_0_key,
273 cclos_argtype_1_0_key,
274 cclos_argtype_2_0_key,
275 cclos_argtype_3_0_key,
276 cclos_argtype_4_0_key,
277 cclos_argtype_0_1_key,
278 cclos_argtype_1_1_key,
279 cclos_argtype_2_1_key,
280 cclos_argtype_3_1_key,
281 cclos_argtype_0_2_key,
282 cclos_argtype_1_2_key,
283 cclos_argtype_2_2_key,
284 cclos_argtype_0_3_key,
285 cclos_argtype_1_3_key,
286 cclos_argtype_0_4_key,
287 cclos_argtype_for_broken_compilers_that_dont_like_trailing_commas
288 } cclos_argtype_t;
289
290 /* Call of the bytecode-interpreter:
291 interpretes the bytecode of a compiled closure.
292 interpret_bytecode(closure,codevec,index);
293 > closure: compiled closure
294 > codevec: its codevector, a Simple-Bit-Vector
295 > index: Start-Index
296 < mv_count/mv_space: values
297 changes STACK, can trigger GC
298 local Values interpret_bytecode (object closure, object codevec, uintL index);
299 */
300 local /*maygc*/ Values interpret_bytecode_ (object closure, Sbvector codeptr,
301 const uintB* byteptr);
302
303 /* GCC can jump directly to labels.
304 This results in faster code than switch(). */
305 #if defined(GNU) && !(__APPLE_CC__ > 1)
306 #if !defined(UNIX_HPUX) && !defined(NO_FAST_DISPATCH) /* work around HP-UX Linker Bug */
307 #define FAST_DISPATCH
308 #define FAST_DISPATCH_THREADED
309 #endif
310 #endif
311
312 #if defined(USE_JITC)
313 /* replacement for interpret_bytecode_ */
314 local /*maygc*/ Values jitc_run (object closure_in, Sbvector codeptr,
315 const uintB* byteptr_in);
cclosure_run(object closure_in,Sbvector codevec,const uintB * byteptr_in)316 local inline /*maygc*/ Values cclosure_run (object closure_in, Sbvector codevec,
317 const uintB* byteptr_in) {
318 if (cclosure_jitc_p(closure_in)) jitc_run(closure_in,codevec,byteptr_in);
319 else interpret_bytecode_(closure_in,codevec,byteptr_in);
320 }
321 #define interpret_bytecode(closure,codevec,index) \
322 with_saved_back_trace_cclosure(closure, \
323 cclosure_run(closure,TheSbvector(codevec),&TheSbvector(codevec)->data[index]); )
324 #else
325 #define interpret_bytecode(closure,codevec,index) \
326 with_saved_back_trace_cclosure(closure, \
327 interpret_bytecode_(closure,TheSbvector(codevec),&TheSbvector(codevec)->data[index]); )
328 #endif
329
330 /* Values of the bytecodes (256 totally): */
331 typedef enum {
332 #define BYTECODE(code) code,
333 #include "bytecode.c"
334 #undef BYTECODE
335 cod_for_broken_compilers_that_dont_like_trailing_commas
336 } bytecode_enum_t;
337
338
339 /* ---------------------- LISP-FUNCTIONS ----------------------- */
340
341 /* (SYS::%FUNTABREF i) returns the name of function Nr. i from the function-
342 table (a symbol), resp. NIL if i is not in the right range. */
343 LISPFUNNF(funtabref,1)
344 {
345 var object arg = popSTACK(); /* argument */
346 var uintV i;
347 if (posfixnump(arg) /* should be Fixnum >=0 */
348 && (i = posfixnum_to_V(arg),
349 i < FUNTAB_length+FUNTABR_length)) { /* and < table-length */
350 /* Name of the indexed element of the table: */
351 value1 = (i < FUNTAB_length
352 ? FUNTAB[i] /* from FUNTAB1/2 */
353 : FUNTABR[i-FUNTAB_length] /* resp. from FUNTABR */
354 )->name;
355 } else {
356 value1 = NIL; /* or NIL */
357 }
358 mv_count=1; /* as value */
359 }
360
361 /* (SYS::SUBR-INFO obj) returns information for this SUBR, if obj is a SUBR
362 (or a Symbol with a SUBR as global function definition),
363 6 values:
364 name Name,
365 req-count number of required parameters,
366 opt-count number of optional parameters,
367 rest-p flag, if &rest is specified,
368 keywords list of admissible keywords (empty: no &key specified),
369 allow-other-keys flag, if additional keywords are allowed,
370 otherwise NIL. */
371 LISPFUNNR(subr_info,1)
372 {
373 var object obj = popSTACK();
374 if (!subrp(obj)) {
375 if (!(symbolp(obj) && subrp(Symbol_function(obj)))) {
376 VALUES0; return; /* no SUBR -> no value */
377 }
378 obj = Symbol_function(obj);
379 }
380 /* obj is a SUBR */
381 pushSTACK(TheSubr(obj)->name); /* Name */
382 pushSTACK(fixnum(TheSubr(obj)->req_count)); /* req-count (req-nr) */
383 pushSTACK(fixnum(TheSubr(obj)->opt_count)); /* opt-count (opt-nr) */
384 pushSTACK(TheSubr(obj)->rest_flag == subr_norest ? NIL : T); /* rest-p */
385 /* during bootstrap, before defseq.lisp is loaded, this may fail: */
386 coerce_sequence(TheSubr(obj)->keywords,S(list),false);
387 /* keyword-vector as list (during bootstrap: vector) */
388 pushSTACK(eq(value1,nullobj) ? (object)TheSubr(obj)->keywords : value1);
389 pushSTACK(TheSubr(obj)->key_flag == subr_key_allow ? T : NIL); /* allow-other-keys */
390 STACK_to_mv(6); /* 6 values */
391 }
392
393
394 /* ----------------------- SUBROUTINES ----------------------- */
395
396 /* UP: unwinds a frame, which is pointed at by STACK.
397 unwind();
398 The values mv_count/mv_space remain unmodified.
399 If it is no Unwind-Protect-Frame: return normally.
400 If it is a Unwind-Protect-Frame:
401 save the values, climbs(?) up STACK and SP
402 and then calls unwind_protect_to_save.fun .
403 changes STACK
404 can trigger GC */
unwind(void)405 global /*maygc*/ void unwind (void)
406 {
407 var fcint frame_info = framecode(STACK_0);
408 GCTRIGGER_IF(frame_info == APPLY_frame_info || frame_info == TRAPPED_APPLY_frame_info
409 || frame_info == EVAL_frame_info || frame_info == TRAPPED_EVAL_frame_info,
410 GCTRIGGER1(mv_space));
411 #ifdef unwind_bit_t
412 if (frame_info & bit(unwind_bit_t)) /* anything to do? */
413 #else
414 if (frame_info >= unwind_limit_t) /* anything to do? */
415 #endif
416 { /* (not at APPLY, EVAL untrapped, CATCH, HANDLER,
417 IBLOCK or ITAGBODY unnested) */
418 if (frame_info < skip2_limit_t) { /* ENV- or DYNBIND-Frame? */
419 #ifdef entrypoint_bit_t
420 if (frame_info & bit(entrypoint_bit_t)) /* BLOCK, TAGBODY, CATCH etc. ? */
421 #else
422 if (frame_info < entrypoint_limit_t) /* BLOCK, TAGBODY, CATCH etc. ? */
423 #endif
424 /* Frame with Exitpoint */
425 if (frame_info <= blockgo_max_t) { /* BLOCK or TAGBODY? */
426 /* BLOCK_FRAME or TAGBODY_FRAME */
427 if (frame_info == CBLOCK_CTAGBODY_frame_info) { /* compiled? */
428 /* CBLOCK_FRAME or CTAGBODY_FRAME
429 In Cons (NAME/Tags . <Framepointer>) */
430 Cdr(STACK_(frame_ctag)) = disabled; /* disable Exit/Tags */
431 } else {
432 /* IBLOCK_FRAME or ITAGBODY_FRAME, nested
433 In Cons (NAME/Tags . <Framepointer>)
434 (first pair of alist next_env) */
435 Cdr(Car(STACK_(frame_next_env))) = disabled; /* disable Exit/Tags */
436 }
437 } else {
438 /* UNWIND_PROTECT_FRAME DRIVER_FRAME or trapped APPLY/EVAL_FRAME */
439 if (frame_info & dynjump_mask_t) {
440 /* UNWIND_PROTECT_FRAME or DRIVER_FRAME */
441 if (frame_info & bit(driver_bit_t)) {
442 /* DRIVER_FRAME */
443 } else {
444 /* UNWIND_PROTECT_FRAME */
445 enter_frame_at_STACK();
446 }
447 } else {
448 /* trapped APPLY/EVAL_FRAME
449 like in the tracer: */
450 var object values;
451 mv_to_list(); values = popSTACK(); /* pack values into list */
452 dynamic_bind(S(trace_values),values); /* bind *TRACE-VALUES* */
453 break_driver(true); /* call break-driver */
454 list_to_mv(Symbol_value(S(trace_values)), /* build values again */
455 error_mv_toomany(framecode(STACK_(0+3))==
456 TRAPPED_EVAL_frame_info
457 ? S(eval)
458 : S(apply)););
459 dynamic_unbind(S(trace_values)); /* unbind */
460 }
461 }
462 else {
463 #ifdef HAVE_SAVED_REGISTERS
464 if ((frame_info & bit(callback_bit_t)) == 0) {
465 /* CALLBACK_FRAME */
466 var gcv_object_t* new_STACK = topofframe(STACK_0); /* Pointer to Frame */
467 /* set callback_saved_registers: */
468 callback_saved_registers = (struct registers *)(aint)as_oint(STACK_1);
469 /* set STACK, thus unwind frame: */
470 setSTACK(STACK = new_STACK);
471 goto done;
472 } else
473 #endif
474 {
475 /* VAR_FRAME or FUN_FRAME */
476 var gcv_object_t* new_STACK = topofframe(STACK_0); /* Pointer to Frame */
477 if (frame_info & bit(fun_bit_t)) {
478 /* for functions: do nothing */
479 } else {
480 /* VAR_FRAME, bindingptr iterates over the bindings */
481 var gcv_object_t* frame_end = STACKpointable(new_STACK);
482 var gcv_object_t* bindingptr = &STACK_(frame_bindings); /* start of the variable-/functionbindings */
483 while (bindingptr != frame_end) {
484 if (as_oint(*(bindingptr STACKop 0)) & wbit(dynam_bit_o))
485 if (as_oint(*(bindingptr STACKop 0)) & wbit(active_bit_o)) {
486 /* binding static or inactive -> nothing to do
487 binding dynamic and active -> write back value: */
488 Symbolflagged_value(*(bindingptr STACKop varframe_binding_sym)) =
489 *(bindingptr STACKop varframe_binding_value);
490 }
491 bindingptr skipSTACKop varframe_binding_size; /* next binding */
492 }
493 }
494 /* set STACK, thus unwind frame: */
495 setSTACK(STACK = new_STACK);
496 goto done;
497 }
498 }
499 } else {
500 /* DYNBIND_FRAME or CALLBACK_FRAME or ENV_FRAME */
501 if (frame_info & bit(envbind_bit_t)) {
502 /* ENV_FRAME */
503 var gcv_object_t* ptr = &STACK_1;
504 switch (frame_info & envbind_case_mask_t) {
505 case (ENV1V_frame_info & envbind_case_mask_t): /* 1 VAR_ENV */
506 aktenv.var_env = *ptr; ptr skipSTACKop 1; break;
507 case (ENV1F_frame_info & envbind_case_mask_t): /* 1 FUN_ENV */
508 aktenv.fun_env = *ptr; ptr skipSTACKop 1; break;
509 case (ENV1B_frame_info & envbind_case_mask_t): /* 1 BLOCK_ENV */
510 aktenv.block_env = *ptr; ptr skipSTACKop 1; break;
511 case (ENV1G_frame_info & envbind_case_mask_t): /* 1 GO_ENV */
512 aktenv.go_env = *ptr; ptr skipSTACKop 1; break;
513 case (ENV1D_frame_info & envbind_case_mask_t): /* 1 DECL_ENV */
514 aktenv.decl_env = *ptr; ptr skipSTACKop 1; break;
515 case (ENV2VD_frame_info & envbind_case_mask_t): /* 1 VAR_ENV and 1 DECL_ENV */
516 aktenv.var_env = *ptr; ptr skipSTACKop 1;
517 aktenv.decl_env = *ptr; ptr skipSTACKop 1;
518 break;
519 case (ENV5_frame_info & envbind_case_mask_t): /* all 5 Environments */
520 aktenv.var_env = *ptr; ptr skipSTACKop 1;
521 aktenv.fun_env = *ptr; ptr skipSTACKop 1;
522 aktenv.block_env = *ptr; ptr skipSTACKop 1;
523 aktenv.go_env = *ptr; ptr skipSTACKop 1;
524 aktenv.decl_env = *ptr; ptr skipSTACKop 1;
525 break;
526 default: NOTREACHED;
527 }
528 } else {
529 /* DYNBIND_FRAME */
530 var gcv_object_t* new_STACK = topofframe(STACK_0); /* Pointer to Frame */
531 var gcv_object_t* frame_end = STACKpointable(new_STACK);
532 var gcv_object_t* bindingptr = &STACK_1; /* start of the bindings */
533 /* bindingptr iterates through the bindings */
534 while (bindingptr != frame_end) {
535 Symbol_value(*(bindingptr STACKop 0)) = *(bindingptr STACKop 1);
536 bindingptr skipSTACKop 2; /* next binding */
537 }
538 /* set STACK, thus unwind frame: */
539 setSTACK(STACK = new_STACK);
540 goto done;
541 }
542 }
543 }
544 /* set STACK, thus unwind frame: */
545 setSTACK(STACK = topofframe(STACK_0));
546 done: ;
547 }
548
549 /* UP: "unwinds" the STACK up to the next DRIVER_FRAME and
550 jumps into the corresponding top-level-loop.
551 if count=0, unwind to TOP; otherwise reset that many times */
reset(uintL count)552 global _GL_NORETURN_FUNC void reset (uintL count) {
553 /* when unwinding UNWIND-PROTECT-frames, don't save values: */
554 bool top_p = (count==0);
555 gcv_object_t *last_driver_frame = NULL;
556 VALUES0;
557 unwind_protect_to_save.fun = (restartf_t)&reset;
558 unwind_protect_to_save.upto_frame = NULL;
559 while (1) {
560 /* does STACK end here? */
561 if (eq(STACK_0,nullobj) && eq(STACK_1,nullobj)) { /* check STACK_start? */
562 if (last_driver_frame) { /* restart at last driver frame */
563 setSTACK(STACK = last_driver_frame);
564 break;
565 }
566 /* we used to start a new driver() here, but this is wrong because it
567 does not clean up SP & back_trace, just STACK, see
568 https://sourceforge.net/p/clisp/bugs/327/
569 we probably cannot even do NOTREACHED - the STACK is bad. */
570 fprintf(stderr,"\n[%s:%d] reset() found no driver frame (sp=0x%lx-0x%lx)\n",
571 __FILE__,__LINE__,(unsigned long)SP_anchor,(unsigned long)SP());
572 abort();
573 }
574 if (framecode(STACK_0) & bit(frame_bit_t)) {
575 /* at STACK_0: beginning of a frame */
576 if (framecode(STACK_0) == DRIVER_frame_info) { /* DRIVER_FRAME ? */
577 last_driver_frame = STACK; /* save the frame */
578 if (!top_p && --count==0) /* done count resets */
579 break; /* yes -> found */
580 }
581 unwind(); /* unwind frame */
582 } else { /* STACK_0 contains a normal LISP-object */
583 skipSTACK(1);
584 }
585 }
586 /* At STACK_0 a new Driver-Frame starts. */
587 enter_frame_at_STACK();
588 }
589
590 /* UP: dynamically binds the symbols of list symlist
591 to the the values of list vallist.
592 progv(symlist,vallist);
593 > symlist, vallist: two lists
594 Exactly one variable binding frame is constructed.
595 changes STACK
596 can trigger GC */
progv(object symlist,object vallist)597 global maygc void progv (object symlist, object vallist) {
598 /* check symlist */
599 var uintL llen = 0;
600 var bool need_new_symlist = true;
601 pushSTACK(symlist); pushSTACK(vallist);
602 for (pushSTACK(symlist); consp(STACK_0); STACK_0 = Cdr(STACK_0), llen++) {
603 var object sym = check_symbol_non_constant(Car(STACK_0),S(progv));
604 if (!eq(sym,Car(STACK_0))) { /* changed symbol ==> must copy symlist */
605 if (need_new_symlist) { /* have not copied symlist yet */
606 pushSTACK(sym); /* save sym */
607 STACK_1 = STACK_3 = copy_list(STACK_3); /* copy symlist */
608 var uintL pos = llen; /* skip copy ... */
609 while (pos--) STACK_1 = Cdr(STACK_1); /* ... to the right position */
610 need_new_symlist = false; /* do not copy symlist twice */
611 sym = popSTACK(); /* restore sym */
612 }
613 Car(STACK_0) = sym;
614 }
615 #ifdef MULTITHREAD
616 /* allocate per thread value cell for the symbol if it does not have */
617 if (TheSymbol(sym)->tls_index == SYMBOL_TLS_INDEX_NONE) {
618 add_per_thread_special_var(sym);
619 }
620 #endif
621 }
622 skipSTACK(1); vallist = popSTACK(); symlist = popSTACK();
623 /* demand room on STACK: */
624 get_space_on_STACK(llen * 2 * sizeof(gcv_object_t));
625 /* build frame: */
626 var gcv_object_t* top_of_frame = STACK; /* Pointer to Frame */
627 var object symlistr = symlist;
628 while (consp(symlistr)) { /* loop over symbol list */
629 var object sym = Car(symlistr);
630 pushSTACK(Symbol_thread_value(sym)); /* old value of the variables */
631 pushSTACK(sym); /* variable */
632 symlistr = Cdr(symlistr);
633 }
634 finish_frame(DYNBIND);
635 /* building of frame completed, now change the values of the variables: */
636 while (consp(symlist)) {
637 if (atomp(vallist)) {
638 /* value list shorter than symbol list
639 -> all further "values" are #<UNBOUND> */
640 do {
641 Symbol_thread_value(Car(symlist)) = unbound;
642 symlist = Cdr(symlist);
643 } while (consp(symlist));
644 break;
645 }
646 /* symbol obtains new value: */
647 Symbol_thread_value(Car(symlist)) = Car(vallist);
648 symlist = Cdr(symlist); vallist = Cdr(vallist);
649 }
650 }
651
652 /* UP: unwinds the dynamic nesting in STACK up to the frame
653 (exclusively), which is pointed to by upto, and then jumps to it.
654 unwind_upto(upto);
655 > upto: pointer to a frame (into the stack, without typinfo).
656 saves the values mv_count/mv_space.
657 changes STACK,SP
658 can trigger GC
659 then jumps to the frame, which was found. */
unwind_upto(gcv_object_t * upto_frame)660 global _GL_NORETURN_FUNC /*maygc*/ void unwind_upto (gcv_object_t* upto_frame) {
661 GCTRIGGER1(mv_space);
662 unwind_protect_to_save.fun = &unwind_upto;
663 unwind_protect_to_save.upto_frame = upto_frame;
664 while (STACK != upto_frame) { /* arrived at target-frame? */
665 if (framecode(STACK_0) & bit(frame_bit_t)) { /* is it a frame? */
666 unwind(); /* yes -> unwind */
667 /* (if this is a Unwind-Protect-Frame, then
668 unwind_upto(upto_frame) is called again, and we are again here.) */
669 } else {
670 skipSTACK(1); /* no -> simply go ahead */
671 }
672 }
673 /* now STACK points to the FRAME found. */
674 enter_frame_at_STACK();
675 }
676
677 /* UP: throws to the Tag tag and passes the values mv_count/mv_space.
678 returns only, if there is no CATCH-Frame for this tag.
679 throw_to(tag); */
throw_to(object tag)680 global void throw_to (object tag) {
681 /* search for Catch-Frame with Tag = tag: */
682 var gcv_object_t* FRAME = STACK;
683 while (1) { /* search in the Stack starting at FRAME
684 for a CATCH-Frame with the same Tag: */
685 if (eq(FRAME_(0),nullobj)) /* end of Stack? */
686 return; /* yes -> no suitable Catch there -> jump back */
687 if (framecode(FRAME_(0)) & bit(frame_bit_t)) {
688 /* found frame */
689 if ((framecode(FRAME_(0)) == CATCH_frame_info) /* Catch-Frame? */
690 && eq(FRAME_(frame_tag),tag)) /* with the same tag? */
691 break; /* yes -> search-loop finished */
692 /* skip Frame: */
693 FRAME = topofframe(FRAME_(0));
694 } else {
695 FRAME skipSTACKop 1;
696 }
697 }
698 /* FRAME points to the lowest CATCH-Frame with the same Tag */
699 unwind_upto(FRAME); /* unwind upto there, then jump */
700 }
701
702 /* UP: Invokes all handlers for condition cond. Returns only, if none
703 of these handlers feels responsible (i.e. if each handler returns).
704 invoke_handlers(cond);
705 can trigger GC
706 This deactivates the handler, that is called right now,
707 and all newer handlers. */
invoke_handlers(object cond)708 global maygc void invoke_handlers (object cond) {
709 /* Also deactivates the handler being called, and all newer handlers.
710 the handler-ranges, which are screened off: */
711 var stack_range_t* other_ranges = inactive_handlers;
712 var stack_range_t new_range;
713 /* Search for Handler-Frame, that handles a Type with (TYPEP cond type): */
714 var gcv_object_t* FRAME = STACK;
715 while (1) {
716 /* search in Stack starting at FRAME for a suitable HANDLER-Frame: */
717 if (!(other_ranges == NULL) && (FRAME == other_ranges->low_limit)) {
718 FRAME = other_ranges->high_limit;
719 other_ranges = other_ranges->next;
720 } else if (eq(FRAME_(0),nullobj)) { /* End of Stack? */
721 break; /* yes -> finised, jump back */
722 } else if (framecode(FRAME_(0)) & bit(frame_bit_t)) {
723 /* found frame */
724 var fcint frame_info = framecode(FRAME_(0));
725 if (frame_info == HANDLER_frame_info || frame_info == C_HANDLER_frame_info) { /* Handler-Frame? */
726 /* loop over types of the vectors #(type1 label1 ... typem labelm): */
727 var uintL m2 = Svector_length(Car(FRAME_(frame_handlers))); /* 2*m */
728 var uintL i = 0;
729 do {
730 pushSTACK(cond); /* save cond */
731 pushSTACK(cond);
732 pushSTACK(TheSvector(Car(FRAME_(frame_handlers)))->data[i]); /* typei */
733 funcall(S(safe_typep),2); /* execute (SYS::SAFE-TYPEP cond typei) */
734 if (!nullp(value1)) { /* found a suitable handler */
735 /* CLtL2 p. 873, 884:
736 "A handler is executed in the dynamic context
737 of the signaler, except that the set of available condition
738 handlers will have been rebound to the value that was active
739 at the time the condition handler was made active."
740 we make the whole thing bullet-proof by an
741 Unwind-Protect-Frame: */
742 var stack_range_t* saved_inactive_handlers = inactive_handlers;
743 new_range.low_limit = STACK;
744 new_range.high_limit = topofframe(FRAME_(0));
745 new_range.next = other_ranges;
746 var gcv_object_t* top_of_frame = STACK;
747 var sp_jmp_buf returner; /* return point */
748 finish_entry_frame(UNWIND_PROTECT,returner,, {
749 var restartf_t fun = unwind_protect_to_save.fun;
750 var gcv_object_t* arg = unwind_protect_to_save.upto_frame;
751 skipSTACK(2); /* unwind Unwind-Protect-Frame */
752 /* Cleanup: reactivate Handler: */
753 inactive_handlers = saved_inactive_handlers;
754 /* and jump ahead: */
755 fun(arg);
756 NOTREACHED;
757 });
758 if (frame_info == HANDLER_frame_info) {
759 /* deactivate Handler: */
760 inactive_handlers = &new_range;
761 /* make information available for Handler: */
762 handler_args.condition = STACK_(0+2);
763 handler_args.stack = FRAME STACKop 4;
764 handler_args.sp = (SPint*)(aint)as_oint(FRAME_(frame_SP));
765 handler_args.spdepth = Cdr(FRAME_(frame_handlers));
766 /* call Handler: */
767 var object closure = FRAME_(frame_closure);
768 var object codevec = TheCclosure(closure)->clos_codevec;
769 var uintL index = (TheCodevec(codevec)->ccv_flags & bit(7) ? CCV_START_KEY : CCV_START_NONKEY)
770 + (uintL)posfixnum_to_V(TheSvector(Car(FRAME_(frame_handlers)))->data[i+1]);
771 interpret_bytecode(closure,codevec,index);
772 /* reactivate Handler: */
773 inactive_handlers = saved_inactive_handlers;
774 } else { /* call C-Handler - it must deactivate itself! */
775 void* handler_fn = (void*)(aint)as_oint(FRAME_(frame_closure));
776 ((void (*) (void*, gcv_object_t*, object, object)) handler_fn)
777 ((void*)(aint)as_oint(FRAME_(frame_SP)),FRAME,
778 TheSvector(Car(FRAME_(frame_handlers)))->data[i+1],
779 STACK_(0+2));
780 }
781 skipSTACK(2); /* unwind Unwind-Protect-Frame */
782 }
783 cond = popSTACK(); /* cond back */
784 i += 2;
785 } while (i < m2);
786 }
787 /* skip Frame: */
788 FRAME = topofframe(FRAME_(0));
789 } else {
790 FRAME skipSTACKop 1;
791 }
792 }
793 var object handler = Symbol_function(S(global_handler));
794 if (boundp(handler)) { /* unbound during bootstrap */
795 pushSTACK(cond); funcall(handler,1); /* (GLOBAL-HANDLER cond) */
796 }
797 }
798
799 /* UP: finds out, if an object is a function name, i.e. a Symbol or
800 a list of the form (SETF symbol).
801 funnamep(obj)
802 > obj: Object
803 < result: true if function name */
funnamep(object obj)804 global bool funnamep (object obj) {
805 if (symbolp(obj))
806 return true;
807 if (consp(obj) && eq(Car(obj),S(setf))) {
808 obj = Cdr(obj);
809 if (consp(obj) && nullp(Cdr(obj)) && symbolp(Car(obj)))
810 return true;
811 }
812 return false;
813 }
814
815 /* Warns about implementation-dependent reference to a symbol.
816 warn_impdependent(sym);
817 > sym: a symbol
818 can trigger GC */
warn_impdependent(object sym)819 local maygc void warn_impdependent (object sym) {
820 pushSTACK(NIL); pushSTACK(sym);
821 STACK_1 = CLSTEXT("Reference to ~S is implementation-dependent, per ANSI CL 6.1.1.4.");
822 funcall(S(warn),2);
823 }
824
825 /* UP: find whether the symbol is bound in the environment
826 can trigger GC */
symbol_env_search(object sym,object venv)827 local maygc inline gcv_object_t* symbol_env_search (object sym, object venv)
828 {
829 /* Does the binding at bindptr bind the symbol sym? */
830 #ifdef NO_symbolflags
831 #define binds_sym_p(bindingptr) \
832 (eq(*(bindingptr STACKop 1),sym) /* the right symbol? */ \
833 && eq(*(bindingptr STACKop 0),fixnum(bit(active_bit)))) /* active & static? */
834 #else
835 #define binds_sym_p(bindingptr) \
836 (eq(*(bindingptr STACKop 0),SET_BIT(sym,active_bit_o))) /* right symbol & active & static? */
837 #endif
838 next_env:
839 if (framepointerp(venv)) {
840 /* Environment is a Pointer to a variable-binding-frame */
841 var gcv_object_t* FRAME = TheFramepointer(venv);
842 var uintL count = as_oint(FRAME_(frame_count)); /* number of bindings */
843 if (count > 0) {
844 var gcv_object_t* bindingsptr = &FRAME_(frame_bindings); /* 1st binding */
845 do {
846 if (binds_sym_p(bindingsptr)) { /* right symbol & active & static? */
847 if (eq(*(bindingsptr STACKop varframe_binding_value),impdependent)) {
848 pushSTACK(sym); warn_impdependent(sym); sym = popSTACK();
849 } else {
850 return bindingsptr STACKop varframe_binding_value;
851 }
852 }
853 bindingsptr skipSTACKop varframe_binding_size; /* no: next binding */
854 } while (--count);
855 }
856 venv = FRAME_(frame_next_env);
857 goto next_env;
858 }
859 var bool from_inside_macrolet = false;
860 for (;;) {
861 if (simple_vector_p(venv)) {
862 /* environment is a simple-vector */
863 var uintL count = floor(Svector_length(venv),2); /* number of bindings */
864 var gcv_object_t* ptr = &TheSvector(venv)->data[0];
865 dotimesL(count,count, {
866 if (eq(*ptr,sym)) { /* right symbol? */
867 if (from_inside_macrolet && !eq(*(ptr+1),specdecl)
868 && !symbolmacrop(*(ptr+1)))
869 goto macrolet_error;
870 if (eq(*(ptr+1),impdependent)) {
871 pushSTACK(sym); warn_impdependent(sym); sym = popSTACK();
872 } else {
873 return ptr+1;
874 }
875 }
876 ptr += 2; /* next binding */
877 });
878 venv = *ptr; /* next environment */
879 continue;
880 } else if (consp(venv)) {
881 /* environment is a MACROLET capsule */
882 ASSERT(eq(Car(venv),S(macrolet)));
883 from_inside_macrolet = true;
884 venv = Cdr(venv);
885 continue;
886 } else
887 break;
888 }
889 /* Environment is NIL */
890 return NULL;
891 #undef binds_sym_p
892 macrolet_error:
893 /* <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/speope_fletcm_scm_macrolet.html#macrolet>
894 "the consequences are undefined if the local macro definitions reference
895 any local variable or function bindings that are visible in that lexical
896 environment." */
897 pushSTACK(sym); /* SOURCE-PROGRAM-ERROR slot DETAIL */
898 pushSTACK(S(macrolet)); pushSTACK(sym);
899 error(program_error,
900 GETTEXT("Invalid access to the value of the lexical variable ~S from within a ~S definition"));
901 }
902
903 /* (SYS::SPECIAL-VARIABLE-P symbol &optional environment)
904 tests whether the symbol is a special variable or a constant.
905 A missing or NIL environment means the global environment. */
906 LISPFUN(special_variable_p,seclass_read,1,1,norest,nokey,0,NIL)
907 {
908 var object symbol = check_symbol(STACK_1);
909 var object env = STACK_0; skipSTACK(2);
910 if (special_var_p(TheSymbol(symbol))) {
911 value1 = T;
912 } else if (missingp(env)) {
913 value1 = NIL;
914 } else {
915 if (simple_vector_p(env)) {
916 var uintL len = Svector_length(env);
917 if (len == 2 || len == 5)
918 env = TheSvector(env)->data[0]; /* venv */
919 else
920 error_environment(env);
921 }
922 var gcv_object_t *binding = symbol_env_search(symbol,env);
923 if ((binding != NULL) && eq(*binding,specdecl))
924 value1 = T;
925 else
926 value1 = NIL;
927 }
928 mv_count = 1;
929 }
930
931 /* UP: returns the value of a symbol in an environment.
932 sym_value(symbol,venv,&symbolmacro)
933 > symbol: Symbol
934 > venv: a Variable- and Symbolmacro-Environment
935 < symbolmacro: symbol-macro definition, or nullobj if not a symbol-macro
936 < result: value of the symbol in this environment, or
937 nullobj if a symbol-macro
938 can trigger GC */
sym_value(object sym,object env,object * symbolmacro_)939 local maygc gcv_object_t sym_value (object sym, object env, object* symbolmacro_)
940 {
941 if (special_var_p(TheSymbol(sym))) {
942 /* Constants and symbols declared special have only global values. */
943 goto global_value;
944 } else {
945 pushSTACK(sym);
946 var gcv_object_t* binding = symbol_env_search(sym,env);
947 sym = popSTACK();
948 if (binding != NULL) {
949 var object val = *binding;
950 if (eq(val,specdecl))
951 goto global_value;
952 if (symbolmacrop(val)) {
953 *symbolmacro_ = val;
954 return nullobj;
955 }
956 *symbolmacro_ = nullobj;
957 return val;
958 }
959 if (symmacro_var_p(TheSymbol(sym))) {
960 /* Fetch the symbol-macro definition from the property list: */
961 var object symbolmacro = get(sym,S(symbolmacro));
962 if (!eq(symbolmacro,unbound)) {
963 ASSERT(globalsymbolmacrop(symbolmacro));
964 *symbolmacro_ = TheGlobalSymbolmacro(symbolmacro)->globalsymbolmacro_definition;
965 return nullobj;
966 }
967 /* Huh? The symbol-macro definition got lost. */
968 clear_symmacro_flag(TheSymbol(sym));
969 }
970 }
971 global_value: /* the global (dynamic) value of the Symbol */
972 *symbolmacro_ = nullobj;
973 return Symbol_value(sym);
974 }
975
976 /* UP: determines, if a Symbol is a Macro in the current environment.
977 sym_macrop(symbol)
978 > symbol: Symbol
979 < result: true if sym is a Symbol-Macro
980 can trigger GC */
sym_macrop(object sym)981 global maygc bool sym_macrop (object sym) {
982 var object symbolmacro;
983 sym_value(sym,aktenv.var_env,&symbolmacro);
984 return !eq(symbolmacro,nullobj);
985 }
986
987 /* UP: Sets the value of a Symbol in the current Environment.
988 setq(symbol,value);
989 > symbol: Symbol, no constant, not a symbol-macro in the current Environment
990 > value: desired value of the Symbols in the current Environment
991 < result: value
992 can trigger GC */
setq(object sym,object value)993 global maygc object setq (object sym, object value)
994 {
995 pushSTACK(value); pushSTACK(sym);
996 if (special_var_p(TheSymbol(sym))) {
997 /* Constants and symbols declared special have only global values. */
998 goto global_value;
999 } else {
1000 var gcv_object_t* binding = symbol_env_search(sym,aktenv.var_env);
1001 if (binding != NULL) {
1002 var object val = *binding;
1003 if (eq(val,specdecl))
1004 goto global_value;
1005 ASSERT(!symbolmacrop(val));
1006 skipSTACK(1);
1007 return *binding = popSTACK();
1008 }
1009 ASSERT(!symmacro_var_p(TheSymbol(STACK_0)));
1010 }
1011 global_value: /* the global (dynamic) value of the Symbol */
1012 symbol_value_check_lock(S(setq),STACK_0);
1013 Symbol_value(STACK_0) = STACK_1;
1014 skipSTACK(1);
1015 return popSTACK();
1016 }
1017
1018 /* UP: returns for a Symbol its function definition in an Environment
1019 sym_function(sym,fenv)
1020 > sym: function name (e.g. Symbol)
1021 > fenv: a function- and macro-bindung-environment
1022 < result: function definition, either unbound (if undefined function)
1023 or Closure/SUBR/FSUBR/Macro/FunctionMacro. */
sym_function(object sym,object env)1024 global object sym_function (object sym, object env)
1025 {
1026 var object value;
1027 { next_env:
1028 if (framepointerp(env)) {
1029 /* Environment is a Pointer to a function-binding-frame */
1030 var gcv_object_t* FRAME = TheFramepointer(env);
1031 var uintL count = as_oint(FRAME_(frame_count)); /* number of bindings */
1032 if (count > 0) {
1033 var gcv_object_t* bindingsptr = &FRAME_(frame_bindings); /* pointer to the first binding */
1034 dotimespL(count,count, {
1035 if (equal(*(bindingsptr STACKop 0),sym)) { /* right Symbol? */
1036 value = *(bindingsptr STACKop 1); goto done;
1037 }
1038 bindingsptr skipSTACKop 2; /* no: next binding */
1039 });
1040 }
1041 env = FRAME_(frame_next_env);
1042 goto next_env;
1043 }
1044 var bool from_inside_macrolet = false;
1045 for (;;) {
1046 if (simple_vector_p(env)) {
1047 /* Environment is a Simple-Vector */
1048 var uintL count = floor(Svector_length(env),2); /* number of bindings */
1049 var gcv_object_t* ptr = &TheSvector(env)->data[0];
1050 dotimesL(count,count, {
1051 if (equal(*ptr,sym)) { /* right Symbol? */
1052 value = *(ptr+1);
1053 if (from_inside_macrolet && !macrop(value))
1054 goto macrolet_error;
1055 goto done;
1056 }
1057 ptr += 2; /* next binding */
1058 });
1059 env = *ptr; /* next Environment */
1060 continue;
1061 } else if (consp(env)) {
1062 /* environment is a MACROLET capsule */
1063 ASSERT(eq(Car(env),S(macrolet)));
1064 from_inside_macrolet = true;
1065 env = Cdr(env);
1066 continue;
1067 } else /* Environment is NIL */
1068 goto global_value;
1069 }
1070 }
1071 global_value: /* global function-definition */
1072 if (!symbolp(sym)) {
1073 sym = get(Car(Cdr(sym)),S(setf_function)); /* (get s 'SYS::SETF-FUNCTION) */
1074 if (!symbolp(sym)) /* should be (uninterned) Symbol */
1075 return unbound; /* else undefined */
1076 }
1077 return Symbol_function(sym);
1078 done:
1079 /* Symbol found active in Environment, "Value" value (a Closure or Macro
1080 or FunctionMacro or NIL) if Definition = NIL (during LABELS),
1081 the function is passed for as undefined: */
1082 if (nullp(value))
1083 value = unbound;
1084 return value;
1085 macrolet_error:
1086 /* <http://www.ai.mit.edu/projects/iiip/doc/CommonLISP/HyperSpec/Body/speope_fletcm_scm_macrolet.html#macrolet>
1087 "the consequences are undefined if the local macro definitions reference
1088 any local variable or function bindings that are visible in that lexical
1089 environment." */
1090 pushSTACK(sym); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1091 pushSTACK(S(macrolet)); pushSTACK(sym);
1092 error(source_program_error,
1093 GETTEXT("Invalid access to the local function definition of ~S from within a ~S definition"));
1094 }
1095
1096 /* UP: evaluates a Form in a given Environment.
1097 eval_5env(form,var,fun,block,go,decl);
1098 > var_env: value for VAR_ENV
1099 > fun_env: value for FUN_ENV
1100 > block_env: value for BLOCK_ENV
1101 > go_env: value for GO_ENV
1102 > decl_env: value for DECL_ENV
1103 > form: Form
1104 < mv_count/mv_space: values
1105 can trigger GC */
eval_5env(object form,object var_env,object fun_env,object block_env,object go_env,object decl_env)1106 global maygc Values eval_5env (object form, object var_env, object fun_env,
1107 object block_env, object go_env, object decl_env)
1108 {
1109 /* bind Environments: */
1110 make_ENV5_frame();
1111 /* set current Environments: */
1112 aktenv.var_env = var_env;
1113 aktenv.fun_env = fun_env;
1114 aktenv.block_env = block_env;
1115 aktenv.go_env = go_env;
1116 aktenv.decl_env = decl_env;
1117 /* evaluate Form: */
1118 eval(form);
1119 /* unwind Environment-Frame: */
1120 unwind();
1121 return; /* finished */
1122 }
1123
1124 /* UP: evaluates a form in an empty environment.
1125 eval_noenv(form);
1126 > form: Form
1127 < mv_count/mv_space: values
1128 can trigger GC */
eval_noenv(object form)1129 global maygc Values eval_noenv (object form) {
1130 return_Values eval_5env(form,NIL,NIL,NIL,NIL,O(top_decl_env));
1131 }
1132
1133 /* UP: "nests" a FUN-Environment, i.e. writes all active bindings
1134 from the Stack into freshly allocated vectors.
1135 nest_fun(env)
1136 > env: FUN-Env
1137 < result: same environment, no Pointer into the Stack
1138 can trigger GC */
nest_fun(object env)1139 global maygc object nest_fun (object env)
1140 {
1141 var uintL depth = 0; /* recursion counter := 0 */
1142 /* Pseudorecursion with Input env, Output env. */
1143 nest_start: /* start of recursion */
1144 if (framepointerp(env)) {
1145 /* env is a pointer to a STACK-Frame. */
1146 check_STACK();
1147 pushSTACK(env); /* save env */
1148 /* execute nest_fun(NEXT_ENV(env)) "disrecursified" :-) : */
1149 {
1150 var gcv_object_t* FRAME = TheFramepointer(env);
1151 env = FRAME_(frame_next_env); depth++; goto nest_start;
1152 }
1153 nest_reentry: depth--;
1154 { /* NEXT_ENV is now nested. */
1155 var gcv_object_t* FRAME = TheFramepointer(STACK_0); /* next STACK-Frame to be nested */
1156 STACK_0 = env; /* bisher genestetes Environment */
1157 var uintL bcount = as_oint(FRAME_(frame_count)); /* number of not yet netsted bindings */
1158 if (bcount == 0) {
1159 /* no bindings -> unnecessary, to create a vector. */
1160 env = popSTACK();
1161 } else {
1162 /* create vector for bcount bindings: */
1163 env = allocate_vector(2*bcount+1);
1164 /* and fill: */
1165 {
1166 var gcv_object_t* ptr = &TheSvector(env)->data[0];
1167 var gcv_object_t* bindingsptr = &FRAME_(frame_bindings); /* Pointer to the first binding */
1168 /* put bcount bindings starting at bindingsptr into the vector at ptr: */
1169 dotimespL(bcount,bcount, {
1170 *ptr++ = *(bindingsptr STACKop 0); /* copy binding into the vector */
1171 *ptr++ = *(bindingsptr STACKop 1);
1172 bindingsptr skipSTACKop 2;
1173 });
1174 *ptr++ = popSTACK(); /* put nested NEXT_ENV into vector */
1175 }
1176 FRAME_(frame_next_env) = env; /* Vector as NEXT_ENV into the Frame */
1177 FRAME_(frame_count) = as_object(0); /* new number of not yet nested bindings */
1178 }
1179 }
1180 }
1181 /* finished with this Nest-substep. */
1182 if (depth>0) /* end of recursion */
1183 goto nest_reentry;
1184 return env;
1185 }
1186
1187 /* UP: "nests" a VAR-Environment, i.e. writes all active bindings
1188 from the Stack in freshly allocated vectors.
1189 nest_var(env)
1190 > env: VAR-Env
1191 < result: same Environment, no Pointer in the Stack
1192 can trigger GC */
nest_var(object env)1193 local maygc object nest_var (object env)
1194 {
1195 var uintL depth = 0; /* Recursion counter := 0 */
1196 /* Pseudorecursion with Input env, Output env. */
1197 nest_start: /* start of Recursion */
1198 if (framepointerp(env)) {
1199 /* env is a Pointer to a STACK-Frame. */
1200 check_STACK();
1201 pushSTACK(env); /* save env */
1202 /* execute nest_var(NEXT_ENV(env)) "disrecursified" :-) : */
1203 {
1204 var gcv_object_t* FRAME = TheFramepointer(env);
1205 env = FRAME_(frame_next_env); depth++; goto nest_start;
1206 }
1207 nest_reentry: depth--;
1208 /* NEXT_ENV is now nested. */
1209 {
1210 var gcv_object_t* FRAME = TheFramepointer(STACK_0); /* next STACK-Frame to be nested */
1211 STACK_0 = env; /* formerly nested Environment */
1212 /* Search (from bottom) the first active among the not yet
1213 nested bindings: */
1214 var uintL bcount = as_oint(FRAME_(frame_count)); /* number of not yet nested bindings */
1215 var uintL count = 0;
1216 var gcv_object_t* bindingsptr = &FRAME_(frame_bindings); /* Pointer to the first binding */
1217 while (!((count>=bcount) /* all unnested bindings through? */
1218 || (as_oint(*(bindingsptr STACKop 0)) & wbit(active_bit_o)))) { /* discovered active binding? */
1219 /* no -> continue search: */
1220 bindingsptr skipSTACKop varframe_binding_size;
1221 count++;
1222 }
1223 /* Below bindingsptr are count inactive bindings.
1224 From bindingsptr on there are bcount-count active, to be nested bindings. */
1225 bcount = bcount-count; /* number of bindings to be nested */
1226 if (bcount == 0) {
1227 /* no bindings -> creating a vector is unnecessary. */
1228 env = popSTACK();
1229 } else {
1230 /* create vector for bcount bindings: */
1231 env = allocate_vector(2*bcount+1);
1232 /* and fill: */
1233 {
1234 var gcv_object_t* ptr = &TheSvector(env)->data[0];
1235 /* put bindungs starting at bindingsptr in the vector at ptr: */
1236 dotimespL(bcount,bcount, {
1237 if (as_oint(*(bindingsptr STACKop varframe_binding_mark)) & wbit(dynam_bit_o)) { /* binding dynamic? */
1238 /* dynamic binding, lexical scope */
1239 *ptr++ = symbol_without_flags(*(bindingsptr STACKop varframe_binding_sym)); /* put Symbol without Flag-Bits in the Vector */
1240 *ptr++ = specdecl; /* mark as special reference */
1241 /* binding stays active in the Frame */
1242 } else {
1243 /* static binding, lexical scope */
1244 *(bindingsptr STACKop varframe_binding_mark) =
1245 CLR_BIT(*(bindingsptr STACKop varframe_binding_mark),active_bit_o); /* deactivate binding */
1246 *ptr++ = *(bindingsptr STACKop varframe_binding_sym); /* copy binding in the vector */
1247 *ptr++ = *(bindingsptr STACKop varframe_binding_value);
1248 }
1249 bindingsptr skipSTACKop varframe_binding_size;
1250 });
1251 *ptr++ = popSTACK(); /* put nested NEXT_ENV in the vector */
1252 }
1253 FRAME_(frame_next_env) = env; /* vector as NEXT_ENV in the Frame */
1254 FRAME_(frame_count) = fake_gcv_object(count); /* new number of not yet nested bindings */
1255 }
1256 }
1257 }
1258 /* finished with this Nest-substep. */
1259 if (depth>0) /* end of recursion */
1260 goto nest_reentry;
1261 return env;
1262 }
1263
1264 /* UP: Nests the Environments in *env (i.e. writes all information in
1265 Stack-independent structures) and pushes them onto the STACK.
1266 (The values VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV will not
1267 be changed, because inactive bindings might poss. still sit in the frames.
1268 It has to be feasible, to activate these bindings without change of VAR_ENV.)
1269 nest_env(env)
1270 > gcv_environment_t* env: Pointer to five Environments
1271 < gcv_environment_t* result: Pointer to the Environments in the STACK
1272 changes STACK, can trigger GC */
nest_env(gcv_environment_t * env5)1273 global maygc gcv_environment_t* nest_env (gcv_environment_t* env5)
1274 {
1275 /* First copy all Environments in the STACK: */
1276 make_STACK_env(env5->var_env,env5->fun_env,env5->block_env,env5->go_env,
1277 env5->decl_env,env5 = );
1278 /* DECL_ENV: Not to be changed. */
1279 { /* GO_ENV: */
1280 var object env = env5->go_env;
1281 var uintL depth = 0; /* recursion depth := 0 */
1282 /* pseudo-recursion: nests a GO_ENV. */
1283 /* Input: env, a GO_ENV. Output: env, with Alist. */
1284 nest_go_start: { /* start of recursion */
1285 var gcv_object_t* FRAME;
1286 if (framepointerp(env)) {
1287 /* env is a pointer into the STACK to a ITAGBODY-frame. */
1288 check_STACK();
1289 FRAME = TheFramepointer(env);
1290 if (framecode(FRAME_(0)) & bit(nested_bit_t)) { /* frame already nested? */
1291 env = FRAME_(frame_next_env); /* yes -> fetch former Alist */
1292 } else {
1293 pushSTACK(env); /* save env */
1294 /* execute nest_go(NEXT_ENV(env)) "disrecursivied": */
1295 env = FRAME_(frame_next_env); depth++; goto nest_go_start;
1296 nest_go_reentry: depth--;
1297 { /* NEXT_ENV is now nested. */
1298 var object frame = STACK_0; /* next to be nested STACK-Frame */
1299 FRAME = uTheFramepointer(frame);
1300 STACK_0 = env; /* so far nested Environment */
1301 var gcv_object_t* tagsptr = &FRAME_(frame_bindings); /* Pointer to the bottom Tag */
1302 var gcv_object_t* frame_end = STACKpointable(topofframe(FRAME_(0))); /* Pointer to Frame */
1303 var uintL count = /* number of tags */
1304 /* subtract the pointers tagsptr and frame_end (both without Typinfo!): */
1305 STACK_item_count(tagsptr,frame_end) / 2;
1306 { /* create vector for count tags: */
1307 var object tagvec = allocate_vector(count);
1308 /* and fill: */
1309 if (count > 0) {
1310 var gcv_object_t* ptr = &TheSvector(tagvec)->data[0];
1311 /* put tags starting at tagsptr in the vector at ptr: */
1312 dotimespL(count,count, {
1313 *ptr++ = *(tagsptr STACKop 0);
1314 tagsptr skipSTACKop 2;
1315 });
1316 }
1317 pushSTACK(tagvec); /* and save */
1318 }
1319 { /* create next Alist Cons (cons tag-vector frame-pointer) : */
1320 var object new_cons = allocate_cons();
1321 Car(new_cons) = STACK_0; /* tagvec */
1322 Cdr(new_cons) = frame;
1323 STACK_0 = new_cons;
1324 }
1325 /* and prepend to Alist: */
1326 env = allocate_cons();
1327 Car(env) = popSTACK(); /* new_cons */
1328 Cdr(env) = popSTACK(); /* previous Alist */
1329 FRAME_(frame_next_env) = env; /* store new NEXT_ENV */
1330 *(oint*)(&FRAME_(0)) += (oint)(NESTED_ITAGBODY_frame_info-ITAGBODY_frame_info) << oint_type_shift; /* this frame is now nested. */
1331 }
1332 }
1333 }
1334 /* finished with this Nest-Substep. */
1335 if (depth>0) /* end of Recursion */
1336 goto nest_go_reentry;
1337 env5->go_env = env; /* file nested GO_ENV */
1338 }
1339 }
1340 { /* BLOCK_ENV: */
1341 var object env = env5->block_env;
1342 var uintL depth = 0; /* recursion depth := 0 */
1343 /* Pseudo-Recursion: nests a BLOCK_ENV. */
1344 /* Input: env, a BLOCK_ENV. Output: env, with Alist. */
1345 nest_block_start: { /* start of recursion */
1346 var gcv_object_t* FRAME;
1347 if (framepointerp(env)) {
1348 /* env is a pointer into the STACK to a IBLOCK-Frame. */
1349 check_STACK();
1350 FRAME = TheFramepointer(env);
1351 if (framecode(FRAME_(0)) & bit(nested_bit_t)) { /* Frame already nested? */
1352 env = FRAME_(frame_next_env); /* yes -> fetch previous Alist */
1353 } else {
1354 pushSTACK(env); /* save env */
1355 /* execute nest_block(NEXT_ENV(env)) "disrecursified": */
1356 env = FRAME_(frame_next_env); depth++; goto nest_block_start;
1357 nest_block_reentry: depth--;
1358 { /* NEXT_ENV is now nested. */
1359 var object frame = STACK_0; /* next to be nested STACK-Frame */
1360 FRAME = TheFramepointer(frame);
1361 STACK_0 = env; /* so far nested Environment */
1362 { /* create next Alist Cons (cons Block-Name Frame-Pointer) : */
1363 var object new_cons = allocate_cons();
1364 Car(new_cons) = FRAME_(frame_name);
1365 Cdr(new_cons) = frame;
1366 pushSTACK(new_cons);
1367 }
1368 /* and prepend to the Alist: */
1369 env = allocate_cons();
1370 Car(env) = popSTACK(); /* new_cons */
1371 Cdr(env) = popSTACK(); /* previous Alist */
1372 FRAME_(frame_next_env) = env; /* store new NEXT_ENV */
1373 *(oint*)(&FRAME_(0)) += (oint)(NESTED_IBLOCK_frame_info-IBLOCK_frame_info) << oint_type_shift; /* this frame is now nested. */
1374 }
1375 }
1376 }
1377 }
1378 /* finished with this Nest-Substep. */
1379 if (depth>0) /* end of recursion */
1380 goto nest_block_reentry;
1381 env5->block_env = env; /* file nested BLOCK_ENV */
1382 }
1383 /* FUN_ENV: */
1384 env5->fun_env = nest_fun(env5->fun_env);
1385 /* VAR_ENV: */
1386 env5->var_env = nest_var(env5->var_env);
1387 /* done */
1388 return env5;
1389 }
1390
1391 /* UP: Nests the current environments (i.e. writes all Information in
1392 Stack-independent Structures) and pushes them onto the STACK.
1393 (The values VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV are not
1394 modified, because inactive bindings might poss. still sit in the Frames.
1395 It has to be feasible, to activate these bindings without change of VAR_ENV.)
1396 nest_aktenv()
1397 < gcv_environment* result: Pointer to the Environments in the STACK
1398 changes STACK, can trigger GC */
1399 #define nest_aktenv() nest_env(&aktenv)
1400
1401 /* UP: augments a Declaration-Environment with a decl-spec.
1402 augment_decl_env(declspec,env)
1403 > declspec: Declaration-Specifier, a Cons
1404 > env: Declaration-Environment
1405 < result: new (poss. augmented) Declaration-Environment
1406 can trigger GC */
augment_decl_env(object new_declspec,object env)1407 global maygc object augment_decl_env (object new_declspec, object env)
1408 {
1409 var object decltyp = Car(new_declspec); /* Declaration-Type */
1410 /* Is this a declaration type to be payed attention to?
1411 Is there a Decl-Spec of the form (DECLARATION ... decltyp ...) in env?
1412 Aside: The List O(declaration_types) is the last Decl-Spec in env. */
1413 if (symbolp(decltyp)) {
1414 /* loop over all local to be respected Declaration-Types: */
1415 var object declspecs = env;
1416 while (consp(declspecs)) { /* loop over all declspecs from env */
1417 var object declspec = Car(declspecs);
1418 if (eq(Car(declspec),S(declaration)) /* (DECLARATION ...) ? */
1419 && !nullp(memq(decltyp,Cdr(declspec))))
1420 goto note_declspec;
1421 declspecs = Cdr(declspecs);
1422 }
1423 }
1424 /* not to be respected Declaration. */
1425 return env; /* leave env unchanged */
1426 note_declspec:
1427 /* a to be respected Declaration -> env := (cons new_declspec env) */
1428 pushSTACK(env); pushSTACK(new_declspec);
1429 env = allocate_cons();
1430 Car(env) = popSTACK(); Cdr(env) = popSTACK();
1431 return env;
1432 }
1433
1434 /* UP: expands a form, if possible, (however it doesn't, if FSUBR-Call
1435 or Symbol or FunctionMacro-Call) in an Environment
1436 macroexp(form,venv,fenv);
1437 > form: Form
1438 > venv: a Variable- and Symbolmacro-Environment
1439 > fenv: a Function- and Macrobinding-Environment
1440 < value1: the expansion
1441 < value2: NIL, if not expanded,
1442 T, if expansion has taken place
1443 can trigger GC */
macroexp(object form,object venv,object fenv)1444 global maygc void macroexp (object form, object venv, object fenv)
1445 {
1446 if (consp(form)) { /* only lists can be a macro-call */
1447 var object funname = Car(form); /* function name */
1448 if (symbolp(funname)) {
1449 var object fdef = sym_function(funname,fenv); /* fetch function definition */
1450 /* is it a #<MACRO expander> ? */
1451 if (macrop(fdef)) {
1452 /* yes -> expand:
1453 execute (FUNCALL *MACROEXPAND-HOOK* expander form env) : */
1454 pushSTACK(TheMacro(fdef)->macro_expander); /* expander as first argument */
1455 pushSTACK(form); /* form as second argument */
1456 pushSTACK(fenv);
1457 pushSTACK(nest_var(venv)); /* nested Variable- and Symbolmacro-Environment */
1458 STACK_1 = nest_fun(STACK_1); /* nested Functions- and Macrobinding-Environment */
1459 var object env = allocate_vector(2); /* Environment for both */
1460 TheSvector(env)->data[0] = popSTACK(); /* venv as 1st component */
1461 TheSvector(env)->data[1] = STACK_0; /* fenv as 2nd component */
1462 STACK_0 = env; /* Environment as third Argument */
1463 funcall(Symbol_value(S(macroexpand_hook)),3);
1464 value2 = T; /* expanded Form as 1st value, T as 2nd value */
1465 return;
1466 }
1467 }
1468 }
1469 /* else, don't expand: */
1470 value1 = form; value2 = NIL;
1471 }
1472
1473 /* UP: expands a form, if possible, (also, when FSUBR-Call or
1474 Symbol, however not, when FunctionMacro-Call) in an Environment
1475 macroexp0(form,env);
1476 > form: Form
1477 > env: a Macroexpansion-Environment
1478 < value1: the Expansion
1479 < value2: NIL, if not expanded,
1480 T, if expansion has taken place
1481 can trigger GC */
macroexp0(object form,object env)1482 global maygc void macroexp0 (object form, object env)
1483 {
1484 if (consp(form)) { /* only lists can be a macro-call */
1485 var object funname = Car(form); /* function name */
1486 if (symbolp(funname)) {
1487 var object fdef = sym_function(funname,TheSvector(env)->data[1]); /* fetch function definition */
1488 if (fsubrp(fdef)) {
1489 /* fdef is a FSUBR, so the global function definition was valid.
1490 loop up, if the property list contains a macro definition: */
1491 var object expander = get(funname,S(macro)); /* search for Property SYS::MACRO */
1492 if (boundp(expander)) {
1493 /* found. Expand with th Expander from the property list:
1494 execute (FUNCALL *MACROEXPAND-HOOK* expander form env) : */
1495 pushSTACK(expander); /* expander as first argument */
1496 pushSTACK(form); /* form as second Argument */
1497 pushSTACK(env); /* environment as third argument */
1498 funcall(Symbol_value(S(macroexpand_hook)),3);
1499 value2 = T; /* expanded form as 1st value, t as 2nd value */
1500 return;
1501 }
1502 } else {
1503 /* 4 possibilities:
1504 #UNBOUND/SUBR/Closure (global or lexical function def.)
1505 -> don't expand
1506 #<MACRO expander> (lexical macro definition)
1507 -> expand (call expander)
1508 #<FUNCTION-MACRO function expander> (lexical FunctionMacro-
1509 Definition) -> don't expand, because
1510 (MACRO-FUNCTION funname) => NIL
1511 Symbol (lexical function definition during SYS::%EXPAND)
1512 expand: (list* 'FUNCALL Symbol (cdr form)) */
1513 if (macrop(fdef)) {
1514 /* #<MACRO expander> -> expand:
1515 execute (FUNCALL *MACROEXPAND-HOOK* expander form env) : */
1516 pushSTACK(TheMacro(fdef)->macro_expander); /* Expander as first Argument */
1517 pushSTACK(form); /* Form as second Argument */
1518 pushSTACK(env); /* Environment as third Argument */
1519 funcall(Symbol_value(S(macroexpand_hook)),3);
1520 value2 = T; /* expanded Form as 1st value, T as 2nd value */
1521 return;
1522 } else if (symbolp(fdef)) {
1523 /* fdef a Symbol
1524 Must be expanded to (FUNCALL fdef ...) : */
1525 pushSTACK(Cdr(form)); /* (cdr form) */
1526 pushSTACK(fdef); /* Symbol */
1527 {
1528 var object new_cons = allocate_cons();
1529 Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
1530 STACK_0 = new_cons; /* (cons Symbol (cdr form)) */
1531 }
1532 {
1533 var object new_cons = allocate_cons();
1534 Car(new_cons) = S(funcall); Cdr(new_cons) = popSTACK();
1535 value1 = new_cons; /* (cons 'FUNCALL (cons Symbol (cdr form))) */
1536 }
1537 value2 = T; return; /* expansion has taken place. */
1538 }
1539 }
1540 }
1541 } else if (symbolp(form)) {
1542 pushSTACK(form);
1543 var object symbolmacro;
1544 var object val = sym_value(form,TheSvector(env)->data[0],&symbolmacro);
1545 if (!eq(symbolmacro,nullobj)) { /* found Symbol-Macro? */
1546 /* yes -> expand */
1547 skipSTACK(1);
1548 value1 = TheSymbolmacro(symbolmacro)->symbolmacro_expansion; value2 = T;
1549 return;
1550 }
1551 form = popSTACK();
1552 }
1553 /* else, don't expand: */
1554 value1 = form; value2 = NIL;
1555 }
1556
1557 /* UP: Parse-Declarations-Docstring. Detaches those from a list of forms,
1558 that have to be viewed as declarations resp. documentation string.
1559 parse_dd(formlist)
1560 > formlist: ( {decl|doc-string} . body )
1561 < value1: body
1562 < value2: List of decl-specs
1563 < value3: Doc-String or NIL
1564 < result: name if a (COMPILE name)-declaration occurred,
1565 unbound if a (COMPILE)-declaration occurred, else Fixnum_0
1566 can trigger GC */
parse_dd(object formlist)1567 global maygc object parse_dd (object formlist)
1568 {
1569 pushSTACK(Fixnum_0); /* place for (COMPILE name) */
1570 pushSTACK(formlist); /* store formlist for error message */
1571 pushSTACK(NIL); /* preliminary Doc-String */
1572 pushSTACK(NIL); /* start of decl-spec-List */
1573 /* stack layout: formlist, docstring, declspecs. */
1574 var object body = formlist; /* rest of the form-list */
1575 while (consp(body)) {
1576 var object form = Car(body); /* next form */
1577 var object body_rest = Cdr(body); /* shorten body */
1578 if (stringp(form)) { /* found Doc-String? */
1579 if (atomp(body_rest)) /* at the last position of the form list? */
1580 break; /* yes -> last form can't be a Doc-String! */
1581 if (!nullp(STACK_1)) { /* preceding Doc-String? */
1582 /* yes -> more than one Doc-String is too much: */
1583 pushSTACK(STACK_2); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1584 pushSTACK(STACK_0);
1585 error(source_program_error,
1586 GETTEXT("Too many documentation strings in ~S"));
1587 }
1588 STACK_1 = form; /* new Doc-String */
1589 body = body_rest;
1590 } else if (consp(form) && eq(Car(form),S(declare))) {/* (DECLARE ...) */
1591 /* cons decl-specs one by one onto STACK_0: */
1592 pushSTACK(body_rest); /* save body_rest */
1593 pushSTACK(Cdr(form)); /* list of the new decl-specs */
1594 while (mconsp(STACK_0)) {
1595 var object declspec = Car(STACK_0); /* next decl-spec */
1596 /* check for (COMPILE)
1597 Test: (EQUAL d '(COMPILE)) =
1598 (and (consp d) (eq (car d) 'COMPILE) (null (cdr d))) */
1599 if (consp(declspec)
1600 && eq(Car(declspec),S(compile))) {
1601 if (nullp(Cdr(declspec))) STACK_(3+2) = unbound;
1602 else if (consp(Cdr(declspec)) && funnamep(Car(Cdr(declspec))))
1603 STACK_(3+2) = Car(Cdr(declspec));
1604 else {
1605 pushSTACK(STACK_(2+2)); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1606 pushSTACK(declspec);
1607 error(source_program_error,GETTEXT("Invalid declaration ~S"));
1608 }
1609 }
1610 { /* push this declaration onto STACK_(0+2) : */
1611 pushSTACK(declspec);
1612 var object new_cons = allocate_cons();
1613 Car(new_cons) = popSTACK(); /* declspec */
1614 Cdr(new_cons) = STACK_(0+2);
1615 STACK_(0+2) = new_cons;
1616 }
1617 /* go to next decl-spec: */
1618 STACK_0 = Cdr(STACK_0);
1619 }
1620 skipSTACK(1);
1621 body = popSTACK(); /* body := old body_rest */
1622 } else { /* finished with loop over the form list */
1623 break;
1624 }
1625 }
1626 value1 = body;
1627 value2 = nreverse(popSTACK()); /* decl-spec-List */
1628 value3 = popSTACK(); /* Doc-String */
1629 skipSTACK(1);
1630 return popSTACK();
1631 }
1632
1633 /* UP: binds *EVALHOOK* and *APPLYHOOK* dynamically to the specified values.
1634 bindhooks(evalhook_value,applyhook_value);
1635 > evalhook_value: value for *EVALHOOK*
1636 > applyhook_value: value for *APPLYHOOK*
1637 changes STACK */
bindhooks(object evalhook_value,object applyhook_value)1638 global void bindhooks (object evalhook_value, object applyhook_value) {
1639 { /* build frame: */
1640 var gcv_object_t* top_of_frame = STACK; /* Pointer to Frame */
1641 pushSTACK(Symbol_thread_value(S(evalhookstar))); /* old value of *EVALHOOK* */
1642 pushSTACK(S(evalhookstar)); /* *EVALHOOK* */
1643 pushSTACK(Symbol_thread_value(S(applyhookstar))); /* old value of *APPLYHOOK* */
1644 pushSTACK(S(applyhookstar)); /* *APPLYHOOK* */
1645 finish_frame(DYNBIND);
1646 }
1647 /* Frame got ready, now change the values of the variables: */
1648 Symbol_thread_value(S(evalhookstar)) = evalhook_value; /* (SETQ *EVALHOOK* evalhook_value) */
1649 Symbol_thread_value(S(applyhookstar)) = applyhook_value; /* (SETQ *APPLYHOOK* applyhook_value) */
1650 }
1651
1652 /* UP: binds *EVALHOOK* and *APPLYHOOK* dynamically to NIL.
1653 bindhooks_NIL();
1654 changes STACK */
1655 #define bindhooks_NIL() bindhooks(NIL,NIL)
1656
1657 /* UP: Determines the source-lambdabody of a lambda body.
1658 lambdabody_source(lambdabody)
1659 > lambdabody: Lambdabody (a Cons)
1660 < result: Source-Lambdabody (unbound if no source specified) */
lambdabody_source(object lambdabody)1661 local object lambdabody_source (object lambdabody) {
1662 var object body = Cdr(lambdabody);
1663 /* body = ((DECLARE (SOURCE ...) ...) ...) ? */
1664 if (consp(body)) {
1665 var object form = Car(body); /* first Form */
1666 /* form = (DECLARE (SOURCE ...) ...) ? */
1667 if (consp(form) && eq(Car(form),S(declare))) {
1668 var object declspecs = Cdr(form);
1669 /* declspecs = ((SOURCE ...) ...) ? */
1670 if (consp(declspecs)) {
1671 var object declspec = Car(declspecs);
1672 /* declspec = (SOURCE ...) ? */
1673 if (consp(declspec) && eq(Car(declspec),S(source))) {
1674 var object declspecr = Cdr(declspec);
1675 if (consp(declspecr))
1676 /* found Source */
1677 return Car(declspecr);
1678 }
1679 }
1680 }
1681 }
1682 return unbound;
1683 }
1684
1685 /* UP: Inserts an implicit BLOCK in a lambda body.
1686 add_implicit_block();
1687 > STACK_1: function name
1688 > STACK_0: lambda body
1689 > value1: body
1690 > value2: list of decl-specs
1691 > value3: Doc-String or NIL
1692 < STACK_0: new lambda body
1693 can trigger GC */
add_implicit_block(void)1694 local /*maygc*/ void add_implicit_block (void)
1695 {
1696 GCTRIGGER3(value1,value2,value3);
1697 /* Replace lambdabody with
1698 (cons (car lambdabody) ; lambda list
1699 (multiple-value-bind (body-rest declarations docstring)
1700 (sys::parse-body (cdr lambdabody) t) ; body
1701 (append (if declarations (list (cons 'DECLARE declarations)))
1702 (if docstring (list docstring))
1703 (list (list* 'BLOCK (function-block-name name)
1704 body-rest))))) */
1705 var object new_body;
1706 pushSTACK(value2); /* declarations */
1707 pushSTACK(value3); /* docstring */
1708 pushSTACK(funname_blockname(STACK_(1+2))); /* blockname */
1709 pushSTACK(value1); /* body-rest */
1710 { /* stack layout: name, lambdabody, declarations, docstring,
1711 blockname, body-rest. */
1712 var object tmp = allocate_cons();
1713 Cdr(tmp) = popSTACK(); Car(tmp) = STACK_0;
1714 STACK_0 = tmp;
1715 }
1716 {
1717 var object tmp = allocate_cons();
1718 Car(tmp) = S(block); Cdr(tmp) = STACK_0;
1719 STACK_0 = tmp;
1720 }
1721 { /* stack layout: name, lambdabody, declarations, docstring, block-form. */
1722 var object tmp = allocate_cons();
1723 Car(tmp) = popSTACK();
1724 new_body = tmp;
1725 }
1726 /* stack layout: name, lambdabody, declarations, docstring. */
1727 if (nullp(STACK_0)) {
1728 skipSTACK(1);
1729 } else {
1730 pushSTACK(new_body);
1731 var object tmp = allocate_cons();
1732 Cdr(tmp) = popSTACK(); Car(tmp) = popSTACK();
1733 new_body = tmp;
1734 }
1735 /* stack layout: name, lambdabody, declarations. */
1736 if (nullp(STACK_0)) {
1737 STACK_0 = new_body;
1738 } else {
1739 pushSTACK(new_body);
1740 {
1741 var object tmp = allocate_cons();
1742 Car(tmp) = S(declare); Cdr(tmp) = STACK_1;
1743 STACK_1 = tmp;
1744 }
1745 {
1746 var object tmp = allocate_cons();
1747 Cdr(tmp) = popSTACK(); Car(tmp) = STACK_0;
1748 STACK_0 = tmp;
1749 }
1750 }
1751 { /* stack layout: name, lambdabody, new-body. */
1752 var object tmp = allocate_cons();
1753 Cdr(tmp) = popSTACK(); Car(tmp) = Car(STACK_0);
1754 STACK_0 = tmp;
1755 }
1756 }
1757
1758 LISPFUNNR(add_implicit_block,2)
1759 { /* (ADD-IMPLICIT-BLOCK name (lambda-list . lambda-body))
1760 inserts an implicit BLOCK in the BODY */
1761 parse_dd(Cdr(STACK_0)); /* just the lambda-body */
1762 add_implicit_block();
1763 VALUES1(STACK_0);
1764 skipSTACK(2);
1765 }
1766
1767 LISPFUNNR(function_block_name,1)
1768 { /* returns the name of the implicit block for a function-name */
1769 var object funname =
1770 check_funname(type_error,S(function_block_name),popSTACK());
1771 VALUES1(funname_blockname(funname));
1772 }
1773
1774 /* UP: Creates the corresponding Closure for a Lambdabody by decomposition
1775 of the lambda list and poss. macro-expansion of all forms.
1776 get_closure(lambdabody,name,blockp,env)
1777 > lambdabody: (lambda-list {decl|doc} {form})
1778 > name: Name, a Symbol or (SETF symbol)
1779 > blockp: if an implicit BLOCK has to be inserted
1780 > env: Pointer to the five distinct environments:
1781 env->var_env = VENV, env->fun_env = FENV,
1782 env->block_env = BENV, env->go_env = GENV,
1783 env->decl_env = DENV.
1784 < result: Closure
1785 can trigger GC */
get_closure(object lambdabody,object name,bool blockp,gcv_environment_t * env)1786 global maygc object get_closure (object lambdabody, object name, bool blockp,
1787 gcv_environment_t* env)
1788 {
1789 /* Lambdabody must be a Cons: */
1790 if (atomp(lambdabody)) {
1791 pushSTACK(lambdabody); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1792 pushSTACK(name);
1793 error(source_program_error,GETTEXT("~S: lambda-list for ~S is missing"));
1794 }
1795 { /* and the CAR must be a List: */
1796 var object lambdalist = Car(lambdabody);
1797 if (!listp(lambdalist)) {
1798 pushSTACK(lambdalist); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1799 pushSTACK(lambdalist); pushSTACK(name); pushSTACK(S(function));
1800 error(source_program_error,
1801 GETTEXT("~S: lambda-list for ~S should be a list, not ~S"));
1802 }
1803 }
1804 pushSTACK(name);
1805 pushSTACK(lambdabody);
1806 /* stack layout: name, lambdabody.
1807 decompose ({decl|doc} {form}) */
1808 var object compile_name = parse_dd(Cdr(lambdabody));
1809 if (!eq(Fixnum_0,compile_name)) {
1810 if (boundp(compile_name) && eq(STACK_1/*name*/,S(Klambda)))
1811 STACK_1 = compile_name; /* override :LAMBDA with (COMPILE name) */
1812 /* A (COMPILE)-Declaration occurred.
1813 replace Lambdabody with its source (because some Macros
1814 can be compiled more efficiently than their Macro-Expansion): */
1815 { var object source = lambdabody_source(STACK_0);
1816 if (!boundp(source)) {
1817 if (blockp)
1818 add_implicit_block();
1819 } else {
1820 STACK_0 = source;
1821 }
1822 }
1823 { /* nest environments: */
1824 var gcv_environment_t* stack_env = nest_env(env); /* push on STACK */
1825 #if !defined(STACK_UP)
1826 /* and transfer over here */
1827 var object my_var_env = stack_env->var_env;
1828 var object my_fun_env = stack_env->fun_env;
1829 var object my_block_env = stack_env->block_env;
1830 var object my_go_env = stack_env->go_env;
1831 var object my_decl_env = stack_env->decl_env;
1832 skipSTACK(5); /* and pop from STACK again */
1833 pushSTACK(my_var_env);
1834 pushSTACK(my_fun_env);
1835 pushSTACK(my_block_env);
1836 pushSTACK(my_go_env);
1837 pushSTACK(my_decl_env);
1838 #endif
1839 /* stack layout: name, lambdabody, venv, fenv, benv, genv, denv. */
1840 }
1841 /* (SYS::COMPILE-LAMBDA name lambdabody venv fenv benv genv denv t) : */
1842 pushSTACK(T); funcall(S(compile_lambda),8);
1843 return value1; /* compiled Closure as value */
1844 }
1845 { /* build Interpreted Closure: */
1846 var object source = lambdabody_source(STACK_0);
1847 if (!boundp(source)) { /* no source specified -> expand Lambdabody: */
1848 if (blockp)
1849 add_implicit_block();
1850 /* call (SYS::%EXPAND-LAMBDABODY-MAIN lambdabody venv fenv) : */
1851 pushSTACK(STACK_0); /* Lambdabody */
1852 pushSTACK(nest_var(env->var_env)); /* nested Variable Environment */
1853 pushSTACK(nest_fun(env->fun_env)); /* nested Function Environment */
1854 funcall(S(expand_lambdabody_main),3);
1855 lambdabody = value1; /* expanded Lambdabody */
1856 } else { /* Source specified -> it replaces the old Lambdabody: */
1857 lambdabody = STACK_0; /* Lambdabody */
1858 STACK_0 = source; /* Source-Lambdabody */
1859 }
1860 }
1861 /* Now STACK_0 is the Source-Lambdabody,
1862 lambdabody is the Lambdabody to be used. */
1863 pushSTACK(Car(lambdabody)); /* Lambdalist */
1864 /* decompose ({decl|doc} {form}) : */
1865 parse_dd(Cdr(lambdabody));
1866 pushSTACK(value1); /* Body */
1867 pushSTACK(value2); /* Declarations */
1868 pushSTACK(value3); /* Doc-String or NIL */
1869 var gcv_object_t* closure_; /* Pointer to the Closure in the STACK */
1870 { /* create Closure (filled with NIL): */
1871 var object closure = allocate_closure(iclos_length,seclass_default<<4);
1872 /* and fill partially: */
1873 TheIclosure(closure)->clos_docstring = popSTACK(); /* Doc-String */
1874 var object declarations = popSTACK(); /* Declarations */
1875 TheIclosure(closure)->clos_body = popSTACK(); /* Body */
1876 var object lambdalist = popSTACK(); /* Lambda-List */
1877 TheIclosure(closure)->clos_form = popSTACK(); /* Source-Lambdabody */
1878 TheIclosure(closure)->clos_name = STACK_0; /* Name */
1879 /* and save: */
1880 STACK_0 = closure;
1881 /* stack layout: closure. */
1882 closure_ = &STACK_0; /* Pointer to the Closure in the STACK */
1883 if (!nullpSv(defun_accept_specialized_lambda_list)
1884 && functionp(Symbol_function(S(specialized_lambda_list_to_ordinary)))) {
1885 /* convert lambda list to ordinary */
1886 pushSTACK(declarations); /* save */
1887 pushSTACK(lambdalist); pushSTACK(S(function));
1888 funcall(S(specialized_lambda_list_to_ordinary),2);
1889 lambdalist = value1; /* new ordinary lambda list */
1890 declarations = popSTACK(); /* restore */
1891 if (!nullp(value2)) /* merge in declarations */
1892 declarations = nreconc(value2,declarations);
1893 }
1894 pushSTACK(lambdalist); pushSTACK(lambdalist); pushSTACK(lambdalist);
1895 pushSTACK(declarations);
1896 }
1897 { /* nest Environments and put them nested in the closure: */
1898 var gcv_environment_t* stack_env = nest_env(env);
1899 var object closure = *closure_;
1900 TheIclosure(closure)->clos_var_env = stack_env->var_env ;
1901 TheIclosure(closure)->clos_fun_env = stack_env->fun_env ;
1902 TheIclosure(closure)->clos_block_env = stack_env->block_env;
1903 TheIclosure(closure)->clos_go_env = stack_env->go_env ;
1904 TheIclosure(closure)->clos_decl_env = stack_env->decl_env ;
1905 skipSTACK(5);
1906 /* keywords:=0, as long as &KEY is missing: */
1907 TheIclosure(closure)->clos_keywords = Fixnum_0;
1908 }
1909 /* stack layout:
1910 closure, lambdalist, lalist-save, lalist-rest, declarations */
1911 var uintL spec_count = 0; /* number of dynamic references */
1912 var uintL req_count = 0; /* number of required-parameters */
1913 var uintL opt_count = 0; /* number of optional-parameters */
1914 var uintL key_count = 0; /* number of keyword-parameters */
1915 var uintL aux_count = 0; /* number of &AUX-variables */
1916 var uintL var_count = 0; /* total number of the variables on the STACK */
1917 { /* process declarations:
1918 read dynamically referenced variables from the decl-spec-list
1919 declarations and push them on STACK. Other to be respected
1920 declarations change the declarations-environment of the Closure. */
1921 var object declarations = popSTACK();
1922 while (consp(declarations)) { /* all decl-specs processed? */
1923 var object declspec = Car(declarations);
1924 /* declspec must be a List: */
1925 if (atomp(declspec)) {
1926 pushSTACK(declspec); /* SOURCE-PROGRAM-ERROR slot DETAIL */
1927 pushSTACK(declspec); pushSTACK(S(function));
1928 error(source_program_error,GETTEXT("~S: illegal declaration ~S"));
1929 }
1930 /* process SPECIAL-declaration: */
1931 if (eq(Car(declspec),S(special))) { /* SPECIAL-declaration ? */
1932 var object declspecrest = Cdr(declspec);
1933 while (consp(declspecrest)) {
1934 var object sym = Car(declspecrest);
1935 if (!symbolp(sym)) {
1936 pushSTACK(declarations); pushSTACK(declspec); /* save */
1937 pushSTACK(declspecrest);
1938 sym = check_symbol_in_declaration(sym,S(special),S(function));
1939 declspecrest = popSTACK(); Car(declspecrest) = sym;
1940 declspec = popSTACK(); declarations = popSTACK(); /* restore */
1941 }
1942 /* push Symbol on STACK: */
1943 check_STACK(); pushSTACK(sym); spec_count++; var_count++;
1944 declspecrest = Cdr(declspecrest);
1945 }
1946 }
1947 /* process other declaration: */
1948 pushSTACK(Cdr(declarations)); /* shorten and save declarations */
1949 {
1950 var object denv = TheIclosure(*closure_)->clos_decl_env;
1951 denv = augment_decl_env(declspec,denv);
1952 TheIclosure(*closure_)->clos_decl_env = denv;
1953 }
1954 declarations = popSTACK();
1955 }
1956 }
1957 /* stack layout:
1958 closure, lambdalist, lalist-save, lalist-rest [special symbols]* */
1959 var gcv_object_t *lalist_ = closure_ STACKop -2; /* remaining lambda list */
1960 var gcv_object_t *lalist_save_ = closure_ STACKop -3; /* save fixed items */
1961 var object item; /* element of the lambda list */
1962 /* Macro:
1963 NEXT_ITEM(&OPTIONAL_label,&REST_label,&KEY_label,
1964 &ALLOW-OTHER-KEYS_label,&AUX_label,Ende_label)
1965 shortens the rest of the lambda list, moves the next Element to "item"
1966 and in case of one of the 6 specified lambda-list-markers, it jumps to
1967 the respective locations. */
1968 #define NEXT_ITEM(opt_label,rest_label,key_label,allow_label,aux_label,end_label) \
1969 { if (atomp(*lalist_)) goto end_label; /* Lambda-List finished? */ \
1970 item = Car(*lalist_); *lalist_save_ = *lalist_; /* next element */ \
1971 *lalist_ = Cdr(*lalist_); /* shorten List */ \
1972 if (eq(item,S(LLoptional))) goto opt_label; /* &OPTIONAL ? */ \
1973 if (eq(item,S(LLrest))) goto rest_label; /* &REST ? */ \
1974 if (eq(item,S(LLkey))) goto key_label; /* &KEY ? */ \
1975 if (eq(item,S(LLallow_other_keys))) goto allow_label; /* &ALLOW-OTHER-KEYS ? */ \
1976 if (eq(item,S(LLaux))) goto aux_label; /* &AUX ? */ \
1977 if (eq(item,S(LLbody))) goto badLLkey; /* &BODY ? */ \
1978 }
1979 req: /* process required-parameter push on STACK: */
1980 while (1) {
1981 NEXT_ITEM(opt,rest,key,badLLkey,aux,ende);
1982 item = check_symbol_non_constant(item,S(function));
1983 Car(*lalist_save_) = item;
1984 /* push Variable on STACK: */
1985 check_STACK();
1986 pushSTACK(item); pushSTACK(Fixnum_0); req_count++; var_count++;
1987 }
1988 opt: /* process &OPTIONAL-parameter, push on STACK and
1989 put Init-Forms into the Closure: */
1990 while(1) {
1991 NEXT_ITEM(badLLkey,rest,key,badLLkey,aux,ende);
1992 var object init_form;
1993 /* Parse variable spezification in item:
1994 var or (var [init [svar]])
1995 push var and poss. svar on STACK, set in var poss.
1996 the svar_bit. Returns also init (or NIL) in init_form. */
1997 check_STACK();
1998 if (atomp(item)) {
1999 item = check_symbol_non_constant(item,S(function));
2000 Car(*lalist_save_) = item;
2001 /* push variable on STACK: */
2002 pushSTACK(item); pushSTACK(Fixnum_0); opt_count++; var_count++;
2003 init_form = NIL; /* Default-Init */
2004 } else {
2005 var object item_rest = item;
2006 /* first list-element: var */
2007 pushSTACK(item_rest);
2008 item = check_symbol_non_constant(Car(item),S(function));
2009 item_rest = popSTACK(); Car(item_rest) = item;
2010 item_rest = Cdr(item_rest);
2011 /* push variable on STACK: */
2012 pushSTACK(item); pushSTACK(Fixnum_0); opt_count++; var_count++;
2013 if (consp(item_rest)) {
2014 init_form = Car(item_rest); /* second list-element: init */
2015 item_rest = Cdr(item_rest);
2016 if (consp(item_rest)) {
2017 if (mconsp(Cdr(item_rest))) { /* varspec is too lang */
2018 pushSTACK(item_rest); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2019 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2020 pushSTACK(S(LLoptional)); pushSTACK(S(function));
2021 error(source_program_error,
2022 GETTEXT("~S: variable specification after ~S too long: ~S"));
2023 }
2024 /* third list-element: svar */
2025 pushSTACK(init_form); pushSTACK(item_rest);
2026 item = check_symbol_non_constant(Car(item_rest),S(function));
2027 item_rest = popSTACK(); Car(item_rest) = item;
2028 init_form = popSTACK();
2029 /* set svar-bit for var: */
2030 STACK_0 = fixnum_inc(STACK_0,bit(svar_bit));
2031 /* push variable on STACK: */
2032 pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
2033 }
2034 } else
2035 init_form = NIL; /* Default-Init */
2036 }
2037 /* push init_form in front of (clos_opt_inits closure) : */
2038 pushSTACK(init_form);
2039 {
2040 var object new_cons = allocate_cons();
2041 Car(new_cons) = popSTACK();
2042 var object closure = *closure_;
2043 Cdr(new_cons) = TheIclosure(closure)->clos_opt_inits;
2044 TheIclosure(closure)->clos_opt_inits = new_cons;
2045 }
2046 }
2047 rest: { /* process &REST-parameter and push on Stack: */
2048 NEXT_ITEM(badrest,badrest,badrest,badrest,badrest,badrest);
2049 item = check_symbol_non_constant(item,S(function));
2050 Car(*lalist_save_) = item;
2051 /* push variable on STACK: */
2052 pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
2053 /* set Rest-Flag to T: */
2054 TheIclosure(*closure_)->clos_rest_flag = T;
2055 NEXT_ITEM(badLLkey,badLLkey,key,badLLkey,aux,ende);
2056 pushSTACK(item); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2057 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2058 pushSTACK(S(LLaux)); pushSTACK(S(LLkey));
2059 pushSTACK(S(LLrest)); pushSTACK(S(function));
2060 error(source_program_error,GETTEXT("~S: ~S var must be followed by ~S or ~S or end of list: ~S"));
2061 }
2062 badrest: {
2063 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2064 pushSTACK(STACK_0); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2065 pushSTACK(S(LLrest)); pushSTACK(S(function));
2066 error(source_program_error,
2067 GETTEXT("~S: ~S must be followed by a variable: ~S"));
2068 }
2069 key: /* process &KEY-Parameter, push on STACK
2070 and put Init-Forms in the Closure: */
2071 { TheIclosure(*closure_)->clos_keywords = NIL; } /* keywords:=NIL */
2072 while(1) {
2073 NEXT_ITEM(badLLkey,badLLkey,badLLkey,allow,aux,ende);
2074 var object keyword;
2075 var object init_form;
2076 /* Parse variable-spezification in item:
2077 var or (var [init [svar]]) or ((key var) [init [svar]])
2078 push var and poss. svar on STACK, set in var poss.
2079 the svar_bit. Returns also the Keyword in keyword and
2080 init (or NIL) in init_form. */
2081 check_STACK();
2082 if (atomp(item)) {
2083 item = check_symbol_non_constant(item,S(function));
2084 Car(*lalist_save_) = item;
2085 /* push variable on STACK: */
2086 pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
2087 /* fetch Keyword: */
2088 keyword = intern_keyword(Symbol_name(item));
2089 /* Default-Init: */
2090 init_form = NIL;
2091 } else {
2092 var object item_rest = item; /* (item [init [svar]]) */
2093 item = Car(item); /* first list-element: var or (key var) */
2094 pushSTACK(item_rest); /* save */
2095 if (atomp(item)) {
2096 item = check_symbol_non_constant(item,S(function)); /* item = var */
2097 /* push variable on STACK: */
2098 item_rest = popSTACK(); /* restore */
2099 Car(item_rest) = item; item_rest = Cdr(item_rest); /*([init [svar]])*/
2100 pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
2101 /* fetch Keyword: */
2102 pushSTACK(item_rest); /* save */
2103 keyword = intern_keyword(Symbol_name(item));
2104 item_rest = popSTACK(); /* restore */
2105 } else {
2106 pushSTACK(item);
2107 /* item = (key var) */
2108 keyword = check_symbol(Car(item)); /* key */
2109 item = popSTACK(); Car(item) = keyword;
2110 item = Cdr(item); /* (var) */
2111 if (!(consp(item) && matomp(Cdr(item))))
2112 goto error_keyspec;
2113 pushSTACK(keyword); pushSTACK(item); /* save */
2114 item = check_symbol_non_constant(Car(item),S(function)); /* var */
2115 Car(popSTACK()) = item; keyword = popSTACK(); /* restore */
2116 item_rest = popSTACK(); item_rest = Cdr(item_rest); /*([init [svar]])*/
2117 /* push variable on STACK: */
2118 pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
2119 }
2120 if (consp(item_rest)) {
2121 init_form = Car(item_rest); /* second list-element: init */
2122 item_rest = Cdr(item_rest); /* ([svar]) */
2123 if (consp(item_rest)) {
2124 if (mconsp(Cdr(item_rest)))
2125 goto error_keyspec;
2126 /* third list-element: svar */
2127 pushSTACK(init_form); pushSTACK(keyword); pushSTACK(item_rest);
2128 item = check_symbol_non_constant(Car(item_rest),S(function));
2129 item_rest = popSTACK(); Car(item_rest) = item;
2130 keyword = popSTACK(); init_form = popSTACK(); /* restore */
2131 /* set svar-Bit in var: */
2132 STACK_0 = fixnum_inc(STACK_0,bit(svar_bit));
2133 /* push variable on STACK: */
2134 pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
2135 }
2136 } else
2137 init_form = NIL; /* Default-Init */
2138 }
2139 /* push keyword in front of (clos_keywords closure) and
2140 push init_form in front of (clos_key_inits closure) : */
2141 pushSTACK(init_form); pushSTACK(keyword);
2142 {
2143 var object new_cons = allocate_cons();
2144 Car(new_cons) = popSTACK();
2145 var object closure = *closure_;
2146 Cdr(new_cons) = TheIclosure(closure)->clos_keywords;
2147 TheIclosure(closure)->clos_keywords = new_cons;
2148 }
2149 {
2150 var object new_cons = allocate_cons();
2151 Car(new_cons) = popSTACK();
2152 var object closure = *closure_;
2153 Cdr(new_cons) = TheIclosure(closure)->clos_key_inits;
2154 TheIclosure(closure)->clos_key_inits = new_cons;
2155 }
2156 }
2157 error_keyspec: {
2158 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2159 pushSTACK(STACK_0); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2160 pushSTACK(S(LLkey)); pushSTACK(S(function));
2161 error(source_program_error,
2162 GETTEXT("~S: incorrect variable specification after ~S: ~S"));
2163 }
2164 allow: { /* process &ALLOW-OTHER-KEYS: */
2165 TheIclosure(*closure_)->clos_allow_flag = T; /* set Flag to T */
2166 NEXT_ITEM(badLLkey,badLLkey,badLLkey,badLLkey,aux,ende);
2167 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2168 pushSTACK(STACK_0); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2169 pushSTACK(S(LLaux)); pushSTACK(S(LLallow_other_keys));
2170 pushSTACK(S(function));
2171 error(source_program_error,
2172 GETTEXT("~S: ~S must be followed by ~S or end of list: ~S"));
2173 }
2174 aux: /* process &AUX-Parameter, push on STACK and
2175 put Init-Forms in the Closure: */
2176 while(1) {
2177 NEXT_ITEM(badLLkey,badLLkey,badLLkey,badLLkey,badLLkey,ende);
2178 var object init_form;
2179 /* Parse variable-spezification in item:
2180 var or (var [init])
2181 push var on STACK.
2182 Returns also init (or NIL) in init_form. */
2183 check_STACK();
2184 if (atomp(item)) {
2185 item = check_symbol_non_constant(item,S(function));
2186 Car(*lalist_save_) = item;
2187 /* push variable on STACK: */
2188 pushSTACK(item); pushSTACK(Fixnum_0); aux_count++; var_count++;
2189 init_form = NIL; /* Default-Init */
2190 } else {
2191 var object item_rest = item; pushSTACK(item_rest);
2192 /* first list-element: var */
2193 item = check_symbol_non_constant(Car(item),S(function));
2194 item_rest = popSTACK(); Car(item_rest) = item; item_rest = Cdr(item_rest);
2195 /* push variable on STACK: */
2196 pushSTACK(item); pushSTACK(Fixnum_0); aux_count++; var_count++;
2197 if (consp(item_rest)) {
2198 init_form = Car(item_rest); /* second list-element: init */
2199 if (mconsp(Cdr(item_rest))) { /* varspec too long */
2200 pushSTACK(item_rest); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2201 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2202 pushSTACK(S(LLaux)); pushSTACK(S(function));
2203 error(source_program_error,
2204 GETTEXT("~S: variable specification after ~S too long: ~S"));
2205 }
2206 } else
2207 init_form = NIL; /* Default-Init */
2208 }
2209 /* push init_form in front of (clos_aux_inits closure) : */
2210 pushSTACK(init_form);
2211 {
2212 var object new_cons = allocate_cons();
2213 Car(new_cons) = popSTACK();
2214 var object closure = *closure_;
2215 Cdr(new_cons) = TheIclosure(closure)->clos_aux_inits;
2216 TheIclosure(closure)->clos_aux_inits = new_cons;
2217 }
2218 }
2219 /* Collected error messages: */
2220 badLLkey: {
2221 pushSTACK(item); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2222 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2223 pushSTACK(item); pushSTACK(S(function));
2224 error(source_program_error,
2225 GETTEXT("~S: badly placed lambda-list keyword ~S: ~S"));
2226 }
2227 ende: /* reached list-end */
2228 #undef NEXT_ITEM
2229 if (((uintL)~(uintL)0 > lp_limit_1) && (var_count > lp_limit_1)) {
2230 /* too many parameters? */
2231 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2232 pushSTACK(STACK_0); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2233 pushSTACK(S(function));
2234 error(source_program_error,
2235 GETTEXT("~S: too many parameters in the lambda-list ~S"));
2236 }
2237 /* var_count <= lp_limit_1, therefore all counts fit in an uintC. */
2238 if (!nullp(*lalist_)) { /* is Lambda-List a Dotted List? */
2239 pushSTACK(*lalist_); /* SOURCE-PROGRAM-ERROR slot DETAIL */
2240 pushSTACK(*(closure_ STACKop -1)); /* entire Lambda-List */
2241 pushSTACK(S(function));
2242 error(source_program_error,
2243 GETTEXT("~S: a dot in a lambda-list is allowed only for macros, not here: ~S"));
2244 }
2245 /* Collect variables into a vector and put it into the Closure,
2246 Collect variable-flags into a Byte-Vector and put it into the Closure: */
2247 pushSTACK(allocate_bit_vector(Atype_8Bit,var_count-spec_count)); /* create Byte-Vector */
2248 var object vars = allocate_vector(var_count); /* create Vector */
2249 var object varflags = popSTACK();
2250 { /* write variables in the Vector (last one to the back,
2251 leading ones in front): */
2252 var gcv_object_t* ptr = &TheSvector(vars)->data[var_count];
2253 var uintB* ptrflags = &TheSbvector(varflags)->data[var_count-spec_count];
2254 var uintC count = var_count-spec_count;
2255 while (count--) {
2256 *--ptrflags = (uintB)posfixnum_to_V(popSTACK());
2257 *--ptr = popSTACK();
2258 }
2259 for (count = spec_count; count--;)
2260 *--ptr = popSTACK();
2261 }
2262 var object closure = *closure_;
2263 TheIclosure(closure)->clos_vars = vars;
2264 TheIclosure(closure)->clos_varflags = varflags;
2265 /* write counts in the Closure: */
2266 TheIclosure(closure)->clos_spec_count = fixnum(spec_count);
2267 TheIclosure(closure)->clos_req_count = fixnum(req_count);
2268 TheIclosure(closure)->clos_opt_count = fixnum(opt_count);
2269 TheIclosure(closure)->clos_key_count = fixnum(key_count);
2270 TheIclosure(closure)->clos_aux_count = fixnum(aux_count);
2271 /* In the Variable-Vector the first spec_count variables are the
2272 SPECIAL-declared ones. In each remaining variable the DYNAM_BIT is
2273 set, if it occurs among the SPECIAL-declared one. */
2274 if (spec_count) { /* loop over the remaining variables: */
2275 if (var_count-spec_count > 0) {
2276 var gcv_object_t* othervarptr = &TheSvector(vars)->data[spec_count];
2277 var uintB* othervarflagsptr = &TheSbvector(varflags)->data[0];
2278 var uintC count1 = var_count-spec_count;
2279 do {
2280 var object othervar = *othervarptr++; /* next variable */
2281 { /* Search for it among the SPECIAL-declared variables: */
2282 var gcv_object_t* specvarptr = &TheSvector(vars)->data[0];
2283 var uintC count2 = spec_count;
2284 do {
2285 if (eq(*specvarptr++,othervar)) { /* found? */
2286 /* yes -> so the variable othervar is to be bound dynamically. */
2287 *othervarflagsptr |= bit(dynam_bit); break;
2288 }
2289 } while (--count2);
2290 }
2291 othervarflagsptr++;
2292 } while (--count1);
2293 }
2294 }
2295 /* Finally reverse the accumulated lists in the Closure: */
2296 nreverse(TheIclosure(closure)->clos_opt_inits);
2297 nreverse(TheIclosure(closure)->clos_keywords);
2298 nreverse(TheIclosure(closure)->clos_key_inits);
2299 nreverse(TheIclosure(closure)->clos_aux_inits);
2300 /* stack layout: closure, lambdalist, lalist-save, lalist-rest */
2301 skipSTACK(4);
2302 return closure;
2303 }
2304
2305 /* error, if symbol to be called is a special form.
2306 error_specialform(caller,funname);
2307 > caller: caller (a symbol)
2308 > funname: a symbol */
error_specialform(object caller,object funname)2309 local _Noreturn void error_specialform (object caller, object funname) {
2310 pushSTACK(funname); /* CELL-ERROR slot NAME */
2311 pushSTACK(funname);
2312 pushSTACK(caller);
2313 error(undefined_function,
2314 GETTEXT("~S: ~S is a special operator, not a function"));
2315 }
2316
2317 /* error, if symbol to be called is a macro.
2318 error_macro(caller,funname);
2319 > caller: caller (a symbol)
2320 > funname: a symbol */
error_macro(object caller,object funname)2321 local _Noreturn void error_macro (object caller, object funname) {
2322 pushSTACK(funname); /* CELL-ERROR slot NAME */
2323 pushSTACK(funname);
2324 pushSTACK(caller);
2325 error(undefined_function,GETTEXT("~S: ~S is a macro, not a function"));
2326 }
2327
2328 /* UP: Alters argument to a function.
2329 coerce_function(obj)
2330 > obj: object
2331 < result: object as function (SUBR or Closure)
2332 can trigger GC */
coerce_function(object obj)2333 global maygc object coerce_function (object obj)
2334 {
2335 /* obj should be a symbol, a SUBR or a Closure. */
2336 if (functionp(obj)) {
2337 return obj; /* function is OK */
2338 } else if (symbolp(obj)) {
2339 var object fdef = Symbol_function(obj);
2340 if (functionp(fdef))
2341 return fdef;
2342 else if (orecordp(fdef)) {
2343 switch (Record_type(fdef)) {
2344 case Rectype_Fsubr:
2345 error_specialform(TheSubr(subr_self)->name,obj);
2346 case Rectype_Macro:
2347 error_macro(TheSubr(subr_self)->name,obj);
2348 default: NOTREACHED;
2349 }
2350 } else
2351 return check_fdefinition(obj,TheSubr(subr_self)->name);
2352 } else if (funnamep(obj)) {
2353 /* this could have be done easier but we inline the checks -
2354 symbolp and functionp for performance reasons */
2355 var object symbol = get(Car(Cdr(obj)),S(setf_function)); /* (get ... 'SYS::SETF-FUNCTION) */
2356 if (!symbolp(symbol)) { /* should be symbol */
2357 pushSTACK(obj); symbol = check_symbol(symbol); obj = popSTACK();
2358 }
2359 var object fdef = Symbol_function(symbol);
2360 if (functionp(fdef))
2361 return fdef;
2362 else
2363 return check_fdefinition(obj,TheSubr(subr_self)->name);
2364 } else if (consp(obj) && eq(Car(obj),S(lambda))) { /* (LAMBDA . ...) ? */
2365 error_lambda_expression(TheSubr(subr_self)->name,obj);
2366 } else
2367 return check_function(obj);
2368 }
2369
2370 #ifdef DEBUG_EVAL
2371 /* Emit some trace output for a function call, to *funcall-trace-output*.
2372 trace_call(fun,type_of_call,caller_type);
2373 > object fun: function being called, a SUBR/FSUBR/Closure
2374 > uintB type_of_call: 'A' for apply, 'F' for funcall, 'B' for bytecode
2375 > uintB caller_type: 'F' for fsubr, 'S' for subr,
2376 'C' for cclosure, 'I' for iclosure
2377 can trigger GC */
trace_call(object fun,uintB type_of_call,uintB caller_type)2378 local maygc void trace_call (object fun, uintB type_of_call, uintB caller_type)
2379 {
2380 var object stream = Symbol_value(S(funcall_trace_output)); /* SYS::*FUNCALL-TRACE-OUTPUT* */
2381 /* No output until *funcall-trace-output* has been initialized: */
2382 if (!streamp(stream))
2383 return;
2384 pushSTACK(stream);
2385 if (cclosurep(fun)) {
2386 pushSTACK(Closure_name(fun));
2387 write_ascii_char(&STACK_1,'c');
2388 } else if (closurep(fun)) {
2389 pushSTACK(TheIclosure(fun)->clos_name);
2390 write_ascii_char(&STACK_1,'C');
2391 } else if (subrp(fun)) {
2392 pushSTACK(TheSubr(fun)->name);
2393 write_ascii_char(&STACK_1,'S');
2394 } else if (fsubrp(fun)) {
2395 pushSTACK(TheFsubr(fun)->name);
2396 write_ascii_char(&STACK_1,'F');
2397 } else {
2398 pushSTACK(NIL);
2399 write_ascii_char(&STACK_1,'?');
2400 }
2401 write_ascii_char(&STACK_1,type_of_call); /* output type of call */
2402 write_ascii_char(&STACK_1,caller_type); /* output caller */
2403 write_ascii_char(&STACK_1,'[');
2404 prin1(&STACK_1,STACK_0); /* output function name */
2405 write_ascii_char(&STACK_1,']');
2406 terpri(&STACK_1);
2407 skipSTACK(2);
2408 }
2409 #define TRACE_CALL(fu,tc,ct) \
2410 if (streamp(Symbol_value(S(funcall_trace_output)))) { \
2411 pushSTACK(fu); trace_call(fu,tc,ct); fu = popSTACK(); \
2412 }
2413 #else
2414 #define TRACE_CALL(fu,tc,ct)
2415 #endif
2416
2417 /* Test for illegal keywords
2418 check_for_illegal_keywords(allow_flag,error_statement);
2419 > uintC argcount: Number of Keyword/Value-pairs
2420 > gcv_object_t* rest_args_pointer: Pointer to the 2*argcount remaining arguments
2421 > bool allow_flag: Flag, if &ALLOW-OTHER-KEYS was specified
2422 > for_every_keyword: Macro, which loops over all Keywords and assigns
2423 them to 'keyword'.
2424 > error_statement: Statement, that reports, that bad_keyword is illegal. */
2425 #define check_for_illegal_keywords(allow_flag_expr,caller,error_statement) \
2426 { var gcv_object_t* argptr = rest_args_pointer; /* Pointer to the arguments */ \
2427 var object bad_keyword = nullobj; /* first illegal keyword or nullobj */ \
2428 var object bad_value = nullobj; /* its value */ \
2429 var bool allow_flag = /* Flag for allow-other-keys (if */ \
2430 /* &ALLOW-OTHER-KEYS was specified or ':ALLOW-OTHER-KEY T' occurred) */ \
2431 (allow_flag_expr); \
2432 /* But ':ALLOW-OTHER-KEYS NIL' hides a subsequent ':ALLOW-OTHER-KEYS T' \
2433 (see CLHS 3.4.1.4.1.1). */ \
2434 var bool allow_hidden = false; /* true if seen ':ALLOW-OTHER-KEYS NIL' */ \
2435 var uintC check_count=argcount; \
2436 while (check_count--) { \
2437 var object kw = NEXT(argptr); /* next Argument */ \
2438 var object val = NEXT(argptr); /* and value for it */ \
2439 /* must be a symbol, should be a keyword: */ \
2440 if (!symbolp(kw)) error_key_notkw(kw,caller); \
2441 if (!allow_flag) { /* other keywords allowed? yes -> ok */ \
2442 if (eq(kw,S(Kallow_other_keys))) { \
2443 if (!allow_hidden) { \
2444 if (!nullp(val)) \
2445 allow_flag = true; \
2446 else \
2447 allow_hidden = true; \
2448 } \
2449 } else { \
2450 /* up to now :ALLOW-OTHER-KEYS was not there, and NOALLOW */ \
2451 if (eq(bad_keyword,nullobj)) { /* all Keywords ok so far? */ \
2452 /* must test, if the keyword kw is allowed. */ \
2453 for_every_keyword({ if (eq(keyword,kw)) goto kw_ok; }); \
2454 /* keyword kw was not allowed. */ \
2455 bad_keyword = kw; \
2456 bad_value = val; \
2457 kw_ok: ; \
2458 } \
2459 } \
2460 } \
2461 }; \
2462 if (!allow_flag) \
2463 if (!eq(bad_keyword,nullobj)) { \
2464 /* wrong keyword occurred */ \
2465 error_statement \
2466 } \
2467 }
2468
2469 /* For a Keyword 'keyword' search the pair Key.Value:
2470 find_keyword_value( notfound_statement, found_statement );
2471 > keyword: Keyword
2472 > uintC argcount: Number of Keyword/Value-Pairs
2473 > gcv_object_t* rest_args_pointer: Pointer to the 2*argcount remaining Arguments
2474 > notfound_statement: what is to be done, if not found
2475 > found_statement: what is to be done, if value found */
2476 #define find_keyword_value(notfound_statement,found_statement) \
2477 { var gcv_object_t* argptr = rest_args_pointer; \
2478 var uintC find_count; \
2479 dotimesC(find_count,argcount, { \
2480 if (eq(NEXT(argptr),keyword)) goto kw_found; /* right keyword? */ \
2481 argptr skipSTACKop -1; /* NEXT */ \
2482 }); \
2483 if (true) { notfound_statement } /* not found */ \
2484 else { kw_found: /* found */ \
2485 {var object value = NEXT(argptr); \
2486 found_statement }} \
2487 }
2488
2489 /* UP: Applies an interpreted closure to arguments.
2490 funcall_iclosure(closure,args_pointer,argcount);
2491 > closure: Closure
2492 > args_pointer: Pointer to the arguments (in Stack)
2493 > argcount: Number of Arguments
2494 < mv_count/mv_space: values
2495 < STACK: cleaned up, = args_pointer
2496 can trigger GC */
funcall_iclosure(object closure,gcv_object_t * args_pointer,uintC argcount)2497 local maygc Values funcall_iclosure (object closure, gcv_object_t* args_pointer,
2498 uintC argcount)
2499 {
2500 /* 1st step: finish building of APPLY-frame: */
2501 var sp_jmp_buf my_jmp_buf;
2502 TRACE_CALL(closure,'F','I');
2503 {
2504 var gcv_object_t* top_of_frame = args_pointer; /* Pointer to frame */
2505 pushSTACK(closure);
2506 finish_entry_frame(APPLY,my_jmp_buf,,{
2507 if (mv_count==0) { /* after reentry: pass form? */
2508 closure = STACK_(frame_closure); /* try the same APPLY again */
2509 args_pointer = topofframe(STACK_0);
2510 argcount = STACK_item_count(STACK STACKop frame_args,args_pointer);
2511 } else {
2512 setSTACK(STACK = topofframe(STACK_0)); /* clean STACK ?or unwind()?*/
2513 eval_noenv(value1); return; /* evaluate passed form */
2514 }
2515 });
2516 }
2517 var gcv_object_t* closure_ = &STACK_(frame_closure); /* &closure */
2518 var gcv_object_t* frame_pointer; /* pointer to the frame */
2519 var uintC spec_count = posfixnum_to_V(TheIclosure(closure)->clos_spec_count);
2520 var gcv_object_t *spec_ptr;
2521 { /* 2nd step: build variable-binding-frame: */
2522 var gcv_object_t* top_of_frame = STACK; /* Pointer to Frame */
2523 var object vars = TheIclosure(closure)->clos_vars; /* Vector of variable-names */
2524 var uintL var_count = Svector_length(vars); /* number of variables */
2525 get_space_on_STACK(var_count*varframe_binding_size*sizeof(gcv_object_t));
2526 {
2527 var gcv_object_t* varptr = &TheSvector(vars)->data[0]; /* Pointer to variables in vector */
2528 var uintC count;
2529 /* the special-references first: */
2530 spec_ptr = args_end_pointer;
2531 dotimesC(count,spec_count, {
2532 pushSTACK(specdecl); /* SPECDECL as "value" */
2533 pushSTACK_symbolwithflags(*varptr++,0); /* INactive */
2534 });
2535 frame_pointer = args_end_pointer;
2536 if (var_count-spec_count > 0) {
2537 var uintB* varflagsptr = &TheSbvector(TheIclosure(closure)->clos_varflags)->data[0];
2538 dotimespC(count,var_count-spec_count, {
2539 pushSTACK(NIL); /* NIL as preliminary value */
2540 var object next_var = *varptr++; /* next variable */
2541 var oint next_varflags = (oint)(*varflagsptr++)<<oint_symbolflags_shift; /* with poss. dynam_bit, svar_bit */
2542 if (special_var_p(TheSymbol(next_var))) /* proclaimed SPECIAL? */
2543 next_varflags |= wbit(dynam_bit_o); /* -> bind dynamically */
2544 pushSTACK_symbolwithflags(next_var,next_varflags);
2545 });
2546 }
2547 }
2548 /* VAR_ENV of closure becomes NEXT_ENV in frame: */
2549 pushSTACK(TheIclosure(closure)->clos_var_env);
2550 pushSTACK(fake_gcv_object(var_count)); /* var_count bindings, all still un-nested */
2551 finish_frame(VAR);
2552 }
2553 /* STACK now points below the variable-binding-frame.
2554 frame_pointer = Pointer in the variable-binding-frame, above the first
2555 still inactive binding, below the already active SPECIAL-references. */
2556 { /* 3rd step: bind current environments: */
2557 var object new_var_env = make_framepointer(STACK);
2558 /* this frame will become the new VAR_ENV later. */
2559 make_ENV5_frame();
2560 /* activate the closure-environment: */
2561 aktenv.var_env = new_var_env; /* variable-binding-frame */
2562 aktenv.fun_env = TheIclosure(closure)->clos_fun_env;
2563 aktenv.block_env = TheIclosure(closure)->clos_block_env;
2564 aktenv.go_env = TheIclosure(closure)->clos_go_env;
2565 aktenv.decl_env = TheIclosure(closure)->clos_decl_env;
2566 }
2567 /* stack layout: APPLY-frame, variable-binding-frame, ENV-frame */
2568 { /* 4th step: process parameters: */
2569 check_SP();
2570 /* Macro for binding of variables in variable-frame:
2571 binds the next variable to value, decreases frame_pointer by 2 resp. 3.
2572 (takes advantage of varframe_binding_mark = 0 !) */
2573 #define bind_next_var(value,markptr_assignment) \
2574 { frame_pointer skipSTACKop -varframe_binding_size; \
2575 {var gcv_object_t* markptr = markptr_assignment &Before(frame_pointer); \
2576 if (as_oint(*markptr) & wbit(dynam_bit_o)) { \
2577 /* activate dynamic Binding: */ \
2578 var object sym = *(markptr STACKop varframe_binding_sym); /* var */ \
2579 *(markptr STACKop varframe_binding_value) = /* old value in frame */ \
2580 Symbolflagged_value(sym); \
2581 /* new value in value-cell: */ \
2582 Symbolflagged_value(sym) = (value); \
2583 activate_specdecl(sym,spec_ptr,spec_count); \
2584 } else { /* activate static binding: */ \
2585 /* new value in frame: */ \
2586 *(markptr STACKop varframe_binding_value) = (value); \
2587 } \
2588 *markptr = SET_BIT(*markptr,active_bit_o);/* activate binding */ \
2589 }}
2590 { /* process required parameters: fetch next argument and bind in stack */
2591 var uintC count = posfixnum_to_V(TheIclosure(closure)->clos_req_count);
2592 if (count>0) {
2593 if (argcount < count)
2594 error_too_few_args(unbound,TheIclosure(closure)->clos_name,
2595 argcount,count);
2596 argcount -= count;
2597 dotimespC(count,count, {
2598 var object next_arg = NEXT(args_pointer); /* next argument */
2599 bind_next_var(next_arg,); /* bind next variable */
2600 });
2601 }
2602 }
2603 { /* process optional parameters:
2604 fetch next argument; if there is none,
2605 execute an Init-form; then bind in stack. */
2606 var uintC count = posfixnum_to_V(TheIclosure(closure)->clos_opt_count);
2607 if (count==0)
2608 goto optional_ende;
2609 {
2610 var object inits = TheIclosure(closure)->clos_opt_inits; /*init forms*/
2611 do {
2612 if (argcount==0)
2613 goto optional_aus;
2614 argcount--;
2615 var object next_arg = NEXT(args_pointer); /* next argument */
2616 var gcv_object_t* optmarkptr;
2617 bind_next_var(next_arg,optmarkptr=); /* bind next variable */
2618 if (as_oint(*optmarkptr) & wbit(svar_bit_o)) {
2619 /* supplied-p-Parameter follows? */
2620 *optmarkptr = CLR_BIT(*optmarkptr,svar_bit_o);
2621 bind_next_var(T,); /* yes -> bind to T */
2622 }
2623 inits = Cdr(inits); /* shorten Init-Forms-List */
2624 count--;
2625 } while (count);
2626 goto optional_ende;
2627 optional_aus: /* no more optional arguments here. */
2628 pushSTACK(inits);
2629 }
2630 /* execute all Init-forms of the optional parameters here: */
2631 dotimespC(count,count, {
2632 var object inits = STACK_0; /* remaining Initforms */
2633 STACK_0 = Cdr(inits);
2634 inits = (eval(Car(inits)),value1); /* next Initform, evaluated */
2635 var gcv_object_t* optmarkptr;
2636 bind_next_var(inits,optmarkptr=); /* bind next variable */
2637 if (as_oint(*optmarkptr) & wbit(svar_bit_o)) {
2638 /* supplied-p-Parameter follows? */
2639 *optmarkptr = CLR_BIT(*optmarkptr,svar_bit_o);
2640 bind_next_var(NIL,); /* yes -> bind to NIL */
2641 }
2642 });
2643 closure = *closure_;
2644 /* initialize &REST-parameters without arguments: */
2645 if (!nullp(TheIclosure(closure)->clos_rest_flag)) /* Rest-Flag? */
2646 bind_next_var(NIL,); /* yes -> bind to NIL */
2647 /* initialize &KEY-parameters without arguments : */
2648 count = posfixnum_to_V(TheIclosure(closure)->clos_key_count); /* number of Keyword-parameters */
2649 if (count>0) {
2650 STACK_0 = TheIclosure(closure)->clos_key_inits; /* their Init-forms */
2651 dotimespC(count,count, {
2652 var object inits = STACK_0; /* remaining Initforms */
2653 STACK_0 = Cdr(inits);
2654 inits = (eval(Car(inits)),value1); /* next Initform, evaluated */
2655 var gcv_object_t* keymarkptr;
2656 bind_next_var(inits,keymarkptr=); /* bind next Variable */
2657 if (as_oint(*keymarkptr) & wbit(svar_bit_o)) {
2658 /* supplied-p-Parameter follows? */
2659 *keymarkptr = CLR_BIT(*keymarkptr,svar_bit_o);
2660 bind_next_var(NIL,); /* yes -> bind to NIL */
2661 }
2662 });
2663 closure = *closure_;
2664 }
2665 skipSTACK(1); /* remaining Init-forms forgotten */
2666 goto aux; /* go to the AUX-variables */
2667 }
2668 optional_ende:
2669 /* prepare &KEY-parameters and &REST-parameters: */
2670 if (numberp(TheIclosure(closure)->clos_keywords) /* is keyword a number? */
2671 && nullp(TheIclosure(closure)->clos_rest_flag)) { /* and no Rest-parameter? */
2672 /* yes -> neither &KEY nor &REST specified */
2673 if (argcount>0) { /* still arguments there? -> Error */
2674 pushSTACK(TheIclosure(closure)->clos_name);
2675 /* ANSI CL 3.5.1.3. wants a PROGRAM-ERROR here. */
2676 error(program_error,
2677 GETTEXT("EVAL/APPLY: too many arguments given to ~S"));
2678 }
2679 } else { /* &KEY or &REST present. */
2680 /* process &REST-parameters: */
2681 if (!nullp(TheIclosure(closure)->clos_rest_flag)) { /* &rest? */
2682 /* yes -> collect residual arguments in a list: */
2683 pushSTACK(NIL); /* start of list */
2684 if (argcount>0) {
2685 var gcv_object_t* ptr = args_pointer STACKop -(uintP)argcount;
2686 var uintC count;
2687 dotimespC(count,argcount, {
2688 var object new_cons = allocate_cons();
2689 Car(new_cons) = BEFORE(ptr);
2690 Cdr(new_cons) = STACK_0;
2691 STACK_0 = new_cons;
2692 });
2693 closure = *closure_;
2694 }
2695 var object list = popSTACK(); /* entire list */
2696 bind_next_var(list,); /* bind &REST-parameter to this list */
2697 }
2698 /* process &KEY-parameters: */
2699 if (!numberp(TheIclosure(closure)->clos_keywords)) {
2700 /* Keyword-parameters present */
2701 var gcv_object_t* rest_args_pointer = args_pointer;
2702 /* argcount = number of remaining arguments */
2703 /* halve argcount --> number of pairs Key.Value: */
2704 if (argcount%2) { /* number was odd -> not paired: */
2705 var uintC count = 0;
2706 while (count<argcount) pushSTACK(rest_args_pointer[count++]);
2707 error_key_odd(argcount,TheIclosure(closure)->clos_name);
2708 }
2709 argcount = argcount/2;
2710 { /* test for illegal keywords: */
2711 var object keywords = TheIclosure(closure)->clos_keywords;
2712 #define for_every_keyword(statement) \
2713 { var object keywordsr = keywords; \
2714 while (consp(keywordsr)) { \
2715 var object keyword = Car(keywordsr); \
2716 statement; \
2717 keywordsr = Cdr(keywordsr); \
2718 }}
2719 check_for_illegal_keywords
2720 (!nullp(TheIclosure(closure)->clos_allow_flag),
2721 TheIclosure(closure)->clos_name,
2722 { error_key_badkw(TheIclosure(closure)->clos_name,
2723 bad_keyword,bad_value,
2724 TheIclosure(closure)->clos_keywords);});
2725 #undef for_every_keyword
2726 /* Now assign the Key-values and evaluate the Key-Inits: */
2727 var uintC count = posfixnum_to_V(TheIclosure(closure)->clos_key_count);
2728 if (count > 0) {
2729 var object key_inits = TheIclosure(closure)->clos_key_inits;
2730 dotimespC(count,count, {
2731 var object keyword = Car(keywords); /* Keyword */
2732 var object var_value;
2733 var object svar_value;
2734 /* Find the pair Key.Value for Keyword: */
2735 find_keyword_value({ /* not found, must evaluate the Init: */
2736 pushSTACK(keywords); pushSTACK(key_inits);
2737 var_value = (eval(Car(key_inits)),value1);
2738 key_inits = popSTACK(); keywords = popSTACK();
2739 svar_value = NIL; /* NIL for poss. supplied-p-Parameter */
2740 },{ /* found -> take value: */
2741 var_value = value;
2742 svar_value = T; /* T for poss. supplied-p-Parameter */
2743 });
2744 {
2745 var gcv_object_t* keymarkptr;
2746 bind_next_var(var_value,keymarkptr=); /* bind keyword-var */
2747 if (as_oint(*keymarkptr) & wbit(svar_bit_o)) { /* supplied-p-Parameter follows? */
2748 *keymarkptr = CLR_BIT(*keymarkptr,svar_bit_o);
2749 bind_next_var(svar_value,); /* yes -> bind to NIL resp. T */
2750 }
2751 }
2752 keywords = Cdr(keywords);
2753 key_inits = Cdr(key_inits);
2754 });
2755 }
2756 }
2757 closure = *closure_;
2758 }
2759 }
2760 aux: { /* process &AUX-parameter: */
2761 var uintC count = posfixnum_to_V(TheIclosure(closure)->clos_aux_count);
2762 if (count>0) {
2763 pushSTACK(TheIclosure(closure)->clos_aux_inits); /* Init-forms for &AUX-variables */
2764 dotimespC(count,count, {
2765 var object inits = STACK_0;
2766 STACK_0 = Cdr(inits);
2767 inits = (eval(Car(inits)),value1); /* evaluate nnext Init */
2768 bind_next_var(inits,); /* and bind next variable to it */
2769 });
2770 skipSTACK(1); /* forget remaining Init-forms */
2771 closure = *closure_;
2772 }
2773 }
2774 #undef bind_next_var
2775 }
2776 if (spec_count > 0) activate_specdecls(spec_ptr,spec_count);
2777 /* 5th step: evaluate Body: */
2778 implicit_progn(TheIclosure(closure)->clos_body,NIL);
2779 unwind(); /* unwind ENV-frame */
2780 unwind(); /* unwind variable-binding-frame */
2781 unwind(); /* unwind APPLY-frame */
2782 }
2783
2784 /* UP: provides the assignment of the Key-arguments for SUBRs.
2785 call only, if key_flag /= subr_nokey.
2786 > fun: function, a SUBR
2787 > argcount: number of arguments after optional ones
2788 > STACK_(argcount-1),...,STACK_0: the argcount arguments after the optional ones
2789 > key_args_pointer: Pointer to the Key-parameters in the STACK
2790 > rest_args_pointer: Pointer to the remaining arguments in the STACK
2791 < STACK: set correctly
2792 changes STACK */
match_subr_key(object fun,uintL argcount,gcv_object_t * key_args_pointer,gcv_object_t * rest_args_pointer)2793 local void match_subr_key (object fun, uintL argcount,
2794 gcv_object_t* key_args_pointer,
2795 gcv_object_t* rest_args_pointer) {
2796 /* halve argcount --> the number of pairs Key.Value: */
2797 if (argcount%2) /* number was odd -> not paired: */
2798 error_key_odd(argcount,TheSubr(fun)->name);
2799 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
2800 error_too_many_args(unbound,fun,argcount,ca_limit_1);
2801 /* Due to argcount <= ca_limit_1, all count's fit in a uintC. */
2802 argcount = argcount/2;
2803 { /* test for illegal Keywords: */
2804 var gcv_object_t* keywords_pointer =
2805 &TheSvector(TheSubr(fun)->keywords)->data[0];
2806 var uintC key_count = TheSubr(fun)->key_count;
2807 #define for_every_keyword(statement) \
2808 if (key_count > 0) { \
2809 var gcv_object_t* keywordptr = keywords_pointer; \
2810 var uintC count = key_count; \
2811 do { \
2812 var object keyword = *keywordptr++; \
2813 statement; \
2814 } while (--count); \
2815 }
2816 check_for_illegal_keywords
2817 (TheSubr(fun)->key_flag == subr_key_allow,TheSubr(fun)->name,
2818 { pushSTACK(bad_keyword); /* save bad keyword */
2819 pushSTACK(bad_value); /* save bad value */
2820 pushSTACK(fun); /* save the function */
2821 /* convert Keyword-Vector to a List:
2822 (SYS::COERCE-SEQUENCE kwvec 'LIST) */
2823 coerce_sequence(TheSubr(fun)->keywords,S(list),true);
2824 fun = popSTACK(); bad_value = popSTACK();
2825 bad_keyword = popSTACK();
2826 error_key_badkw(TheSubr(fun)->name,bad_keyword,
2827 bad_value,value1);
2828 });
2829 #undef for_every_keyword
2830 /* now assign Arguments and Parameters: */
2831 if (key_count > 0) {
2832 var gcv_object_t* keywordptr = keywords_pointer;
2833 var gcv_object_t* key_args_ptr = key_args_pointer;
2834 var uintC count;
2835 dotimespC(count,key_count, {
2836 var object keyword = *keywordptr++; /* Keyword */
2837 /* find the pair Key.Value for this Keyword: */
2838 find_keyword_value(
2839 /* not found -> value remains #<UNBOUND> : */
2840 { (void)NEXT(key_args_ptr); },
2841 /* found -> save value: */
2842 { NEXT(key_args_ptr) = value; }
2843 );
2844 });
2845 }
2846 }
2847 /* poss. process Rest-Parameters: */
2848 if (TheSubr(fun)->rest_flag == subr_norest) {
2849 /* SUBR without &REST-Flag: forget remaining Arguments: */
2850 set_args_end_pointer(rest_args_pointer);
2851 }
2852 /* SUBR with &REST-Flag: leave remaining Arguments in Stack */
2853 }
2854
2855 /* UP: provides the assignment between Argument-list and Keyword-parameters
2856 and poss. Rest-parameters of a compiled Closure.
2857 > closure: compiled Closure with &KEY-parameters
2858 > argcount: number of arguments after optional ones
2859 > STACK_(argcount-1),...,STACK_0: the argcount arguments after the optional ones
2860 > key_args_pointer: Pointer to the Key-parameters in the STACK
2861 (poss. also Pointer beneath the Rest-parameters in the STACK,
2862 which is #<UNBOUND>, if it is still to be supplied with)
2863 > rest_args_pointer: Pointer to the remaining Arguments in the STACK
2864 < STACK: set correctly
2865 < result: closure
2866 changes STACK
2867 can trigger GC */
match_cclosure_key(object closure,uintL argcount,gcv_object_t * key_args_pointer,gcv_object_t * rest_args_pointer)2868 local maygc object match_cclosure_key (object closure, uintL argcount,
2869 gcv_object_t* key_args_pointer,
2870 gcv_object_t* rest_args_pointer) {
2871 /* half argcount --> the number of pairs Key.Value: */
2872 if (argcount%2) /* number was odd -> not paired: */
2873 error_key_odd(argcount,Closure_name(closure));
2874 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
2875 error_too_many_args(unbound,closure,argcount,ca_limit_1);
2876 /* Due to argcount <= ca_limit_1, all count's fit in a uintC. */
2877 argcount = argcount/2;
2878 var object codevec = TheCclosure(closure)->clos_codevec; /* Code-Vector */
2879 {
2880 var uintC key_count = TheCodevec(codevec)->ccv_numkey; /* number of Keywords */
2881 var uintL keywords_offset = TheCodevec(codevec)->ccv_keyconsts; /* Offset of Keywords in FUNC */
2882 var gcv_object_t* keywords_pointer = /* points to the first Keyword */
2883 (TheCodevec(codevec)->ccv_flags & bit(4) /* generic function? */
2884 ? &TheSvector(TheCclosure(closure)->clos_consts[0])->data[keywords_offset]
2885 : &TheCclosure(closure)->clos_consts[keywords_offset]
2886 );
2887 /* test for illegal Keywords: */
2888 #define for_every_keyword(statement) \
2889 if (key_count > 0) { \
2890 var gcv_object_t* keywordptr = keywords_pointer; \
2891 var uintC count = key_count; \
2892 do { \
2893 var object keyword = *keywordptr++; \
2894 statement; \
2895 } while (--count); \
2896 }
2897 check_for_illegal_keywords
2898 (!((TheCodevec(codevec)->ccv_flags & bit(6)) == 0),
2899 Closure_name(closure),
2900 { pushSTACK(bad_keyword); /* save */
2901 pushSTACK(bad_value); /* save */
2902 pushSTACK(closure); /* save the closure */
2903 /* build list of legal Keywords: */
2904 for_every_keyword( { pushSTACK(keyword); } );
2905 {var object kwlist = listof(key_count);
2906 closure = popSTACK(); bad_value = popSTACK();
2907 bad_keyword = popSTACK(); /* report errors: */
2908 error_key_badkw(Closure_name(closure),
2909 bad_keyword,bad_value,kwlist);}});
2910 #undef for_every_keyword
2911 /* now assign Arguments and Parameters: */
2912 if (key_count > 0) {
2913 var gcv_object_t* keywordptr = keywords_pointer;
2914 var gcv_object_t* key_args_ptr = key_args_pointer;
2915 var uintC count;
2916 dotimespC(count,key_count, {
2917 var object keyword = *keywordptr++; /* Keyword */
2918 /* find the pair Key.value for this keyword: */
2919 find_keyword_value(
2920 /* not found -> Wert remains #<UNBOUND> : */
2921 { (void)NEXT(key_args_ptr); },
2922 /* found -> save value: */
2923 { NEXT(key_args_ptr) = value; }
2924 );
2925 });
2926 }
2927 }
2928 /* poss. process Rest-parameters: */
2929 if (TheCodevec(codevec)->ccv_flags & bit(0)) { /* Rest-Flag? */
2930 /* Closure with Keywords and &REST-Flag: */
2931 var gcv_object_t* rest_arg_ = &BEFORE(key_args_pointer); /* Pointer to the REST-Parameter */
2932 if (!boundp(*rest_arg_)) {
2933 /* must still be filed: handicraft list */
2934 *rest_arg_ = closure; /* save Closure */
2935 var object rest_arg = NIL;
2936 while (args_end_pointer != rest_args_pointer) {
2937 pushSTACK(rest_arg);
2938 rest_arg = allocate_cons();
2939 Cdr(rest_arg) = popSTACK();
2940 Car(rest_arg) = popSTACK();
2941 }
2942 closure = *rest_arg_; /* return Closure */
2943 *rest_arg_ = rest_arg;
2944 } else {
2945 /* forget remaining arguments: */
2946 set_args_end_pointer(rest_args_pointer);
2947 }
2948 } else {
2949 /* Closure without &REST-Flag: forget remaining arguments: */
2950 set_args_end_pointer(rest_args_pointer);
2951 }
2952 return closure;
2953 }
2954
2955
2956 /* ----------------------- E V A L ----------------------- */
2957
2958 /* later: */
2959 local Values eval1 (object form);
2960 local Values eval_fsubr (object fun, object args);
2961 local Values eval_applyhook (object fun);
2962 local Values eval_subr (object fun);
2963 local Values eval_closure (object fun);
2964 #ifdef DYNAMIC_FFI
2965 local Values eval_ffunction (object fun);
2966 #endif
2967
2968 /* UP: evaluates a form in the current environment.
2969 eval(form);
2970 > form: form
2971 < mv_count/mv_space: values
2972 can trigger GC */
eval(object form)2973 modexp maygc Values eval (object form)
2974 {
2975 start:
2976 /* Test for Keyboard-Interrupt: */
2977 interruptp({
2978 pushSTACK(form); /* save form */
2979 pushSTACK(S(eval)); tast_break(); /* call break-loop */
2980 form = popSTACK();
2981 goto start;
2982 });
2983 var sp_jmp_buf my_jmp_buf;
2984 { /* build EVAL-frame: */
2985 var gcv_object_t* top_of_frame = STACK; /* Pointer to Frame */
2986 pushSTACK(form); /* Form */
2987 finish_entry_frame(EVAL,my_jmp_buf,,
2988 {
2989 if (mv_count==0) { /* after reentry: Form passed over? */
2990 form = STACK_(frame_form); /* evaluate the same form again */
2991 } else {
2992 form = STACK_(frame_form) = value1; /* evaluate form passed over */
2993 }
2994 });
2995 }
2996 { /* Test for *EVALHOOK*: */
2997 var object evalhook_value = Symbol_value(S(evalhookstar)); /* *EVALHOOK* */
2998 if (nullp(evalhook_value)) { /* *EVALHOOK* = NIL ? */
2999 /* yes -> continue evaluation normally */
3000 pushSTACK(Symbol_value(S(applyhookstar))); eval1(form);
3001 } else {
3002 /* bind *EVALHOOK*, *APPLYHOOK* to NIL: */
3003 bindhooks_NIL();
3004 /* execute (FUNCALL *EVALHOOK* form env) : */
3005 pushSTACK(form); /* Form as 1st Argument */
3006 pushSTACK(evalhook_value); /* save Function */
3007 var gcv_environment_t* stack_env = nest_aktenv(); /* Environments in the Stack, */
3008 var object env = allocate_vector(5); /* in newly allocated Vector */
3009 *(gcv_environment_t*)(&TheSvector(env)->data[0]) = *stack_env; /* push in */
3010 skipSTACK(5);
3011 evalhook_value = popSTACK(); /* return Function */
3012 pushSTACK(env); /* entire Environment as 2nd Argument */
3013 funcall(evalhook_value,2);
3014 /* restore old values of *EVALHOOK*, *APPLYHOOK* : */
3015 unwind();
3016 /* unwind EVAL-Frame: */
3017 unwind();
3018 }
3019 }
3020 }
3021
3022 /* UP: evaluates a form in the current Environment. Does not take
3023 *EVALHOOK* and *APPLYHOOK* into consideration.
3024 eval_no_hooks(form);
3025 > form: Form
3026 < mv_count/mv_space: values
3027 can trigger GC */
eval_no_hooks(object form)3028 global maygc Values eval_no_hooks (object form) {
3029 var sp_jmp_buf my_jmp_buf;
3030 /* build EVAL-Frame: */
3031 {
3032 var gcv_object_t* top_of_frame = STACK; /* Pointer to Frame */
3033 pushSTACK(form); /* Form */
3034 finish_entry_frame(EVAL,my_jmp_buf,,
3035 {
3036 if (mv_count==0) { /* after reentry: Form passed over? */
3037 form = STACK_(frame_form); /* evaluate the same form again */
3038 } else {
3039 form = STACK_(frame_form) = value1; /* evaluate form passed over */
3040 }
3041 });
3042 }
3043 /* continue evaluation, consider *APPLYHOOK* as being NIL: */
3044 pushSTACK(NIL); eval1(form);
3045 }
3046
3047 /* UP: evaluates a form in the current environment.
3048 Does not take the value of *EVALHOOK* into consideration
3049 and expects the value of *APPLYHOOK*.
3050 the EVAL-frame must already have been built; it will then be unwound.
3051 eval1(form);
3052 > form: form
3053 > STACK_3..STACK_1: EVAL-Frame, with form in STACK_3
3054 > STACK_0: value of *APPLYHOOK*
3055 < mv_count/mv_space: values
3056 changes STACK
3057 can trigger GC */
eval1(object form)3058 local maygc Values eval1 (object form)
3059 {
3060 if (atomp(form)) {
3061 if (symbolp(form)) { /* Form is a Symbol */
3062 /* value1 = value in the current Environment - not unbound! */
3063 var object symbolmacro;
3064 value1 = sym_value(form,aktenv.var_env,&symbolmacro);
3065 if (!eq(symbolmacro,nullobj)) { /* Symbol-Macro? */
3066 /* yes -> expand and evaluate again: */
3067 skipSTACK(1); /* forget value of *APPLYHOOK* */
3068 check_SP(); check_STACK();
3069 eval(TheSymbolmacro(symbolmacro)->symbolmacro_expansion); /* evaluate Expansion */
3070 } else {
3071 if (!boundp(value1)) {
3072 check_variable_value_replacement(&(STACK_(frame_form+1)),true);
3073 if (eq(T,value2)) /* STORE-VALUE */
3074 value1 = setq(STACK_(frame_form+1),value1);
3075 }
3076 mv_count=1; /* value1 as value */
3077 skipSTACK(1);
3078 }
3079 unwind(); /* unwind EVAL-Frame */
3080 } else { /* self-evaluating form */
3081 VALUES1(form);
3082 skipSTACK(1);
3083 unwind(); /* unwind EVAL-Frame */
3084 }
3085 } else { /* Form is a Cons */
3086 eval_cons:
3087 /* determine, if Macro-call, poss. expand: */
3088 macroexp(form,aktenv.var_env,aktenv.fun_env); form = value1;
3089 if (!nullp(value2)) { /* expanded ? */
3090 /* now really evaluate: */
3091 skipSTACK(1); /* forget value of *APPLYHOOK* */
3092 check_SP(); check_STACK();
3093 eval(form); /* evaluate expanded form */
3094 unwind(); /* unwind EVAL-Frame */
3095 } else {
3096 var object fun = Car(form); /* function designation */
3097 if (funnamep(fun)) {
3098 /* fetch function-definition in the environment: */
3099 fun = sym_function(fun,aktenv.fun_env);
3100 fun_dispatch:
3101 /* branch according to type of function:
3102 unbound / SUBR/FSUBR/Closure / FunctionMacro / Macro */
3103 #ifdef TYPECODES
3104 switch (typecode(fun))
3105 #else
3106 if (immsubrp(fun))
3107 goto case_subr;
3108 else if (orecordp(fun))
3109 goto case_orecord;
3110 else
3111 switch (0)
3112 #endif
3113 {
3114 case_subr: /* SUBR */
3115 pushSTACK(Cdr(form)); /* argument list */
3116 if (!nullp(STACK_1))
3117 goto applyhook;
3118 eval_subr(fun);
3119 break;
3120 case_closure: /* closure */
3121 pushSTACK(Cdr(form)); /* argument list */
3122 closure: /* fun is a closure */
3123 if (!nullp(STACK_1))
3124 goto applyhook;
3125 eval_closure(fun);
3126 break;
3127 applyhook: /* value of *APPLYHOOK* is /= NIL. */
3128 eval_applyhook(fun);
3129 break;
3130 case_orecord:
3131 switch (Record_type(fun)) {
3132 case_Rectype_Closure_above;
3133 case_Rectype_Subr_above;
3134 case Rectype_Fsubr: /* Fsubr */
3135 eval_fsubr(fun,Cdr(form));
3136 break;
3137 #ifdef DYNAMIC_FFI
3138 case Rectype_Ffunction: /* Foreign-Function */
3139 pushSTACK(Cdr(form)); /* argument list */
3140 if (!nullp(STACK_1))
3141 goto applyhook;
3142 eval_ffunction(fun);
3143 break;
3144 #endif
3145 case Rectype_FunctionMacro:
3146 /* FunctionMacro -> treat like a function */
3147 fun = TheFunctionMacro(fun)->functionmacro_function;
3148 goto fun_dispatch;
3149 default:
3150 goto undef;
3151 }
3152 break;
3153 default: undef: {
3154 pushSTACK(form);
3155 fun = check_fdefinition(Car(form),S(eval));
3156 form = popSTACK();
3157 goto fun_dispatch;
3158 }
3159 }
3160 } else if (consp(fun) && eq(Car(fun),S(lambda))) {
3161 /* lambda-expression? */
3162 pushSTACK(Cdr(form)); /* Argument list */
3163 fun = get_closure(Cdr(fun),S(Klambda),false,&aktenv); /* create closure in current environment */
3164 goto closure; /* und apply it to the arguments, as above */
3165 } else {
3166 pushSTACK(Cdr(form));
3167 fun = check_funname_replacement(source_program_error,S(eval),fun);
3168 pushSTACK(fun);
3169 form = allocate_cons();
3170 Car(form) = popSTACK(); /* fun */
3171 Cdr(form) = popSTACK(); /* Cdr(form) */
3172 goto eval_cons;
3173 }
3174 }
3175 }
3176 }
3177
3178 #define CHECK_STACK(stack_before,fun) do { \
3179 if (STACK != stack_before) { /* STACK as before? */ \
3180 fprintf(stderr,"\n[%s:%d] STACK is not restored: %lu in ", \
3181 __FILE__,__LINE__, \
3182 (unsigned long)STACK_item_count(STACK,stack_before)); \
3183 nobject_out(stderr,fun); fprint(stderr,"\n"); \
3184 abort(); /* no -> go to Debugger */ \
3185 }} while(0)
3186 #if STACKCHECKS
3187 #define CHECK_STACK_S(stack_before,fun) CHECK_STACK(stack_before,fun)
3188 #else
3189 #define CHECK_STACK_S(stack_before,fun)
3190 #endif
3191 #if STACKCHECKC
3192 #define CHECK_STACK_C(stack_before,fun) CHECK_STACK(stack_before,fun)
3193 #else
3194 #define CHECK_STACK_C(stack_before,fun)
3195 #endif
3196
3197 /* In EVAL: Applies a FSUBR to an argument-list, cleans up STACK
3198 and returns the values.
3199 eval_fsubr(fun,args);
3200 > fun: a FSUBR
3201 > args: argument-list
3202 > STACK-layout: EVAL-Frame, *APPLYHOOK*.
3203 < STACK: cleaned up
3204 < mv_count/mv_space: values
3205 changes STACK
3206 can trigger GC */
eval_fsubr(object fun,object args)3207 local maygc Values eval_fsubr (object fun, object args)
3208 {
3209 skipSTACK(1); /* forget value of *APPLYHOOK* */
3210 check_SP(); check_STACK();
3211 #if STACKCHECKS
3212 var gcv_object_t* STACKbefore = STACK;
3213 #endif
3214 /* put arguments in the STACK: */
3215 switch ((uintW)posfixnum_to_V(TheFsubr(fun)->argtype)) {
3216 /* Macro for 1 required-Parameter: */
3217 #define REQ_PAR() \
3218 { if (atomp(args)) goto error_toofew; \
3219 pushSTACK(Car(args)); /* next parameter in the STACK */ \
3220 args = Cdr(args); \
3221 }
3222 case (uintW)fsubr_argtype_2_0_nobody:
3223 /* FSUBR with 2 required-Parameters */
3224 REQ_PAR();
3225 case (uintW)fsubr_argtype_1_0_nobody:
3226 /* FSUBR with 1 required-Parameter */
3227 REQ_PAR();
3228 if (!nullp(args)) goto error_toomany;
3229 break;
3230 case (uintW)fsubr_argtype_2_1_nobody:
3231 /* FSUBR with 2 required-Parameters and 1 optional-Parameter */
3232 REQ_PAR();
3233 case (uintW)fsubr_argtype_1_1_nobody:
3234 /* FSUBR with 1 required-Parameter and 1 optional-Parameter */
3235 REQ_PAR();
3236 if (consp(args)) {
3237 pushSTACK(Car(args)); /* optional parameter into STACK */
3238 args = Cdr(args);
3239 if (!nullp(args)) goto error_toomany;
3240 } else {
3241 pushSTACK(unbound); /* unbound into STACK instead */
3242 if (!nullp(args)) goto error_dotted;
3243 }
3244 break;
3245 case (uintW)fsubr_argtype_2_body:
3246 /* FSUBR with 2 required-Parameters and Body-Parameter */
3247 REQ_PAR();
3248 case (uintW)fsubr_argtype_1_body:
3249 /* FSUBR with 1 required-Parameter and Body-Parameter */
3250 REQ_PAR();
3251 case (uintW)fsubr_argtype_0_body:
3252 /* FSUBR with 0 required-Parameters and Body-Parameter */
3253 pushSTACK(args); /* remaining body into STACK */
3254 break;
3255 default: NOTREACHED;
3256 error_toofew: /* argument-list args is an atom, prematurely */
3257 if (!nullp(args)) goto error_dotted;
3258 /* clean up STACK up to the calling EVAL-Frame: */
3259 while (!(framecode(STACK_0) & bit(frame_bit_t))) {
3260 skipSTACK(1);
3261 }
3262 {
3263 var object form = STACK_(frame_form); /* Form from EVAL-Frame */
3264 pushSTACK(form); /* SOURCE-PROGRAM-ERROR slot DETAIL */
3265 pushSTACK(form); pushSTACK(Car(form));
3266 error(source_program_error,
3267 GETTEXT("EVAL: too few parameters for special operator ~S: ~S"));
3268 }
3269 error_toomany: /* argument-list args is not NIL at the tail */
3270 if (atomp(args)) goto error_dotted;
3271 /* clean up STACK up to the calling EVAL-Frame: */
3272 while (!(framecode(STACK_0) & bit(frame_bit_t))) {
3273 skipSTACK(1);
3274 }
3275 {
3276 var object form = STACK_(frame_form); /* Form from EVAL-Frame */
3277 pushSTACK(form); /* SOURCE-PROGRAM-ERROR slot DETAIL */
3278 pushSTACK(form); pushSTACK(Car(form));
3279 error(source_program_error,
3280 GETTEXT("EVAL: too many parameters for special operator ~S: ~S"));
3281 }
3282 error_dotted: /* argument-list args ends with Atom /= NIL */
3283 /* clean up STACK up to the calling EVAL-Frame: */
3284 while (!(framecode(STACK_0) & bit(frame_bit_t))) {
3285 skipSTACK(1);
3286 }
3287 {
3288 var object form = STACK_(frame_form); /* Form from EVAL-Frame */
3289 pushSTACK(form); /* SOURCE-PROGRAM-ERROR slot DETAIL */
3290 pushSTACK(form); pushSTACK(Car(form));
3291 error(source_program_error,
3292 GETTEXT("EVAL: dotted parameter list for special operator ~S: ~S"));
3293 }
3294 #undef REQ_PAR
3295 }
3296 /* Now STACK = STACKbefore STACKop - (req + opt + (body-flag ? 1 : 0)).
3297 Call FSUBR: */
3298 with_saved_back_trace_fsubr(fun,
3299 (*(fsubr_function_t*)(TheFsubr(fun)->function))(); );
3300 CHECK_STACK_S(STACKbefore,fun);
3301 unwind(); /* unwind EVAL-Frame */
3302 }
3303
3304 /* In EVAL: Applies *APPLYHOOK* to a function (SUBR or Closure) and
3305 an argument-list, cleans up the STACK and returns the values.
3306 eval_applyhook(fun);
3307 > fun: function, a SUBR or a closure
3308 > STACK-layout: EVAL-Frame, *APPLYHOOK* (/= NIL), argument-list.
3309 < STACK: cleaned up
3310 < mv_count/mv_space: values
3311 changes STACK
3312 can trigger GC */
eval_applyhook(object fun)3313 local maygc Values eval_applyhook(object fun) {
3314 var object args = popSTACK(); /* argument-list */
3315 var object applyhook_value = popSTACK(); /* value of *APPLYHOOK* */
3316 check_SP();
3317 /* bind *EVALHOOK*, *APPLYHOOK* to NIL: */
3318 bindhooks_NIL();
3319 #ifndef X3J13_005
3320 /* execute (FUNCALL *APPLYHOOK* fun args env) : */
3321 pushSTACK(fun); /* Funktion as 1st Argument */
3322 pushSTACK(args); /* argument-list as 2nd Argument */
3323 pushSTACK(applyhook_value); /* save function */
3324 {
3325 var gcv_environment_t* stack_env = nest_aktenv(); /* Environments into Stack, */
3326 var object env = allocate_vector(5); /* in newly allocated Vector */
3327 *(gcv_environment_t*)(&TheSvector(env)->data[0]) = *stack_env; /* push in */
3328 skipSTACK(5);
3329 }
3330 applyhook_value = popSTACK(); /* function back */
3331 pushSTACK(env); /* entire Environment as 3rd Argument */
3332 funcall(applyhook_value,3);
3333 #else
3334 /* execute (FUNCALL *APPLYHOOK* fun args) : */
3335 pushSTACK(fun); /* function as 1st Argument */
3336 pushSTACK(args); /* argument-list as 2nd Argument */
3337 funcall(applyhook_value,2);
3338 #endif
3339 /* old values of *EVALHOOK*, *APPLYHOOK* back: */
3340 unwind();
3341 /* unwind EVAL-Frame: */
3342 unwind();
3343 }
3344
3345 /* In EVAL: error, if too few arguments */
error_eval_toofew(object fun)3346 local _Noreturn void error_eval_toofew (object fun) {
3347 var object form = STACK_(frame_form); /* Form */
3348 pushSTACK(form); /* SOURCE-PROGRAM-ERROR slot DETAIL */
3349 pushSTACK(form); pushSTACK(fun);
3350 /* ANSI CL 3.5.1.2. wants a PROGRAM-ERROR here. */
3351 error(source_program_error,
3352 GETTEXT("EVAL: too few arguments given to ~S: ~S"));
3353 }
3354
3355 /* In EVAL: error, if too many arguments */
error_eval_toomany(object fun)3356 local _Noreturn void error_eval_toomany (object fun) {
3357 var object form = STACK_(frame_form); /* Form */
3358 pushSTACK(form); /* SOURCE-PROGRAM-ERROR slot DETAIL */
3359 pushSTACK(form); pushSTACK(fun);
3360 /* ANSI CL 3.5.1.3. wants a PROGRAM-ERROR here. */
3361 error(source_program_error,
3362 GETTEXT("EVAL: too many arguments given to ~S: ~S"));
3363 }
3364
3365 /* In EVAL: error, if dotted argument-list */
error_dotted_form(object form,object fun)3366 global _Noreturn void error_dotted_form (object form, object fun) {
3367 pushSTACK(form); /* SOURCE-PROGRAM-ERROR slot DETAIL */
3368 pushSTACK(form); pushSTACK(fun);
3369 error(source_program_error,
3370 GETTEXT("EVAL: argument list given to ~S is dotted: ~S"));
3371 }
3372 #define error_eval_dotted(fun) error_dotted_form(STACK_(frame_form),fun)
3373
3374 /* In EVAL: Applies an SUBR to an argument-list, cleans up STACK
3375 and returns the values.
3376 eval_subr(fun);
3377 > fun: function, a SUBR
3378 > STACK-layout: EVAL-Frame, *APPLYHOOK*, argument-list.
3379 < STACK: cleaned up
3380 < mv_count/mv_space: values
3381 changes STACK
3382 can trigger GC */
eval_subr(object fun)3383 local maygc Values eval_subr (object fun)
3384 {
3385 var object args = popSTACK(); /* argument-list */
3386 skipSTACK(1); /* forget value of *APPLYHOOK* */
3387 check_SP(); check_STACK();
3388 var gcv_object_t* args_pointer = args_end_pointer; /* Pointer to the arguments */
3389 var gcv_object_t* rest_args_pointer; /* Pointer to the remaining arguments */
3390 var uintL argcount; /* number of remaining arguments */
3391 /* push arguments evaluated in the STACK:
3392 first a Dispatch for most important cases: */
3393 switch (TheSubr(fun)->argtype) {
3394 /* Macro for a required-argument: */
3395 #define REQ_ARG() \
3396 { if (atomp(args)) goto error_toofew; \
3397 pushSTACK(Cdr(args)); /* remaining arguments */ \
3398 eval(Car(args)); /* evaluate next argument */ \
3399 args = STACK_0; STACK_0 = value1; /* and into STACK */ \
3400 }
3401 /* Macro for the n-th last optional-argument: */
3402 #define OPT_ARG(n) \
3403 { if (atomp(args)) goto unbound_optional_##n ; \
3404 pushSTACK(Cdr(args)); /* remaining arguments */ \
3405 eval(Car(args)); /* evaluate next argument */ \
3406 args = STACK_0; STACK_0 = value1; /* and into STACK */ \
3407 }
3408 case (uintW)subr_argtype_6_0: /* SUBR with 6 required arguments */
3409 REQ_ARG();
3410 case (uintW)subr_argtype_5_0: /* SUBR with 5 required arguments */
3411 REQ_ARG();
3412 case (uintW)subr_argtype_4_0: /* SUBR with 4 required arguments */
3413 REQ_ARG();
3414 case (uintW)subr_argtype_3_0: /* SUBR with 3 required arguments */
3415 REQ_ARG();
3416 case (uintW)subr_argtype_2_0: /* SUBR with 2 required arguments */
3417 REQ_ARG();
3418 case (uintW)subr_argtype_1_0: /* SUBR with 1 required argument */
3419 REQ_ARG();
3420 case (uintW)subr_argtype_0_0: /* SUBR without Arguments */
3421 if (!nullp(args)) goto error_toomany;
3422 goto apply_subr_norest;
3423 case (uintW)subr_argtype_4_1: /* SUBR with 4 required and 1 optional */
3424 REQ_ARG();
3425 case (uintW)subr_argtype_3_1: /* SUBR with 3 required and 1 optional */
3426 REQ_ARG();
3427 case (uintW)subr_argtype_2_1: /* SUBR with 2 required and 1 optional */
3428 REQ_ARG();
3429 case (uintW)subr_argtype_1_1: /* SUBR with 1 required and 1 optional */
3430 REQ_ARG();
3431 case (uintW)subr_argtype_0_1: /* SUBR with 1 optional argument */
3432 OPT_ARG(1);
3433 if (!nullp(args)) goto error_toomany;
3434 goto apply_subr_norest;
3435 case (uintW)subr_argtype_3_2: /* SUBR with 3 required and 2 optional */
3436 REQ_ARG();
3437 case (uintW)subr_argtype_2_2: /* SUBR with 2 required and 2 optional */
3438 REQ_ARG();
3439 case (uintW)subr_argtype_1_2: /* SUBR with 1 required and 2 optional */
3440 REQ_ARG();
3441 case (uintW)subr_argtype_0_2: /* SUBR with 2 optional arguments */
3442 OPT_ARG(2);
3443 OPT_ARG(1);
3444 if (!nullp(args)) goto error_toomany;
3445 goto apply_subr_norest;
3446 case (uintW)subr_argtype_2_3: /* SUBR with 2 required and 3 optional */
3447 REQ_ARG();
3448 case (uintW)subr_argtype_1_3: /* SUBR with 1 required and 3 optional */
3449 REQ_ARG();
3450 case (uintW)subr_argtype_0_3: /* SUBR with 3 optional arguments */
3451 OPT_ARG(3);
3452 OPT_ARG(2);
3453 OPT_ARG(1);
3454 if (!nullp(args)) goto error_toomany;
3455 goto apply_subr_norest;
3456 case (uintW)subr_argtype_0_5: /* SUBR with 5 optional arguments */
3457 OPT_ARG(5);
3458 case (uintW)subr_argtype_0_4: /* SUBR with 4 optional arguments */
3459 OPT_ARG(4);
3460 OPT_ARG(3);
3461 OPT_ARG(2);
3462 OPT_ARG(1);
3463 if (!nullp(args)) goto error_toomany;
3464 goto apply_subr_norest;
3465 unbound_optional_5: /* Still 5 optional Arguments, but atomp(args) */
3466 { pushSTACK(unbound); }
3467 unbound_optional_4: /* Still 4 optional Arguments, but atomp(args) */
3468 { pushSTACK(unbound); }
3469 unbound_optional_3: /* Still 3 optional Arguments, but atomp(args) */
3470 { pushSTACK(unbound); }
3471 unbound_optional_2: /* Still 2 optional Arguments, but atomp(args) */
3472 { pushSTACK(unbound); }
3473 unbound_optional_1: /* Still 1 optional Argument, but atomp(args) */
3474 { pushSTACK(unbound); }
3475 if (!nullp(args)) goto error_dotted;
3476 goto apply_subr_norest;
3477 case (uintW)subr_argtype_3_0_rest: /* SUBR with 3 required and rest */
3478 REQ_ARG();
3479 case (uintW)subr_argtype_2_0_rest: /* SUBR with 2 required and rest */
3480 REQ_ARG();
3481 case (uintW)subr_argtype_1_0_rest: /* SUBR with 1 required and rest */
3482 REQ_ARG();
3483 case (uintW)subr_argtype_0_0_rest: /* SUBR with &rest Arguments */
3484 rest_args_pointer = args_end_pointer; /* Pointer to the remaining arguments */
3485 /* evaluate all further arguments and into Stack: */
3486 argcount = 0; /* counter for the remaining arguments */
3487 while (consp(args)) {
3488 check_STACK();
3489 pushSTACK(Cdr(args)); /* remaining arguments */
3490 eval(Car(args)); /* evaluate next argument */
3491 args = STACK_0; STACK_0 = value1; /* and into STACK */
3492 argcount++;
3493 }
3494 goto apply_subr_rest;
3495 case (uintW)subr_argtype_4_0_key: /* SUBR with 4 required and &key */
3496 REQ_ARG();
3497 case (uintW)subr_argtype_3_0_key: /* SUBR with 3 required and &key */
3498 REQ_ARG();
3499 case (uintW)subr_argtype_2_0_key: /* SUBR with 2 required and &key */
3500 REQ_ARG();
3501 case (uintW)subr_argtype_1_0_key: /* SUBR with 1 required and &key */
3502 REQ_ARG();
3503 case (uintW)subr_argtype_0_0_key: /* SUBR with &key */
3504 if (atomp(args)) goto unbound_optional_key_0;
3505 goto apply_subr_key;
3506 case (uintW)subr_argtype_1_1_key:
3507 /* SUBR with 1 required argument, 1 optional argument and &key */
3508 REQ_ARG();
3509 case (uintW)subr_argtype_0_1_key: /* SUBR with 1 optional and &key */
3510 OPT_ARG(key_1);
3511 if (atomp(args)) goto unbound_optional_key_0;
3512 goto apply_subr_key;
3513 case (uintW)subr_argtype_1_2_key:
3514 /* SUBR with 1 required argument, 2 optional arguments and &key */
3515 REQ_ARG();
3516 OPT_ARG(key_2);
3517 OPT_ARG(key_1);
3518 if (atomp(args)) goto unbound_optional_key_0;
3519 goto apply_subr_key;
3520 unbound_optional_key_2: /* Silll 2 optional Arguments, but atomp(args) */
3521 { pushSTACK(unbound); }
3522 unbound_optional_key_1: /* Still 1 optional Argument, but atomp(args) */
3523 { pushSTACK(unbound); }
3524 unbound_optional_key_0: /* Before the keywords is atomp(args) */
3525 {
3526 var uintC count;
3527 dotimesC(count,TheSubr(fun)->key_count, { pushSTACK(unbound); } );
3528 }
3529 if (!nullp(args)) goto error_dotted;
3530 goto apply_subr_norest;
3531 default: NOTREACHED;
3532 #undef OPT_ARG
3533 #undef REQ_ARG
3534 }
3535 /* Now the general Version:
3536 reserve space on the STACK: */
3537 get_space_on_STACK(sizeof(gcv_object_t) *
3538 (uintL)(TheSubr(fun)->req_count +
3539 TheSubr(fun)->opt_count +
3540 TheSubr(fun)->key_count));
3541 /* evaluate required parameters and push into Stack: */
3542 {
3543 var uintC count;
3544 dotimesC(count,TheSubr(fun)->req_count, {
3545 if (atomp(args)) goto error_toofew; /* at the end of argument-list? */
3546 pushSTACK(Cdr(args)); /* remaining argument-list */
3547 eval(Car(args)); /* evaluate next argument */
3548 args = STACK_0; STACK_0 = value1; /* and into Stack */
3549 });
3550 }
3551 { /* evaluate optional parameters and push into Stack: */
3552 var uintC count = TheSubr(fun)->opt_count;
3553 while (!atomp(args)) { /* argument-list not finished? */
3554 if (count==0) /* all optional parameters supplied with? */
3555 goto optionals_ok;
3556 count--;
3557 pushSTACK(Cdr(args)); /* remaining argument-list */
3558 eval(Car(args)); /* evaluate next argument */
3559 args = STACK_0; STACK_0 = value1; /* and into Stack */
3560 }
3561 /* argument-list finished.
3562 All further count optional parameters get the "value"
3563 #<UNBOUND>, the same for the Keyword-parameters: */
3564 dotimesC(count,count + TheSubr(fun)->key_count, { pushSTACK(unbound); } );
3565 if (TheSubr(fun)->rest_flag == subr_rest) { /* &REST-Flag? */
3566 /* yes -> 0 additional arguments: */
3567 argcount = 0; rest_args_pointer = args_end_pointer;
3568 }
3569 /* no -> nothing to do */
3570 goto los;
3571 }
3572 optionals_ok:
3573 /* process Rest- and Keyword-parameters.
3574 args = remaining argument-list (not yet finished) */
3575 if (TheSubr(fun)->key_flag == subr_nokey) {
3576 /* SUBR without KEY */
3577 if (TheSubr(fun)->rest_flag == subr_norest) {
3578 /* SUBR without REST or KEY -> argument-list should be finished */
3579 goto error_toomany;
3580 } else {
3581 /* SUBR with only REST, without KEY: treatment of remaining arguments */
3582 rest_args_pointer = args_end_pointer;
3583 argcount = 0; /* counter for the remaining arguments */
3584 do {
3585 check_STACK();
3586 pushSTACK(Cdr(args)); /* remaining argument-list */
3587 eval(Car(args)); /* evaluate next argument */
3588 args = STACK_0; STACK_0 = value1; /* and into Stack */
3589 argcount++;
3590 } while (consp(args));
3591 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
3592 goto error_toomany;
3593 }
3594 } else
3595 apply_subr_key: { /* SUBR with Keywords. */
3596 /* args = remaining argument-list (not yet finished)
3597 First initialize the Keyword-parameters with #<UNBOUND> , then
3598 evaluate the remaining arguments and push into Stack, then
3599 assign the Keywords: */
3600 var gcv_object_t* key_args_pointer = args_end_pointer; /* Pointer to Keyword-parameters */
3601 /* initialize all Keyword-parameters with #<UNBOUND> : */
3602 {
3603 var uintC count;
3604 dotimesC(count,TheSubr(fun)->key_count, { pushSTACK(unbound); } );
3605 }
3606 rest_args_pointer = args_end_pointer; /* Pointer to the remaining arguments */
3607 /* evaluate all further arguments and into Stack: */
3608 argcount = 0; /* counter for the remaining arguments */
3609 do {
3610 check_STACK();
3611 pushSTACK(Cdr(args)); /* remaining argument-list */
3612 eval(Car(args)); /* evaluate next argument */
3613 args = STACK_0; STACK_0 = value1; /* and into Stack */
3614 argcount++;
3615 } while (consp(args));
3616 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
3617 goto error_toomany;
3618 /* assign Keywords and poss. discard remaining arguments: */
3619 match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
3620 }
3621 los: /* call function */
3622 /* remaining argument-list must be NIL : */
3623 if (!nullp(args)) goto error_dotted;
3624 if (TheSubr(fun)->rest_flag == subr_norest) {
3625 /* SUBR without &REST-Flag: */
3626 apply_subr_norest:
3627 with_saved_back_trace_subr(fun,STACK,-1,
3628 (*(subr_norest_function_t*)(TheSubr(fun)->function))(); );
3629 } else {
3630 /* SUBR with &REST-Flag: */
3631 apply_subr_rest:
3632 with_saved_back_trace_subr(fun,STACK,
3633 TheSubr(fun)->req_count + TheSubr(fun)->opt_count + argcount,
3634 (*(subr_rest_function_t*)(TheSubr(fun)->function))(argcount,rest_args_pointer); );
3635 }
3636 CHECK_STACK_S(args_end_pointer,fun);
3637 unwind(); /* unwind EVAL-Frame */
3638 return; /* finished */
3639 /* Gathered error-messages: */
3640 error_toofew: /* Argument-List args is prematurely an Atom */
3641 if (!nullp(args)) goto error_dotted;
3642 set_args_end_pointer(args_pointer); /* clean up STACK */
3643 error_eval_toofew(TheSubr(fun)->name);
3644 error_toomany: /* Argument-List args is not NIL at the end */
3645 if (atomp(args)) goto error_dotted;
3646 set_args_end_pointer(args_pointer); /* clean up STACK */
3647 error_eval_toomany(TheSubr(fun)->name);
3648 error_dotted: /* Argument-List args ends with Atom /= NIL */
3649 set_args_end_pointer(args_pointer); /* clean up STACK */
3650 error_eval_dotted(TheSubr(fun)->name);
3651 }
3652
3653 /* In EVAL: Applies a Closure to an argument-list, cleans up the STACK
3654 and returns the values.
3655 eval_closure(fun);
3656 > fun: function, a Closure
3657 > STACK-layout: EVAL-Frame, *APPLYHOOK*, argument-list.
3658 < STACK: cleaned up
3659 < mv_count/mv_space: values
3660 changes STACK
3661 can trigger GC */
eval_closure(object closure)3662 local maygc Values eval_closure (object closure)
3663 {
3664 var object args = popSTACK(); /* argument-list */
3665 skipSTACK(1); /* forget value of *APPLYHOOK* */
3666 /* STACK-layout: EVAL-Frame. */
3667 check_SP(); check_STACK();
3668 pushSTACK(closure); /* save Closure */
3669 var gcv_object_t* closure_ = &STACK_0; /* and memorize, where it is */
3670 var gcv_object_t* STACKbefore = STACK;
3671 if (simple_bit_vector_p(Atype_8Bit,TheClosure(closure)->clos_codevec)) {
3672 /* closure is a compiled Closure */
3673 var object codevec = TheCclosure(closure)->clos_codevec; /* Code-Vector */
3674 /* push arguments evaluated into STACK:
3675 first a dispatch for the most important cases: */
3676 switch (TheCodevec(codevec)->ccv_signature) {
3677 /* Macro for a required-argument: */
3678 #define REQ_ARG() \
3679 { if (atomp(args)) goto error_toofew; \
3680 pushSTACK(Cdr(args)); /* remaining arguments */ \
3681 eval(Car(args)); /* evaluate next argument */ \
3682 args = STACK_0; STACK_0 = value1; /* and into STACK */ \
3683 }
3684 /* Macro for the n-last optional-argument: */
3685 #define OPT_ARG(n) \
3686 { if (atomp(args)) goto unbound_optional_##n ; \
3687 pushSTACK(Cdr(args)); /* remaining arguments */ \
3688 eval(Car(args)); /* evaluate next argument */ \
3689 args = STACK_0; STACK_0 = value1; /* and into STACK */ \
3690 }
3691 case (uintB)cclos_argtype_5_0: /* 5 required arguments */
3692 REQ_ARG();
3693 case (uintB)cclos_argtype_4_0: /* 4 required arguments */
3694 REQ_ARG();
3695 case (uintB)cclos_argtype_3_0: /* 3 required arguments */
3696 REQ_ARG();
3697 case (uintB)cclos_argtype_2_0: /* 2 required arguments */
3698 REQ_ARG();
3699 case (uintB)cclos_argtype_1_0: /* 1 required argument */
3700 REQ_ARG();
3701 case (uintB)cclos_argtype_0_0: /* no Arguments */
3702 noch_0_opt_args:
3703 if (!nullp(args)) goto error_toomany;
3704 goto apply_cclosure_nokey;
3705 case (uintB)cclos_argtype_4_1: /* 4 required and 1 optional */
3706 REQ_ARG();
3707 case (uintB)cclos_argtype_3_1: /* 3 required and 1 optional */
3708 REQ_ARG();
3709 case (uintB)cclos_argtype_2_1: /* 2 required and 1 optional */
3710 REQ_ARG();
3711 case (uintB)cclos_argtype_1_1: /* 1 required and 1 optional */
3712 REQ_ARG();
3713 case (uintB)cclos_argtype_0_1: /* 1 optional argument */
3714 noch_1_opt_args:
3715 OPT_ARG(1);
3716 goto noch_0_opt_args;
3717 case (uintB)cclos_argtype_3_2: /* 3 required and 2 optional */
3718 REQ_ARG();
3719 case (uintB)cclos_argtype_2_2: /* 2 required and 2 optional */
3720 REQ_ARG();
3721 case (uintB)cclos_argtype_1_2: /* 1 required and 2 optional */
3722 REQ_ARG();
3723 case (uintB)cclos_argtype_0_2: /* 2 optional arguments */
3724 noch_2_opt_args:
3725 OPT_ARG(2);
3726 goto noch_1_opt_args;
3727 case (uintB)cclos_argtype_2_3: /* 2 required and 3 optional */
3728 REQ_ARG();
3729 case (uintB)cclos_argtype_1_3: /* 1 required and 3 optional */
3730 REQ_ARG();
3731 case (uintB)cclos_argtype_0_3: /* 3 optional arguments */
3732 noch_3_opt_args:
3733 OPT_ARG(3);
3734 goto noch_2_opt_args;
3735 case (uintB)cclos_argtype_1_4: /* 1 required and 4 optional */
3736 REQ_ARG();
3737 case (uintB)cclos_argtype_0_4: /* 4 optional arguments */
3738 noch_4_opt_args:
3739 OPT_ARG(4);
3740 goto noch_3_opt_args;
3741 case (uintB)cclos_argtype_0_5: /* 5 optional arguments */
3742 OPT_ARG(5);
3743 goto noch_4_opt_args;
3744 unbound_optional_5: /* Still 5 optional Arguments, but atomp(args) */
3745 { pushSTACK(unbound); }
3746 unbound_optional_4: /* Still 4 optional Arguments, but atomp(args) */
3747 { pushSTACK(unbound); }
3748 unbound_optional_3: /* Still 3 optional Arguments, but atomp(args) */
3749 { pushSTACK(unbound); }
3750 unbound_optional_2: /* Still 2 optional Arguments, but atomp(args) */
3751 { pushSTACK(unbound); }
3752 unbound_optional_1: /* Still 1 optional Argument, but atomp(args) */
3753 { pushSTACK(unbound); }
3754 if (!nullp(args)) goto error_dotted;
3755 goto apply_cclosure_nokey;
3756 case (uintB)cclos_argtype_4_0_rest: /* 4 required + &rest */
3757 REQ_ARG();
3758 case (uintB)cclos_argtype_3_0_rest: /* 3 required + &rest */
3759 REQ_ARG();
3760 case (uintB)cclos_argtype_2_0_rest: /* 2 required + &rest */
3761 REQ_ARG();
3762 case (uintB)cclos_argtype_1_0_rest: /* 1 required + &rest */
3763 REQ_ARG();
3764 case (uintB)cclos_argtype_0_0_rest: /* no Arguments, Rest-Parameter */
3765 if (consp(args)) goto apply_cclosure_rest_nokey;
3766 if (!nullp(args)) goto error_dotted;
3767 { pushSTACK(NIL); } /* Rest-Parameter := NIL */
3768 goto apply_cclosure_nokey;
3769 case (uintB)cclos_argtype_4_0_key: /* 4 required arguments, &key */
3770 REQ_ARG();
3771 case (uintB)cclos_argtype_3_0_key: /* 3 required arguments, &key */
3772 REQ_ARG();
3773 case (uintB)cclos_argtype_2_0_key: /* 2 required arguments, &key */
3774 REQ_ARG();
3775 case (uintB)cclos_argtype_1_0_key: /* 1 required argument, &key */
3776 REQ_ARG();
3777 noch_0_opt_args_key:
3778 closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
3779 case (uintB)cclos_argtype_0_0_key:
3780 /* only &key */
3781 if (atomp(args)) goto unbound_optional_key_0;
3782 goto apply_cclosure_key;
3783 case (uintB)cclos_argtype_3_1_key:
3784 /* 3 required arguments and 1 optional argument, &key */
3785 REQ_ARG();
3786 case (uintB)cclos_argtype_2_1_key:
3787 /* 2 required arguments and 1 optional argument, &key */
3788 REQ_ARG();
3789 case (uintB)cclos_argtype_1_1_key:
3790 /* 1 required argument and 1 optional argument, &key */
3791 REQ_ARG();
3792 case (uintB)cclos_argtype_0_1_key:
3793 /* 1 optional argument, &key */
3794 noch_1_opt_args_key:
3795 OPT_ARG(key_1);
3796 goto noch_0_opt_args_key;
3797 case (uintB)cclos_argtype_2_2_key: /* 2 required and 2 optional, &key */
3798 REQ_ARG();
3799 case (uintB)cclos_argtype_1_2_key: /* 1 required and 2 optional, &key */
3800 REQ_ARG();
3801 case (uintB)cclos_argtype_0_2_key: /* 2 optional arguments, &key */
3802 noch_2_opt_args_key:
3803 OPT_ARG(key_2);
3804 goto noch_1_opt_args_key;
3805 case (uintB)cclos_argtype_1_3_key: /* 1 required and 3 optional, &key */
3806 REQ_ARG();
3807 case (uintB)cclos_argtype_0_3_key: /* 3 optional arguments, &key */
3808 noch_3_opt_args_key:
3809 OPT_ARG(key_3);
3810 goto noch_2_opt_args_key;
3811 case (uintB)cclos_argtype_0_4_key: /* 4 optional arguments, &key */
3812 OPT_ARG(key_4);
3813 goto noch_3_opt_args_key;
3814 unbound_optional_key_4: /* Still 4 optional Arguments, but atomp(args) */
3815 { pushSTACK(unbound); }
3816 unbound_optional_key_3: /* Still 3 optional Arguments, but atomp(args) */
3817 { pushSTACK(unbound); }
3818 unbound_optional_key_2: /* Still 2 optional Arguments, but atomp(args) */
3819 { pushSTACK(unbound); }
3820 unbound_optional_key_1: /* Still 1 optional Argument, but atomp(args) */
3821 { pushSTACK(unbound); }
3822 unbound_optional_key_0: /* Before the Keywords is atomp(args) */
3823 if (!nullp(args)) goto error_dotted;
3824 goto apply_cclosure_key_noargs;
3825 case (uintB)cclos_argtype_default:
3826 /* General Version */
3827 break;
3828 default: NOTREACHED;
3829 #undef OPT_ARG
3830 #undef REQ_ARG
3831 }
3832 /* Now the general Version: */
3833 {
3834 var uintL req_count = TheCodevec(codevec)->ccv_numreq; /* number of required parameters */
3835 var uintL opt_count = TheCodevec(codevec)->ccv_numopt; /* number of optional parameters */
3836 var uintB flags = TheCodevec(codevec)->ccv_flags; /* Flags */
3837 /* reserve space on STACK: */
3838 get_space_on_STACK(sizeof(gcv_object_t) * (req_count+opt_count));
3839 /* evaluate required parameters and push into Stack: */
3840 {
3841 var uintC count;
3842 dotimesC(count,req_count, {
3843 if (atomp(args)) goto error_toofew; /* argument-list finished? */
3844 pushSTACK(Cdr(args)); /* remaining argument-list */
3845 eval(Car(args)); /* evaluate nnext argument */
3846 args = STACK_0; STACK_0 = value1; /* and into Stack */
3847 });
3848 }
3849 { /* evaluate optional parameters and push into Stack: */
3850 var uintC count = opt_count;
3851 while (!atomp(args)) { /* argument-list not finished? */
3852 if (count==0) /* all optional parameters supplied with? */
3853 goto optionals_ok;
3854 count--;
3855 pushSTACK(Cdr(args)); /* remaining argument-list */
3856 eval(Car(args)); /* evaluate next argument */
3857 args = STACK_0; STACK_0 = value1; /* and into Stack */
3858 }
3859 /* argument-list finished. */
3860 if (!nullp(args)) goto error_dotted;
3861 /* All further count optional parameters get the "value"
3862 #<UNBOUND>, the &REST-parameter gets the value NIL,
3863 the Keyword-parameter gets the value #<UNBOUND> : */
3864 dotimesC(count,count, { pushSTACK(unbound); } );
3865 }
3866 closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
3867 if (flags & bit(0)) /* &REST-Flag? */
3868 pushSTACK(NIL); /* yes -> initialize with NIL */
3869 if (flags & bit(7)) /* &KEY-Flag? */
3870 goto apply_cclosure_key_noargs;
3871 else
3872 goto apply_cclosure_nokey_;
3873 optionals_ok:
3874 /* process Rest- and Keyword-parameters.
3875 args = remaining argument-list (not yet finished) */
3876 closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
3877 if (flags == 0)
3878 /* Closure without REST or KEY -> argument-list should be finished */
3879 goto error_toomany;
3880 else if (flags & bit(7)) { /* Key-Flag? */
3881 /* Closure with Keywords.
3882 args = remaining argument-list (not yet finished)
3883 First initialize the Keyword-parameters with #<UNBOUND> , then
3884 evaluate the remaining arguments and push into Stack, then
3885 assign the Keywords:
3886 poss. initialize the Rest-Parameter: */
3887 if (flags & bit(0))
3888 pushSTACK(unbound);
3889 goto apply_cclosure_key;
3890 } else
3891 goto apply_cclosure_rest_nokey;
3892 }
3893 apply_cclosure_key_noargs:
3894 {
3895 var uintC count = TheCodevec(codevec)->ccv_numkey; /* number of Keyword-parameters */
3896 dotimesC(count,count, { pushSTACK(unbound); } ); /* initialize with #<UNBOUND> */
3897 interpret_bytecode(closure,codevec,CCV_START_KEY); /* interpret bytecode starting at Byte 12 */
3898 }
3899 goto done;
3900 apply_cclosure_key: /* jump to Closure only with &KEY: */
3901 {
3902 var gcv_object_t* key_args_pointer = args_end_pointer; /* Pointer to Keyword-Parameter */
3903 /* initialize all Keyword-parameters with #<UNBOUND> : */
3904 {
3905 var uintC count = TheCodevec(codevec)->ccv_numkey;
3906 dotimesC(count,count, { pushSTACK(unbound); } );
3907 }
3908 var gcv_object_t* rest_args_pointer = args_end_pointer; /* Pointer to the remaining arguments */
3909 /* evaluate all further arguments and push into Stack: */
3910 var uintL argcount = 0; /* counter for the remaining arguments */
3911 do {
3912 check_STACK();
3913 pushSTACK(Cdr(args)); /* remaining argument-list */
3914 eval(Car(args)); /* evaluate next argument */
3915 args = STACK_0; STACK_0 = value1; /* and into Stack */
3916 argcount++;
3917 } while (consp(args));
3918 /* argument-list finished. */
3919 if (!nullp(args)) goto error_dotted;
3920 /* assign Keywords, build Rest-Parameter
3921 and poss. discard remaining arguments: */
3922 closure = match_cclosure_key(*closure_,argcount,key_args_pointer,rest_args_pointer);
3923 codevec = TheCclosure(closure)->clos_codevec;
3924 interpret_bytecode(closure,codevec,CCV_START_KEY); /* interpret bytecode starting at Byte 12 */
3925 }
3926 goto done;
3927 apply_cclosure_rest_nokey: {
3928 /* Closure with only REST, without KEY:
3929 evaluate remaining arguments one by one, put into list
3930 args = remaining argument-list (not yet finished) */
3931 pushSTACK(NIL); /* so far evaluated remaining arguments */
3932 pushSTACK(args); /* remaining arguments, unevaluated */
3933 do {
3934 args = STACK_0; STACK_0 = Cdr(args);
3935 eval(Car(args)); /* evaluate next argument */
3936 pushSTACK(value1);
3937 /* and cons onto the list: */
3938 var object new_cons = allocate_cons();
3939 Car(new_cons) = popSTACK();
3940 Cdr(new_cons) = STACK_1;
3941 STACK_1 = new_cons;
3942 } while (mconsp(STACK_0));
3943 args = popSTACK();
3944 /* reverse list STACK_0 and use as REST-parameter: */
3945 nreverse(STACK_0);
3946 /* argument-list finished. */
3947 if (!nullp(args)) goto error_dotted;
3948 }
3949 apply_cclosure_nokey: /* jump to Closure without &KEY : */
3950 closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
3951 apply_cclosure_nokey_:
3952 interpret_bytecode(closure,codevec,CCV_START_NONKEY); /* interpret bytecode starting at Byte 8 */
3953 done:
3954 CHECK_STACK_C(STACKbefore,closure);
3955 skipSTACK(1); /* discard Closure */
3956 unwind(); /* unwind EVAL-Frame */
3957 return; /* finished */
3958 } else {
3959 /* closure is an interpreted Closure */
3960 var gcv_object_t* args_pointer = args_end_pointer; /* Pointer to the arguments */
3961 var uintC args_on_stack = 0; /* number of arguments */
3962 while (consp(args)) {
3963 pushSTACK(Cdr(args)); /* save rest of list */
3964 eval(Car(args)); /* evaluate next element */
3965 args = STACK_0; STACK_0 = value1; /* result into STACK */
3966 args_on_stack += 1;
3967 if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
3968 goto error_toomany;
3969 }
3970 with_saved_back_trace_iclosure(*closure_,args_pointer,args_on_stack,
3971 funcall_iclosure(*closure_,args_pointer,args_on_stack); );
3972 skipSTACK(1); /* discard Closure */
3973 unwind(); /* unwind EVAL-Frame */
3974 return; /* finished */
3975 }
3976 /* Gathered errormessages: */
3977 error_toofew: /* Argument-list args is prematurely an Atom */
3978 if (!nullp(args)) goto error_dotted;
3979 setSTACK(STACK = STACKbefore); /* clean up STACK */
3980 closure = popSTACK();
3981 error_eval_toofew(Closure_name(closure));
3982 error_toomany: /* Argument-list args is not NIL at the end */
3983 if (atomp(args)) goto error_dotted;
3984 setSTACK(STACK = STACKbefore); /* clean up STACK */
3985 closure = popSTACK();
3986 error_eval_toomany(Closure_name(closure));
3987 error_dotted: /* Argument-list args ends with Atom /= NIL */
3988 setSTACK(STACK = STACKbefore); /* clean up STACK */
3989 closure = popSTACK();
3990 error_eval_dotted(Closure_name(closure));
3991 }
3992
3993 #ifdef DYNAMIC_FFI
3994 /* In EVAL: Applies a Foreign-Function to an argument-list,
3995 cleans up STACK and returns the values.
3996 eval_ffunction(fun);
3997 > fun: function, a Foreign-Function
3998 > STACK-layout: EVAL-Frame, *APPLYHOOK*, argument-list.
3999 < STACK: cleaned up
4000 < mv_count/mv_space: values
4001 changes STACK
4002 can trigger GC */
eval_ffunction(object ffun)4003 local maygc Values eval_ffunction(object ffun) {
4004 var object args = popSTACK(); /* Argument-list */
4005 skipSTACK(1); /* skip value of *APPLYHOOK* */
4006 /* STACK-layout: EVAL-Frame.
4007 (ffun arg ...) --> (FFI::FOREIGN-CALL-OUT ffun arg ...) */
4008 check_SP(); check_STACK();
4009 pushSTACK(ffun); /* Foreign-Function as 1st Argument */
4010 {
4011 var gcv_object_t* args_pointer = args_end_pointer; /* Pointer to the arguments */
4012 var uintC args_on_stack = 1; /* number of arguments */
4013 while (consp(args)) {
4014 pushSTACK(Cdr(args)); /* save list-rest */
4015 eval(Car(args)); /* evaluate next element */
4016 args = STACK_0; STACK_0 = value1; /* result into STACK */
4017 args_on_stack += 1;
4018 if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1)) {
4019 set_args_end_pointer(args_pointer);
4020 error_eval_toomany(popSTACK());
4021 }
4022 }
4023 funcall(L(foreign_call_out),args_on_stack);
4024 }
4025 unwind(); /* unwind EVAL-Frame */
4026 return; /* finished */
4027 }
4028 #endif
4029
4030
4031 /* ----------------------- A P P L Y ----------------------- */
4032
4033 /* later: */
4034 local Values apply_subr (object fun, uintC args_on_stack, object other_args);
4035 local Values apply_closure(object fun, uintC args_on_stack, object other_args);
4036
4037 /* UP: Applies a function to its arguments.
4038 apply(function,args_on_stack,other_args);
4039 > function: function
4040 > arguments: args_on_stack arguments on the STACK,
4041 remaining argument-list in other_args
4042 < STACK: cleaned up (i.e. STACK is increased by args_on_stack)
4043 < mv_count/mv_space: values
4044 changes STACK, can trigger GC */
apply(object fun,uintC args_on_stack,object other_args)4045 modexp maygc Values apply (object fun, uintC args_on_stack, object other_args) {
4046 apply_restart:
4047 /* fun must be a SUBR or a Closure or a Cons (LAMBDA ...) : */
4048 if (subrp(fun)) { /* SUBR ? */
4049 return_Values apply_subr(fun,args_on_stack,other_args);
4050 } else if (closurep(fun)) { /* Closure ? */
4051 return_Values apply_closure(fun,args_on_stack,other_args);
4052 } else if (symbolp(fun)) { /* Symbol ? */
4053 /* apply Symbol: global Definition Symbol_function(fun) applies. */
4054 var object fdef = Symbol_function(fun);
4055 if (subrp(fdef)) { /* SUBR -> apply */
4056 return_Values apply_subr(fdef,args_on_stack,other_args);
4057 } else if (closurep(fdef)) { /* Closure -> apply */
4058 return_Values apply_closure(fdef,args_on_stack,other_args);
4059 } else if (orecordp(fdef)) {
4060 #ifdef DYNAMIC_FFI
4061 if (ffunctionp(fdef)) { /* Foreign-Function ? */
4062 fun = fdef; goto call_ffunction;
4063 }
4064 #endif
4065 switch (Record_type(fdef)) {
4066 case Rectype_Fsubr: { error_specialform(S(apply),fun); }
4067 case Rectype_Macro: { error_macro(S(apply),fun); }
4068 default: NOTREACHED;
4069 }
4070 } else
4071 /* if no SUBR, no Closure, no FSUBR, no Macro:
4072 Symbol_function(fun) must be #<UNBOUND> . */
4073 goto undef;
4074 } else if (funnamep(fun)) { /* List (SETF symbol) ? */
4075 /* global Definition (symbol-function (get-setf-symbol symbol)) applies. */
4076 var object symbol = get(Car(Cdr(fun)),S(setf_function)); /* (get ... 'SYS::SETF-FUNCTION) */
4077 if (!symbolp(symbol)) /* should be (uninterned) Symbol */
4078 goto undef; /* else undefined */
4079 var object fdef = Symbol_function(symbol);
4080 if (closurep(fdef)) { /* Closure -> apply */
4081 return_Values apply_closure(fdef,args_on_stack,other_args);
4082 } else if (subrp(fdef)) { /* SUBR -> apply */
4083 return_Values apply_subr(fdef,args_on_stack,other_args);
4084 }
4085 #ifdef DYNAMIC_FFI
4086 else if (ffunctionp(fdef)) { /* Foreign-Function ? */
4087 fun = fdef; goto call_ffunction;
4088 }
4089 #endif
4090 else
4091 /* Such function-names cannot denote FSUBRs or Macros.
4092 fdef is presumably #<UNBOUND> . */
4093 goto undef;
4094 }
4095 #ifdef DYNAMIC_FFI
4096 else if (ffunctionp(fun)) /* Foreign-Function ? */
4097 call_ffunction: { /* call (SYS::FOREIGN-CALL-OUT foreign-function . args) */
4098 /* Therefore first shift down the arguments in Stack by 1. */
4099 var uintC count;
4100 var gcv_object_t* ptr = &STACK_0;
4101 dotimesC(count,args_on_stack, {
4102 *(ptr STACKop -1) = *ptr; ptr skipSTACKop 1;
4103 });
4104 *(ptr STACKop -1) = fun;
4105 skipSTACK(-1);
4106 return_Values apply_subr(L(foreign_call_out),args_on_stack+1,other_args);
4107 }
4108 #endif
4109 else if (consp(fun) && eq(Car(fun),S(lambda))) /* Cons (LAMBDA ...) ? */
4110 error_lambda_expression(S(apply),fun);
4111 else {
4112 pushSTACK(other_args);
4113 fun = check_funname_replacement(type_error,S(apply),fun);
4114 other_args = popSTACK();
4115 goto apply_restart;
4116 }
4117 return;
4118 undef:
4119 pushSTACK(other_args);
4120 fun = check_fdefinition(fun,S(apply));
4121 other_args = popSTACK();
4122 goto apply_restart;
4123 }
4124
4125 /* Error because of too many arguments
4126 > name: name of function */
error_apply_toomany(object name)4127 local _Noreturn void error_apply_toomany (object name) {
4128 pushSTACK(name);
4129 /* ANSI CL 3.5.1.3. wants a PROGRAM-ERROR here. */
4130 error(program_error,GETTEXT("APPLY: too many arguments given to ~S"));
4131 }
4132
4133 /* Error because of too few arguments
4134 > name: name of function
4135 > tail: atom at the end of the argument list */
error_apply_toofew(object name,object tail)4136 local _Noreturn void error_apply_toofew (object name, object tail) {
4137 if (!nullp(tail)) {
4138 pushSTACK(tail); /* ARGUMENT-LIST-DOTTED slot DATUM */
4139 pushSTACK(tail); pushSTACK(name);
4140 error(argument_list_dotted,
4141 GETTEXT("APPLY: dotted argument list given to ~S : ~S"));
4142 } else {
4143 pushSTACK(name);
4144 /* ANSI CL 3.5.1.2. wants a PROGRAM-ERROR here. */
4145 error(program_error,GETTEXT("APPLY: too few arguments given to ~S"));
4146 }
4147 }
4148
4149 /* Error because of too many arguments for a SUBR
4150 > fun: function, a SUBR */
4151 local _Noreturn void error_subr_toomany (object fun);
4152 #define error_subr_toomany(fun) error_apply_toomany(TheSubr(fun)->name)
4153
4154 /* Error because of too few arguments for a SUBR
4155 > fun: function, a SUBR
4156 > tail: atom at the end of the argument list */
4157 local _Noreturn void error_subr_toofew (object fun, object tail);
4158 #define error_subr_toofew(fun,tail) \
4159 error_apply_toofew(TheSubr(fun)->name,tail)
4160
4161 /* In APPLY: Applies a SUBR to an argument-list, cleans up STACK
4162 and returns the values.
4163 apply_subr(fun,args_on_stack,other_args);
4164 > fun: function, a SUBR
4165 > Arguments: args_on_stack Arguments on STACK,
4166 remaining argument-list in other_args
4167 < STACK: cleaned up (i.e. STACK is increased by args_on_stack)
4168 < mv_count/mv_space: values
4169 changes STACK, can trigger GC */
apply_subr(object fun,uintC args_on_stack,object args)4170 local maygc Values apply_subr (object fun, uintC args_on_stack, object args)
4171 {
4172 #if STACKCHECKS
4173 var gcv_object_t* args_pointer = args_end_pointer STACKop args_on_stack; /* Pointer to the arguments */
4174 #endif
4175 var gcv_object_t* key_args_pointer; /* Pointer to the &key */
4176 var gcv_object_t* rest_args_pointer; /* Pointer to the remaining Arguments */
4177 var uintL argcount; /* number of remaining Arguments */
4178 TRACE_CALL(fun,'A','S');
4179 /* push Arguments on STACK:
4180 first a Dispatch for the most important cases: */
4181 switch (TheSubr(fun)->argtype) {
4182 /* Macro for a required argument: */
4183 #define REQ_ARG() \
4184 { if (args_on_stack>0) { args_on_stack--; } \
4185 else if (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
4186 else goto error_toofew; \
4187 }
4188 /* Macro for the n-last optional argument: */
4189 #define OPT_ARG(n) \
4190 { if (args_on_stack>0) { args_on_stack--; } \
4191 else if (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
4192 else goto unbound_optional_##n; \
4193 }
4194 case (uintW)subr_argtype_6_0: /* SUBR with 6 required arguments */
4195 REQ_ARG();
4196 case (uintW)subr_argtype_5_0: /* SUBR with 5 required arguments */
4197 REQ_ARG();
4198 case (uintW)subr_argtype_4_0: /* SUBR with 4 required arguments */
4199 REQ_ARG();
4200 case (uintW)subr_argtype_3_0: /* SUBR with 3 required arguments */
4201 REQ_ARG();
4202 case (uintW)subr_argtype_2_0: /* SUBR with 2 required arguments */
4203 REQ_ARG();
4204 case (uintW)subr_argtype_1_0: /* SUBR with 1 required argument */
4205 REQ_ARG();
4206 case (uintW)subr_argtype_0_0: /* SUBR without Arguments */
4207 if ((args_on_stack>0) || consp(args)) goto error_toomany;
4208 goto apply_subr_norest;
4209 case (uintW)subr_argtype_4_1: /* SUBR with 4 required and 1 optional */
4210 REQ_ARG();
4211 case (uintW)subr_argtype_3_1: /* SUBR with 3 required and 1 optional */
4212 REQ_ARG();
4213 case (uintW)subr_argtype_2_1: /* SUBR with 2 required and 1 optional */
4214 REQ_ARG();
4215 case (uintW)subr_argtype_1_1: /* SUBR with 1 required and 1 optional */
4216 REQ_ARG();
4217 case (uintW)subr_argtype_0_1: /* SUBR with 1 optional argument */
4218 OPT_ARG(1);
4219 if ((args_on_stack>0) || consp(args)) goto error_toomany;
4220 goto apply_subr_norest;
4221 case (uintW)subr_argtype_3_2: /* SUBR with 3 required and 2 optional */
4222 REQ_ARG();
4223 case (uintW)subr_argtype_2_2: /* SUBR with 2 required and 2 optional */
4224 REQ_ARG();
4225 case (uintW)subr_argtype_1_2: /* SUBR with 1 required and 2 optional */
4226 REQ_ARG();
4227 case (uintW)subr_argtype_0_2: /* SUBR with 2 optional arguments */
4228 OPT_ARG(2);
4229 OPT_ARG(1);
4230 if ((args_on_stack>0) || consp(args)) goto error_toomany;
4231 goto apply_subr_norest;
4232 case (uintW)subr_argtype_2_3: /* SUBR with 2 required and 3 optional */
4233 REQ_ARG();
4234 case (uintW)subr_argtype_1_3: /* SUBR with 1 required and 3 optional */
4235 REQ_ARG();
4236 case (uintW)subr_argtype_0_3: /* SUBR with 3 optional arguments */
4237 OPT_ARG(3);
4238 OPT_ARG(2);
4239 OPT_ARG(1);
4240 if ((args_on_stack>0) || consp(args)) goto error_toomany;
4241 goto apply_subr_norest;
4242 case (uintW)subr_argtype_0_5: /* SUBR with 5 optional arguments */
4243 OPT_ARG(5);
4244 case (uintW)subr_argtype_0_4: /* SUBR with 4 optional arguments */
4245 OPT_ARG(4);
4246 OPT_ARG(3);
4247 OPT_ARG(2);
4248 OPT_ARG(1);
4249 if ((args_on_stack>0) || consp(args)) goto error_toomany;
4250 goto apply_subr_norest;
4251 unbound_optional_5: /* Still 5 optionals Arguments, but args_on_stack=0 and atomp(args) */
4252 { pushSTACK(unbound); }
4253 unbound_optional_4: /* Still 4 optional Arguments, but args_on_stack=0 and atomp(args) */
4254 { pushSTACK(unbound); }
4255 unbound_optional_3: /* Still 3 optional Arguments, but args_on_stack=0 and atomp(args) */
4256 { pushSTACK(unbound); }
4257 unbound_optional_2: /* Still 2 optional Arguments, but args_on_stack=0 and atomp(args) */
4258 { pushSTACK(unbound); }
4259 unbound_optional_1: /* Still 1 optionals Argument, but args_on_stack=0 and atomp(args) */
4260 { pushSTACK(unbound); }
4261 goto apply_subr_norest;
4262 case (uintW)subr_argtype_3_0_rest: /* SUBR with 3 required and &rest */
4263 REQ_ARG();
4264 case (uintW)subr_argtype_2_0_rest: /* SUBR with 2 required and &rest */
4265 REQ_ARG();
4266 case (uintW)subr_argtype_1_0_rest: /* SUBR with 1 required and &rest */
4267 REQ_ARG();
4268 case (uintW)subr_argtype_0_0_rest: /* SUBR with rest arguments */
4269 if (args_on_stack==0)
4270 goto apply_subr_rest_onlylist;
4271 else
4272 goto apply_subr_rest_withlist;
4273 case (uintW)subr_argtype_4_0_key: /* SUBR with 4 required and &key */
4274 REQ_ARG();
4275 case (uintW)subr_argtype_3_0_key: /* SUBR with 3 required and &key */
4276 REQ_ARG();
4277 case (uintW)subr_argtype_2_0_key: /* SUBR with 2 required and &key */
4278 REQ_ARG();
4279 case (uintW)subr_argtype_1_0_key: /* SUBR with 1 required and &key */
4280 REQ_ARG();
4281 case (uintW)subr_argtype_0_0_key: /* SUBR with &key */
4282 if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
4283 goto apply_subr_key;
4284 case (uintW)subr_argtype_1_1_key:
4285 /* SUBR with 1 required argument, 1 optional argument and &key */
4286 REQ_ARG();
4287 case (uintW)subr_argtype_0_1_key:
4288 /* SUBR with 1 optional argument and &key */
4289 OPT_ARG(key_1);
4290 if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
4291 goto apply_subr_key;
4292 case (uintW)subr_argtype_1_2_key:
4293 /* SUBR with 1 required argument, 2 optional arguments and &key */
4294 REQ_ARG();
4295 OPT_ARG(key_2);
4296 OPT_ARG(key_1);
4297 if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
4298 goto apply_subr_key;
4299 unbound_optional_key_2: /* Still 2 optional Arguments, but args_on_stack=0 and atomp(args) */
4300 { pushSTACK(unbound); }
4301 unbound_optional_key_1: /* Still 1 optional Argument, but args_on_stack=0 and atomp(args) */
4302 { pushSTACK(unbound); }
4303 unbound_optional_key_0: /* Before the Keywords is args_on_stack=0 and atomp(args) */
4304 {
4305 var uintC count;
4306 dotimesC(count,TheSubr(fun)->key_count, { pushSTACK(unbound); } );
4307 }
4308 goto apply_subr_norest;
4309 default: NOTREACHED;
4310 #undef OPT_ARG
4311 #undef REQ_ARG
4312 }
4313 /* Now the general Version: */
4314 {
4315 var uintC key_count;
4316 {
4317 var uintC req_count = TheSubr(fun)->req_count;
4318 var uintC opt_count = TheSubr(fun)->opt_count;
4319 key_count = TheSubr(fun)->key_count;
4320 if (args_on_stack < req_count) {
4321 /* fewer Arguments there than required */
4322 req_count = req_count - args_on_stack; /* as many as these must go on STACK */
4323 /* reserve space on STACK: */
4324 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)(req_count + opt_count + key_count));
4325 /* store required Parameter in Stack: */
4326 {
4327 var uintC count;
4328 dotimespC(count,req_count, {
4329 if (atomp(args))
4330 goto error_toofew;
4331 pushSTACK(Car(args)); /* store next Argument */
4332 args = Cdr(args);
4333 });
4334 }
4335 goto optionals_from_list;
4336 }
4337 args_on_stack -= req_count; /* remaining number */
4338 if (args_on_stack < opt_count) {
4339 /* Arguments in Stack don't last for the optional ones */
4340 opt_count = opt_count - args_on_stack; /* as many as these must go on STACK */
4341 /* reserve space on STACK: */
4342 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)(opt_count + key_count));
4343 optionals_from_list:
4344 { /* store optional Parameters on Stack: */
4345 var uintC count = opt_count;
4346 while (consp(args)) { /* argument-list not finished? */
4347 if (count==0) /* all optional Parameters supplied with? */
4348 goto optionals_ok;
4349 count--;
4350 pushSTACK(Car(args)); /* store next Argument */
4351 args = Cdr(args);
4352 }
4353 if (!nullp(args)) goto error_dotted;
4354 /* Argument-list finished.
4355 All further count optional Parameters receive the "value"
4356 #<UNBOUND>, including the Keyword-Parameters: */
4357 dotimesC(count,count + key_count, { pushSTACK(unbound); } );
4358 if (TheSubr(fun)->rest_flag == subr_rest) { /* &REST-Flag? */
4359 /* yes -> 0 additional Arguments: */
4360 argcount = 0; rest_args_pointer = args_end_pointer;
4361 goto apply_subr_rest;
4362 } else {
4363 /* no -> nothing to do */
4364 goto apply_subr_norest;
4365 }
4366 }
4367 optionals_ok: /* optional Argument OK, continue processing (non-empty) list */
4368 if (TheSubr(fun)->key_flag == subr_nokey) {
4369 /* SUBR without KEY */
4370 if (TheSubr(fun)->rest_flag == subr_norest)
4371 /* SUBR without REST or KEY */
4372 error_subr_toomany(fun); /* too many Arguments */
4373 else
4374 /* SUBR with only REST, without KEY */
4375 goto apply_subr_rest_onlylist;
4376 } else {
4377 /* SUBR with KEY */
4378 key_args_pointer = args_end_pointer;
4379 {
4380 var uintC count;
4381 dotimesC(count,key_count, { pushSTACK(unbound); } );
4382 }
4383 rest_args_pointer = args_end_pointer;
4384 argcount = 0;
4385 goto key_from_list;
4386 }
4387 }
4388 args_on_stack -= opt_count; /* remaining number */
4389 if (TheSubr(fun)->key_flag == subr_nokey) {
4390 /* SUBR without KEY */
4391 if (TheSubr(fun)->rest_flag == subr_norest) {
4392 /* SUBR without REST or KEY */
4393 if ((args_on_stack>0) || consp(args)) /* still Arguments? */
4394 error_subr_toomany(fun);
4395 goto apply_subr_norest;
4396 } else
4397 /* SUBR with only REST, without KEY */
4398 goto apply_subr_rest_withlist;
4399 } else
4400 /* SUBR with Keywords. */
4401 goto apply_subr_key_;
4402 }
4403 apply_subr_key:
4404 key_count = TheSubr(fun)->key_count;
4405 apply_subr_key_:
4406 /* shift down remaining Arguments on STACK and thus
4407 create room for the Keyword-Parameters: */
4408 argcount = args_on_stack;
4409 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)key_count);
4410 {
4411 var gcv_object_t* new_args_end_pointer = args_end_pointer STACKop -(uintP)key_count;
4412 var gcv_object_t* ptr1 = args_end_pointer;
4413 var gcv_object_t* ptr2 = new_args_end_pointer;
4414 var uintC count;
4415 dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
4416 key_args_pointer = ptr1;
4417 rest_args_pointer = ptr2;
4418 dotimesC(count,key_count, { NEXT(ptr1) = unbound; } );
4419 set_args_end_pointer(new_args_end_pointer);
4420 }
4421 key_from_list: /* take remaining Arguments for Keywords from list */
4422 while (consp(args)) {
4423 check_STACK(); pushSTACK(Car(args)); /* push next argument onto Stack */
4424 args = Cdr(args);
4425 argcount++;
4426 }
4427 if (!nullp(args)) goto error_dotted;
4428 /* assign Keywords and poss. discard remaining arguments: */
4429 match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
4430 if (TheSubr(fun)->rest_flag != subr_norest)
4431 /* SUBR with &REST-Flag: */
4432 goto apply_subr_rest;
4433 else
4434 /* SUBR without &REST-Flag: */
4435 goto apply_subr_norest;
4436 }
4437 apply_subr_rest_onlylist:
4438 argcount = 0; rest_args_pointer = args_end_pointer;
4439 goto rest_from_list;
4440 apply_subr_rest_withlist:
4441 argcount = args_on_stack;
4442 rest_args_pointer = args_end_pointer STACKop argcount;
4443 rest_from_list: /* take remaining Arguments from list */
4444 while (consp(args)) {
4445 check_STACK(); pushSTACK(Car(args)); /* next argument onto Stack */
4446 args = Cdr(args);
4447 argcount++;
4448 }
4449 if (!nullp(args)) goto error_dotted;
4450 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1)) /* too many arguments? */
4451 goto error_toomany;
4452 apply_subr_rest:
4453 if (!nullp(args)) goto error_dotted;
4454 with_saved_back_trace_subr(fun,STACK,
4455 TheSubr(fun)->req_count + TheSubr(fun)->opt_count + argcount,
4456 (*(subr_rest_function_t*)(TheSubr(fun)->function))(argcount,rest_args_pointer); );
4457 goto done;
4458 apply_subr_norest:
4459 if (!nullp(args)) goto error_dotted;
4460 with_saved_back_trace_subr(fun,STACK,-1,
4461 (*(subr_norest_function_t*)(TheSubr(fun)->function))(); );
4462 done:
4463 CHECK_STACK_S(args_end_pointer,fun);
4464 return; /* finished */
4465 /* gathered error messages: */
4466 error_dotted: error_toofew: error_subr_toofew(fun,args);
4467 error_toomany: error_subr_toomany(fun);
4468 }
4469
4470 /* Error because of too many arguments for a Closure
4471 > closure: function, a Closure */
4472 local _Noreturn void error_closure_toomany (object closure);
4473 #define error_closure_toomany(closure) error_apply_toomany(closure)
4474
4475 /* Error because of too few arguments for a Closure
4476 > closure: function, a Closure
4477 > tail: atom at the end of the argument list */
4478 local _Noreturn void error_closure_toofew (object closure, object tail);
4479 #define error_closure_toofew(closure,tail) error_apply_toofew(closure,tail)
4480
4481 /* In APPLY: Applies a Closure to an argument-list, cleans up STACK
4482 and returns the values.
4483 apply_closure(fun,args_on_stack,other_args);
4484 > fun: function, a Closure
4485 > Arguments: args_on_stack arguments on STACK,
4486 remaining argument-list in other_args
4487 < STACK: cleaned up (i.e. STACK is increased by args_on_stack)
4488 < mv_count/mv_space: values
4489 changes STACK, can trigger GC */
apply_closure(object closure,uintC args_on_stack,object args)4490 local maygc Values apply_closure (object closure, uintC args_on_stack, object args)
4491 {
4492 TRACE_CALL(closure,'A','C');
4493 if (simple_bit_vector_p(Atype_8Bit,TheClosure(closure)->clos_codevec)) {
4494 /* closure is a compiled Closure */
4495 #if STACKCHECKC
4496 var gcv_object_t* args_pointer = args_end_pointer STACKop args_on_stack; /* Pointer to the arguments */
4497 #endif
4498 var object codevec = TheCclosure(closure)->clos_codevec; /* Code-Vector */
4499 var gcv_object_t* key_args_pointer; /* Pointer to the Keyword-arguments */
4500 var gcv_object_t* rest_args_pointer; /* Pointer to the remaining arguments */
4501 var uintL argcount; /* number of remaining arguments */
4502 check_SP(); check_STACK();
4503 /* put arguments in STACK: first a Dispatch for the most important cases: */
4504 switch (TheCodevec(codevec)->ccv_signature) {
4505 /* Macro for a required-argument: */
4506 #define REQ_ARG() \
4507 { if (args_on_stack>0) { args_on_stack--; } \
4508 else if (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
4509 else goto error_toofew; \
4510 }
4511 /* Macro for the n-last optional-argument: */
4512 #define OPT_ARG(n) \
4513 { if (args_on_stack>0) { args_on_stack--; } \
4514 else if (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
4515 else goto unbound_optional_##n; \
4516 }
4517 case (uintB)cclos_argtype_5_0: /* 5 required arguments */
4518 REQ_ARG();
4519 case (uintB)cclos_argtype_4_0: /* 4 required arguments */
4520 REQ_ARG();
4521 case (uintB)cclos_argtype_3_0: /* 3 required arguments */
4522 REQ_ARG();
4523 case (uintB)cclos_argtype_2_0: /* 2 required arguments */
4524 REQ_ARG();
4525 case (uintB)cclos_argtype_1_0: /* 1 required argument */
4526 REQ_ARG();
4527 case (uintB)cclos_argtype_0_0: /* no Arguments */
4528 noch_0_opt_args:
4529 if (args_on_stack>0) goto error_toomany;
4530 if (!nullp(args)) {
4531 if (consp(args))
4532 goto error_toomany;
4533 else
4534 goto error_dotted;
4535 }
4536 goto apply_cclosure_nokey;
4537 case (uintB)cclos_argtype_4_1: /* 4 required and 1 optional */
4538 REQ_ARG();
4539 case (uintB)cclos_argtype_3_1: /* 3 required and 1 optional */
4540 REQ_ARG();
4541 case (uintB)cclos_argtype_2_1: /* 2 required and 1 optional */
4542 REQ_ARG();
4543 case (uintB)cclos_argtype_1_1: /* 1 required and 1 optional */
4544 REQ_ARG();
4545 case (uintB)cclos_argtype_0_1: /* 1 optional argument */
4546 noch_1_opt_args:
4547 OPT_ARG(1);
4548 goto noch_0_opt_args;
4549 case (uintB)cclos_argtype_3_2: /* 3 required and 2 optional */
4550 REQ_ARG();
4551 case (uintB)cclos_argtype_2_2: /* 2 required and 2 optional */
4552 REQ_ARG();
4553 case (uintB)cclos_argtype_1_2: /* 1 required and 2 optional */
4554 REQ_ARG();
4555 case (uintB)cclos_argtype_0_2: /* 2 optional arguments */
4556 noch_2_opt_args:
4557 OPT_ARG(2);
4558 goto noch_1_opt_args;
4559 case (uintB)cclos_argtype_2_3: /* 2 required and 3 optional */
4560 REQ_ARG();
4561 case (uintB)cclos_argtype_1_3: /* 1 required and 3 optional */
4562 REQ_ARG();
4563 case (uintB)cclos_argtype_0_3: /* 3 optional arguments */
4564 noch_3_opt_args:
4565 OPT_ARG(3);
4566 goto noch_2_opt_args;
4567 case (uintB)cclos_argtype_1_4: /* 1 required and 4 optional */
4568 REQ_ARG();
4569 case (uintB)cclos_argtype_0_4: /* 4 optional arguments */
4570 noch_4_opt_args:
4571 OPT_ARG(4);
4572 goto noch_3_opt_args;
4573 case (uintB)cclos_argtype_0_5: /* 5 optional arguments */
4574 OPT_ARG(5);
4575 goto noch_4_opt_args;
4576 unbound_optional_5: /* Still 5 optional Arguments, but args_on_stack=0 and atomp(args) */
4577 { pushSTACK(unbound); }
4578 unbound_optional_4: /* Still 4 optional Arguments, but args_on_stack=0 and atomp(args) */
4579 { pushSTACK(unbound); }
4580 unbound_optional_3: /* Still 3 optional Arguments, but args_on_stack=0 and atomp(args) */
4581 { pushSTACK(unbound); }
4582 unbound_optional_2: /* Still 2 optional Arguments, but args_on_stack=0 and atomp(args) */
4583 { pushSTACK(unbound); }
4584 unbound_optional_1: /* Still 1 optional Argument, but args_on_stack=0 and atomp(args) */
4585 { pushSTACK(unbound); }
4586 if (!nullp(args)) goto error_dotted;
4587 goto apply_cclosure_nokey;
4588 case (uintB)cclos_argtype_4_0_rest: /* 4 required + &rest */
4589 REQ_ARG();
4590 case (uintB)cclos_argtype_3_0_rest: /* 3 required + &rest */
4591 REQ_ARG();
4592 case (uintB)cclos_argtype_2_0_rest: /* 2 required + &rest */
4593 REQ_ARG();
4594 case (uintB)cclos_argtype_1_0_rest: /* 1 required + &rest */
4595 REQ_ARG();
4596 case (uintB)cclos_argtype_0_0_rest: /* no Arguments, Rest-Parameter */
4597 goto apply_cclosure_rest_nokey;
4598 case (uintB)cclos_argtype_4_0_key: /* 4 required arguments, &key */
4599 REQ_ARG();
4600 case (uintB)cclos_argtype_3_0_key: /* 3 required arguments, &key */
4601 REQ_ARG();
4602 case (uintB)cclos_argtype_2_0_key: /* 2 required arguments, &key */
4603 REQ_ARG();
4604 case (uintB)cclos_argtype_1_0_key: /* 1 required argument, &key */
4605 REQ_ARG();
4606 noch_0_opt_args_key:
4607 case (uintB)cclos_argtype_0_0_key: /* only &key */
4608 if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
4609 goto apply_cclosure_key_withlist;
4610 case (uintB)cclos_argtype_3_1_key:
4611 /* 3 required arguments and 1 optional argument, &key */
4612 REQ_ARG();
4613 case (uintB)cclos_argtype_2_1_key:
4614 /* 2 required arguments and 1 optional argument, &key */
4615 REQ_ARG();
4616 case (uintB)cclos_argtype_1_1_key:
4617 /* 1 required argument and 1 optional argument, &key */
4618 REQ_ARG();
4619 case (uintB)cclos_argtype_0_1_key: /* 1 optional argument, &key */
4620 noch_1_opt_args_key:
4621 OPT_ARG(key_1);
4622 goto noch_0_opt_args_key;
4623 case (uintB)cclos_argtype_2_2_key:
4624 /* 2 required arguments and 2 optional arguments, &key */
4625 REQ_ARG();
4626 case (uintB)cclos_argtype_1_2_key:
4627 /* 1 required argument and 2 optional arguments, &key */
4628 REQ_ARG();
4629 case (uintB)cclos_argtype_0_2_key:
4630 /* 2 optional arguments, &key */
4631 noch_2_opt_args_key:
4632 OPT_ARG(key_2);
4633 goto noch_1_opt_args_key;
4634 case (uintB)cclos_argtype_1_3_key:
4635 /* 1 required argument and 3 optional arguments, &key */
4636 REQ_ARG();
4637 case (uintB)cclos_argtype_0_3_key:
4638 /* 3 optional arguments, &key */
4639 noch_3_opt_args_key:
4640 OPT_ARG(key_3);
4641 goto noch_2_opt_args_key;
4642 case (uintB)cclos_argtype_0_4_key:
4643 /* 4 optional arguments, &key */
4644 OPT_ARG(key_4);
4645 goto noch_3_opt_args_key;
4646 unbound_optional_key_4: /* Still 4 optional Arguments, but args_on_stack=0 and atomp(args) */
4647 { pushSTACK(unbound); }
4648 unbound_optional_key_3: /* Still 3 optional Arguments, but args_on_stack=0 and atomp(args) */
4649 { pushSTACK(unbound); }
4650 unbound_optional_key_2: /* Still 2 optional Arguments, but args_on_stack=0 and atomp(args) */
4651 { pushSTACK(unbound); }
4652 unbound_optional_key_1: /* Still 1 optional Argument, but args_on_stack=0 and atomp(args) */
4653 { pushSTACK(unbound); }
4654 unbound_optional_key_0: /* Before the Keywords is args_on_stack=0 and atomp(args) */
4655 if (!nullp(args)) goto error_dotted;
4656 goto apply_cclosure_key_noargs;
4657 case (uintB)cclos_argtype_default:
4658 /* General Version */
4659 break;
4660 default: NOTREACHED;
4661 #undef OPT_ARG
4662 #undef REQ_ARG
4663 }
4664 /* Now the general Version: */
4665 {
4666 var uintB flags;
4667 {
4668 var uintC req_count = TheCodevec(codevec)->ccv_numreq; /* number of required Parameters */
4669 var uintC opt_count = TheCodevec(codevec)->ccv_numopt; /* number of optional Parameters */
4670 flags = TheCodevec(codevec)->ccv_flags; /* Flags */
4671 if (args_on_stack < req_count) {
4672 /* fewer Arguments than demanded */
4673 req_count = req_count - args_on_stack; /* as many as these must on STACK */
4674 /* reserve space on STACK: */
4675 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)(req_count + opt_count));
4676 /* store required Parameters on Stack: */
4677 {
4678 var uintC count;
4679 dotimespC(count,req_count, {
4680 if (atomp(args))
4681 goto error_toofew;
4682 pushSTACK(Car(args)); /* store next argument */
4683 args = Cdr(args);
4684 });
4685 }
4686 goto optionals_from_list;
4687 }
4688 args_on_stack -= req_count; /* remaining number */
4689 if (args_on_stack < opt_count) {
4690 /* Arguments in Stack don't last for the optional ones */
4691 opt_count = opt_count - args_on_stack; /* as many as these must go on STACK */
4692 /* reserve space on STACK: */
4693 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)opt_count);
4694 optionals_from_list:
4695 { /* store optional parameters on Stack: */
4696 var uintC count = opt_count;
4697 while (consp(args)) { /* argument-list not finished? */
4698 if (count==0) /* all optional parameters supplied with? */
4699 goto optionals_ok;
4700 count--;
4701 pushSTACK(Car(args)); /* store next argument */
4702 args = Cdr(args);
4703 }
4704 /* argument-list finished. */
4705 if (!nullp(args)) goto error_dotted;
4706 /* All further count optional parameters receive the "value"
4707 #<UNBOUND>, the &REST-parameter receives NIL,
4708 the Keyword-parameters receive the value #<UNBOUND> : */
4709 dotimesC(count,count, { pushSTACK(unbound); } );
4710 }
4711 if (flags & bit(0)) /* &REST-Flag? */
4712 pushSTACK(NIL); /* yes -> initialize with NIL */
4713 if (flags & bit(7)) /* &KEY-Flag? */
4714 goto apply_cclosure_key_noargs;
4715 else
4716 goto apply_cclosure_nokey;
4717 optionals_ok:
4718 /* process Rest- and Keyword-parameters.
4719 args = remaining argument-list (not yet finished) */
4720 if (flags == 0)
4721 /* Closure without REST or KEY -> argument-list should be finished */
4722 goto error_toomany;
4723 /* poss. fill the Rest-parameter: */
4724 if (flags & bit(0))
4725 pushSTACK(args);
4726 if (flags & bit(7)) { /* Key-Flag? */
4727 /* Closure with Keywords.
4728 args = remaining argument-list (not yet finished)
4729 First initialize the Keyword-parameters with #<UNBOUND> ,
4730 the store the remaining arguments in Stack,
4731 then assign the Keywords: */
4732 key_args_pointer = args_end_pointer; /* Pointer to the Keyword-parameters */
4733 /* initialize all Keyword-parameters with #<UNBOUND> : */
4734 {
4735 var uintC count = TheCodevec(codevec)->ccv_numkey;
4736 dotimesC(count,count, { pushSTACK(unbound); } );
4737 }
4738 rest_args_pointer = args_end_pointer; /* Pointer to the remaining arguments */
4739 argcount = 0; /* counter for the remaining arguments */
4740 goto key_from_list;
4741 } else
4742 /* Closure with only REST, without KEY: */
4743 goto apply_cclosure_nokey;
4744 }
4745 args_on_stack -= opt_count; /* remaining number */
4746 if (flags & bit(7)) /* Key-Flag? */
4747 goto apply_cclosure_key_withlist_;
4748 else if (flags & bit(0))
4749 goto apply_cclosure_rest_nokey;
4750 else {
4751 /* Closure without REST or KEY */
4752 if ((args_on_stack>0) || consp(args)) /* still arguments? */
4753 goto error_toomany;
4754 goto apply_cclosure_nokey;
4755 }
4756 }
4757 apply_cclosure_key_noargs:
4758 {
4759 var uintC key_count = TheCodevec(codevec)->ccv_numkey; /* number of Keyword-parameters */
4760 if (key_count > 0) {
4761 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)key_count);
4762 var uintC count;
4763 dotimespC(count,key_count, { pushSTACK(unbound); } ); /* initialize with #<UNBOUND> */
4764 }
4765 goto apply_cclosure_key;
4766 }
4767 apply_cclosure_key_withlist:
4768 flags = TheCodevec(codevec)->ccv_flags; /* initialize flags! */
4769 apply_cclosure_key_withlist_:
4770 /* Closure with Keywords */
4771 {
4772 var uintC key_count = TheCodevec(codevec)->ccv_numkey; /* number of Keyword-parameters */
4773 /* shift down remaining arguments in STACK and thus
4774 create room for the Keyword-parameters
4775 (and poss. Rest-parameters): */
4776 var uintL shift = key_count;
4777 if (flags & bit(0))
4778 shift++; /* poss. 1 more for Rest-Parameter */
4779 argcount = args_on_stack;
4780 get_space_on_STACK(sizeof(gcv_object_t) * shift);
4781 var gcv_object_t* new_args_end_pointer = args_end_pointer STACKop -(uintP)shift;
4782 var gcv_object_t* ptr1 = args_end_pointer;
4783 var gcv_object_t* ptr2 = new_args_end_pointer;
4784 var uintC count;
4785 dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
4786 if (flags & bit(0))
4787 NEXT(ptr1) = args; /* Rest-Parameter (preliminary) */
4788 key_args_pointer = ptr1;
4789 rest_args_pointer = ptr2;
4790 dotimesC(count,key_count, { NEXT(ptr1) = unbound; } );
4791 set_args_end_pointer(new_args_end_pointer);
4792 if (flags & bit(0))
4793 /* fill Rest-Parameter, less effort than with match_cclosure_key: */
4794 if (args_on_stack > 0) {
4795 var gcv_object_t* ptr3 = new_args_end_pointer;
4796 pushSTACK(closure); /* save Closure */
4797 pushSTACK(args); /* save args */
4798 dotimespC(count,args_on_stack, {
4799 var object new_cons = allocate_cons();
4800 Car(new_cons) = BEFORE(ptr3);
4801 Cdr(new_cons) = Before(key_args_pointer);
4802 Before(key_args_pointer) = new_cons;
4803 });
4804 args = popSTACK();
4805 closure = popSTACK();
4806 }
4807 }
4808 key_from_list: /* remove remaining arguments for Keywords from list */
4809 while (consp(args)) {
4810 check_STACK(); pushSTACK(Car(args)); /* store next argument in Stack */
4811 args = Cdr(args);
4812 argcount++;
4813 }
4814 /* argument-list finished. */
4815 if (!nullp(args)) goto error_dotted;
4816 /* assign Keywords, build Rest-parameter
4817 and poss. discard remaining arguments: */
4818 closure = match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer);
4819 codevec = TheCclosure(closure)->clos_codevec;
4820 apply_cclosure_key:
4821 interpret_bytecode(closure,codevec,CCV_START_KEY); /* process Bytecode starting at Byte 12 */
4822 goto done;
4823 }
4824 apply_cclosure_rest_nokey:
4825 /* we could use list_length() to catch (apply #'foo '(1 . 1))
4826 too but the cost would be ridiculous */
4827 if (!listp(args)) goto error_dotted;
4828 /* Closure with only REST, without KEY:
4829 still has to cons args_on_stack Arguments from Stack to args: */
4830 pushSTACK(args);
4831 if (args_on_stack > 0) {
4832 pushSTACK(closure); /* Closure must be saved */
4833 dotimespC(args_on_stack,args_on_stack, {
4834 var object new_cons = allocate_cons();
4835 Cdr(new_cons) = STACK_1;
4836 Car(new_cons) = STACK_2; /* cons next argument to it */
4837 STACK_2 = new_cons;
4838 STACK_1 = STACK_0; skipSTACK(1);
4839 });
4840 closure = popSTACK(); codevec = TheCclosure(closure)->clos_codevec;
4841 }
4842 goto apply_cclosure_nokey;
4843 apply_cclosure_nokey: /* jump to Closure without &KEY: */
4844 interpret_bytecode(closure,codevec,CCV_START_NONKEY); /* process Bytecode starting at Byte 8 */
4845 done:
4846 CHECK_STACK_C(args_end_pointer,closure);
4847 return; /* finished */
4848 } else {
4849 /* closure is an interpreted Closure
4850 reserve space on STACK: */
4851 get_space_on_STACK(sizeof(gcv_object_t) * llength(args));
4852 while (consp(args)) { /* Still Arguments in list? */
4853 pushSTACK(Car(args)); /* push next Element in STACK */
4854 args = Cdr(args);
4855 args_on_stack += 1;
4856 if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
4857 goto error_toomany;
4858 }
4859 if (!nullp(args)) goto error_dotted;
4860 var gcv_object_t* args_pointer = args_end_pointer STACKop args_on_stack;
4861 with_saved_back_trace_iclosure(closure,args_pointer,args_on_stack,
4862 funcall_iclosure(closure,args_pointer,args_on_stack); );
4863 return; /* finished */
4864 }
4865 /* Gathered error-messages: */
4866 error_dotted: error_toofew: error_closure_toofew(closure,args);
4867 error_toomany: error_closure_toomany(closure);
4868 }
4869
4870
4871 /* ----------------------- F U N C A L L ----------------------- */
4872
4873 /* later: */
4874 local Values funcall_subr (object fun, uintC args_on_stack);
4875 local Values funcall_closure (object fun, uintC args_on_stack);
4876
4877 /* UP: Applies a function to its arguments.
4878 funcall(function,argcount);
4879 > function: function
4880 > Arguments: argcount arguments on STACK
4881 < STACK: cleaned up (i.e. STACK is increased by argcount)
4882 < mv_count/mv_space: values
4883 changes STACK, can trigger GC */
funcall(object fun,uintC args_on_stack)4884 modexp maygc Values funcall (object fun, uintC args_on_stack)
4885 {
4886 funcall_restart:
4887 /* fun must be a SUBR or a Closure or a Cons (LAMBDA ...) : */
4888 if (subrp(fun)) { /* SUBR ? */
4889 return_Values funcall_subr(fun,args_on_stack);
4890 } else if (closurep(fun)) { /* Closure ? */
4891 return_Values funcall_closure(fun,args_on_stack);
4892 } else if (symbolp(fun)) { /* Symbol ? */
4893 /* apply Symbol: global Definition Symbol_function(fun) applies. */
4894 var object fdef = Symbol_function(fun);
4895 if (subrp(fdef)) { /* SUBR -> apply */
4896 return_Values funcall_subr(fdef,args_on_stack);
4897 } else if (closurep(fdef)) { /* Closure -> apply */
4898 return_Values funcall_closure(fdef,args_on_stack);
4899 } else if (orecordp(fdef)) {
4900 #ifdef DYNAMIC_FFI
4901 if (ffunctionp(fdef)) { /* Foreign-Function ? */
4902 fun = fdef; goto call_ffunction;
4903 }
4904 #endif
4905 switch (Record_type(fdef)) {
4906 case Rectype_Fsubr: { error_specialform(S(funcall),fun); }
4907 case Rectype_Macro: { error_macro(S(funcall),fun); }
4908 default: NOTREACHED;
4909 }
4910 } else
4911 /* if no SUBR, no Closure, no FSUBR, no Macro:
4912 Symbol_function(fun) must be #<UNBOUND> . */
4913 goto undef;
4914 } else if (funnamep(fun)) { /* list (SETF symbol) ? */
4915 /* global definition (symbol-function (get-setf-symbol symbol)) applies. */
4916 var object symbol = get(Car(Cdr(fun)),S(setf_function)); /* (get ... 'SYS::SETF-FUNCTION) */
4917 if (!symbolp(symbol)) /* should be (uninterned) symbol */
4918 goto undef; /* else undefined */
4919 var object fdef = Symbol_function(symbol);
4920 if (closurep(fdef)) { /* Closure -> apply */
4921 return_Values funcall_closure(fdef,args_on_stack);
4922 } else if (subrp(fdef)) { /* SUBR -> apply */
4923 return_Values funcall_subr(fdef,args_on_stack);
4924 }
4925 #ifdef DYNAMIC_FFI
4926 else if (ffunctionp(fdef)) { /* Foreign-Function ? */
4927 fun = fdef; goto call_ffunction;
4928 }
4929 #endif
4930 else
4931 /* Such function-names cannot denote FSUBRs or Macros.
4932 fdef is presumable #<UNBOUND> . */
4933 goto undef;
4934 }
4935 #ifdef DYNAMIC_FFI
4936 else if (ffunctionp(fun)) /* Foreign-Function ? */
4937 call_ffunction: { /* call (SYS::FOREIGN-CALL-OUT foreign-function . args) */
4938 /* First shift down the arguments in Stack by 1. */
4939 var uintC count;
4940 var gcv_object_t* ptr = &STACK_0;
4941 dotimesC(count,args_on_stack, {
4942 *(ptr STACKop -1) = *ptr; ptr skipSTACKop 1;
4943 });
4944 *(ptr STACKop -1) = fun;
4945 skipSTACK(-1);
4946 return_Values funcall_subr(L(foreign_call_out),args_on_stack+1);
4947 }
4948 #endif
4949 else if (consp(fun) && eq(Car(fun),S(lambda))) /* Cons (LAMBDA ...) ? */
4950 error_lambda_expression(S(funcall),fun);
4951 else {
4952 fun = check_funname_replacement(type_error,S(funcall),fun);
4953 goto funcall_restart;
4954 }
4955 return;
4956 undef:
4957 fun = check_fdefinition(fun,S(funcall));
4958 goto funcall_restart;
4959 }
4960
4961 /* In FUNCALL: Applies a SUBR to arguments, cleans up STACK
4962 and returns the values.
4963 funcall_subr(fun,args_on_stack);
4964 > fun: function, a SUBR
4965 > Arguments: args_on_stack arguments on STACK
4966 < STACK: cleaned up (i.e. STACK is increased by args_on_stack)
4967 < mv_count/mv_space: values
4968 changes STACK, can trigger GC */
funcall_subr(object fun,uintC args_on_stack)4969 local maygc Values funcall_subr (object fun, uintC args_on_stack)
4970 {
4971 #if STACKCHECKS
4972 var gcv_object_t* args_pointer = args_end_pointer STACKop args_on_stack; /* Pointer to the arguments */
4973 #endif
4974 var gcv_object_t* key_args_pointer; /* Pointer to the Keyword-arguments */
4975 var gcv_object_t* rest_args_pointer; /* Pointer to the remaining arguments */
4976 var uintL argcount; /* number of remaining arguments */
4977 TRACE_CALL(fun,'F','S');
4978 /* store arguments in STACK:
4979 First a Dispatch for the most important cases: */
4980 switch (TheSubr(fun)->argtype) {
4981 case (uintW)subr_argtype_0_0: /* SUBR without Arguments */
4982 if (!(args_on_stack==0)) goto error_toomany;
4983 goto apply_subr_norest;
4984 case (uintW)subr_argtype_1_0: /* SUBR with 1 required argument */
4985 if (!(args_on_stack==1)) goto error_count;
4986 goto apply_subr_norest;
4987 case (uintW)subr_argtype_2_0: /* SUBR with 2 required arguments */
4988 if (!(args_on_stack==2)) goto error_count;
4989 goto apply_subr_norest;
4990 case (uintW)subr_argtype_3_0: /* SUBR with 3 required arguments */
4991 if (!(args_on_stack==3)) goto error_count;
4992 goto apply_subr_norest;
4993 case (uintW)subr_argtype_4_0: /* SUBR with 4 required arguments */
4994 if (!(args_on_stack==4)) goto error_count;
4995 goto apply_subr_norest;
4996 case (uintW)subr_argtype_5_0: /* SUBR with 5 required arguments */
4997 if (!(args_on_stack==5)) goto error_count;
4998 goto apply_subr_norest;
4999 case (uintW)subr_argtype_6_0: /* SUBR with 6 required arguments */
5000 if (!(args_on_stack==6)) goto error_count;
5001 goto apply_subr_norest;
5002 case (uintW)subr_argtype_0_1: /* SUBR with 1 optional argument */
5003 if (args_on_stack==1) goto apply_subr_norest;
5004 else if (args_on_stack>1) goto error_toomany;
5005 else { pushSTACK(unbound); goto apply_subr_norest; }
5006 case (uintW)subr_argtype_1_1: /* SUBR with 1 required and 1 optional */
5007 if (args_on_stack==2) goto apply_subr_norest;
5008 else if (args_on_stack>2) goto error_toomany;
5009 else if (args_on_stack==0) goto error_toofew;
5010 else { pushSTACK(unbound); goto apply_subr_norest; }
5011 case (uintW)subr_argtype_2_1: /* SUBR with 2 required and 1 optional */
5012 if (args_on_stack==3) goto apply_subr_norest;
5013 else if (args_on_stack>3) goto error_toomany;
5014 else if (args_on_stack<2) goto error_toofew;
5015 else { pushSTACK(unbound); goto apply_subr_norest; }
5016 case (uintW)subr_argtype_3_1: /* SUBR with 3 required and 1 optional */
5017 if (args_on_stack==4) goto apply_subr_norest;
5018 else if (args_on_stack>4) goto error_toomany;
5019 else if (args_on_stack<3) goto error_toofew;
5020 else { pushSTACK(unbound); goto apply_subr_norest; }
5021 case (uintW)subr_argtype_4_1: /* SUBR with 4 required and 1 optional */
5022 if (args_on_stack==5) goto apply_subr_norest;
5023 else if (args_on_stack>5) goto error_toomany;
5024 else if (args_on_stack<4) goto error_toofew;
5025 else { pushSTACK(unbound); goto apply_subr_norest; }
5026 case (uintW)subr_argtype_0_2: /* SUBR with 2 optional arguments */
5027 switch (args_on_stack) {
5028 case 0: { pushSTACK(unbound); }
5029 case 1: { pushSTACK(unbound); }
5030 case 2: goto apply_subr_norest;
5031 default: goto error_toomany;
5032 }
5033 case (uintW)subr_argtype_1_2: /* SUBR with 1 required and 2 optional */
5034 switch (args_on_stack) {
5035 case 0: goto error_toofew;
5036 case 1: { pushSTACK(unbound); }
5037 case 2: { pushSTACK(unbound); }
5038 case 3: goto apply_subr_norest;
5039 default: goto error_toomany;
5040 }
5041 case (uintW)subr_argtype_2_2: /* SUBR with 2 required and 2 optional */
5042 switch (args_on_stack) {
5043 case 0: goto error_toofew;
5044 case 1: goto error_toofew;
5045 case 2: { pushSTACK(unbound); }
5046 case 3: { pushSTACK(unbound); }
5047 case 4: goto apply_subr_norest;
5048 default: goto error_toomany;
5049 }
5050 case (uintW)subr_argtype_3_2: /* SUBR with 3 required and 2 optional */
5051 switch (args_on_stack) {
5052 case 0: goto error_toofew;
5053 case 1: goto error_toofew;
5054 case 2: goto error_toofew;
5055 case 3: { pushSTACK(unbound); }
5056 case 4: { pushSTACK(unbound); }
5057 case 5: goto apply_subr_norest;
5058 default: goto error_toomany;
5059 }
5060 case (uintW)subr_argtype_0_3: /* SUBR with 3 optional arguments */
5061 switch (args_on_stack) {
5062 case 0: { pushSTACK(unbound); }
5063 case 1: { pushSTACK(unbound); }
5064 case 2: { pushSTACK(unbound); }
5065 case 3: goto apply_subr_norest;
5066 default: goto error_toomany;
5067 }
5068 case (uintW)subr_argtype_1_3: /* SUBR with 1 required and 3 optional */
5069 switch (args_on_stack) {
5070 case 0: goto error_toofew;
5071 case 1: { pushSTACK(unbound); }
5072 case 2: { pushSTACK(unbound); }
5073 case 3: { pushSTACK(unbound); }
5074 case 4: goto apply_subr_norest;
5075 default: goto error_toomany;
5076 }
5077 case (uintW)subr_argtype_2_3: /* SUBR with 2 required and 3 optional */
5078 switch (args_on_stack) {
5079 case 0: goto error_toofew;
5080 case 1: goto error_toofew;
5081 case 2: { pushSTACK(unbound); }
5082 case 3: { pushSTACK(unbound); }
5083 case 4: { pushSTACK(unbound); }
5084 case 5: goto apply_subr_norest;
5085 default: goto error_toomany;
5086 }
5087 case (uintW)subr_argtype_0_4: /* SUBR with 4 optional arguments */
5088 switch (args_on_stack) {
5089 case 0: { pushSTACK(unbound); }
5090 case 1: { pushSTACK(unbound); }
5091 case 2: { pushSTACK(unbound); }
5092 case 3: { pushSTACK(unbound); }
5093 case 4: goto apply_subr_norest;
5094 default: goto error_toomany;
5095 }
5096 case (uintW)subr_argtype_0_5: /* SUBR with 5 optional arguments */
5097 switch (args_on_stack) {
5098 case 0: { pushSTACK(unbound); }
5099 case 1: { pushSTACK(unbound); }
5100 case 2: { pushSTACK(unbound); }
5101 case 3: { pushSTACK(unbound); }
5102 case 4: { pushSTACK(unbound); }
5103 case 5: goto apply_subr_norest;
5104 default: goto error_toomany;
5105 }
5106 case (uintW)subr_argtype_0_0_rest: /* SUBR with &rest arguments */
5107 goto apply_subr_rest_ok;
5108 case (uintW)subr_argtype_1_0_rest: /* SUBR with 1 required and &rest */
5109 if (args_on_stack==0) goto error_toofew;
5110 args_on_stack -= 1;
5111 goto apply_subr_rest_ok;
5112 case (uintW)subr_argtype_2_0_rest: /* SUBR with 2 requireden and &rest */
5113 if (args_on_stack<2) goto error_toofew;
5114 args_on_stack -= 2;
5115 goto apply_subr_rest_ok;
5116 case (uintW)subr_argtype_3_0_rest: /* SUBR with 3 requireden and &rest */
5117 if (args_on_stack<3) goto error_toofew;
5118 args_on_stack -= 3;
5119 goto apply_subr_rest_ok;
5120 case (uintW)subr_argtype_0_0_key: /* SUBR with &key */
5121 if (args_on_stack==0) goto unbound_optional_key_0;
5122 else goto apply_subr_key;
5123 case (uintW)subr_argtype_1_0_key: /* SUBR with 1 required and &key */
5124 if (args_on_stack==1) goto unbound_optional_key_0;
5125 else if (args_on_stack<1) goto error_toofew;
5126 else { args_on_stack -= 1; goto apply_subr_key; }
5127 case (uintW)subr_argtype_2_0_key: /* SUBR with 2 required and &key */
5128 if (args_on_stack==2) goto unbound_optional_key_0;
5129 else if (args_on_stack<2) goto error_toofew;
5130 else { args_on_stack -= 2; goto apply_subr_key; }
5131 case (uintW)subr_argtype_3_0_key: /* SUBR with 3 required and &key */
5132 if (args_on_stack==3) goto unbound_optional_key_0;
5133 else if (args_on_stack<3) goto error_toofew;
5134 else { args_on_stack -= 3; goto apply_subr_key; }
5135 case (uintW)subr_argtype_4_0_key: /* SUBR with 4 required and &key */
5136 if (args_on_stack==4) goto unbound_optional_key_0;
5137 else if (args_on_stack<4) goto error_toofew;
5138 else { args_on_stack -= 4; goto apply_subr_key; }
5139 case (uintW)subr_argtype_0_1_key: /* SUBR with 1 optional and &key */
5140 switch (args_on_stack) {
5141 case 0: goto unbound_optional_key_1;
5142 case 1: goto unbound_optional_key_0;
5143 default: args_on_stack -= 1; goto apply_subr_key;
5144 }
5145 case (uintW)subr_argtype_1_1_key:
5146 /* SUBR with 1 required argument, 1 optional argument and &key */
5147 switch (args_on_stack) {
5148 case 0: goto error_toofew;
5149 case 1: goto unbound_optional_key_1;
5150 case 2: goto unbound_optional_key_0;
5151 default: args_on_stack -= 2; goto apply_subr_key;
5152 }
5153 case (uintW)subr_argtype_1_2_key:
5154 /* SUBR with 1 required argument, 2 optional arguments and &key */
5155 switch (args_on_stack) {
5156 case 0: goto error_toofew;
5157 case 1: goto unbound_optional_key_2;
5158 case 2: goto unbound_optional_key_1;
5159 case 3: goto unbound_optional_key_0;
5160 default: args_on_stack -= 3; goto apply_subr_key;
5161 }
5162 unbound_optional_key_2: /* Still 2 optional Arguments, but args_on_stack=0 */
5163 { pushSTACK(unbound); }
5164 unbound_optional_key_1: /* Still 1 optional Argument, but args_on_stack=0 */
5165 { pushSTACK(unbound); }
5166 unbound_optional_key_0: /* Before the Keywords is args_on_stack=0 */
5167 {
5168 var uintC count;
5169 dotimesC(count,TheSubr(fun)->key_count, { pushSTACK(unbound); } );
5170 }
5171 goto apply_subr_norest;
5172 default: NOTREACHED;
5173 #undef OPT_ARG
5174 #undef REQ_ARG
5175 }
5176 /* Now the general Version: */
5177 {
5178 var uintC key_count;
5179 {
5180 var uintC req_count = TheSubr(fun)->req_count;
5181 var uintC opt_count = TheSubr(fun)->opt_count;
5182 key_count = TheSubr(fun)->key_count;
5183 if (args_on_stack < req_count)
5184 /* fewer Arguments than demanded */
5185 goto error_toofew;
5186 args_on_stack -= req_count; /* remaining number */
5187 if (args_on_stack <= opt_count) {
5188 /* Arguments in Stack don't last for the optional ones */
5189 opt_count = opt_count - args_on_stack; /* as many as these must go on STACK */
5190 if (opt_count + key_count > 0) {
5191 /* reserve space on STACK: */
5192 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)(opt_count + key_count));
5193 /* All further count optional parameters receive the "value"
5194 #<UNBOUND>, including the Keyword-parameters: */
5195 var uintC count;
5196 dotimespC(count,opt_count + key_count, { pushSTACK(unbound); } );
5197 }
5198 if (TheSubr(fun)->rest_flag == subr_rest) { /* &REST-Flag? */
5199 /* yes -> 0 additional Arguments: */
5200 argcount = 0; rest_args_pointer = args_end_pointer;
5201 goto apply_subr_rest;
5202 } else {
5203 /* no -> nothing to do */
5204 goto apply_subr_norest;
5205 }
5206 }
5207 args_on_stack -= opt_count; /* remaining number (> 0) */
5208 if (TheSubr(fun)->key_flag == subr_nokey) {
5209 /* SUBR without KEY */
5210 if (TheSubr(fun)->rest_flag == subr_norest)
5211 /* SUBR without REST or KEY */
5212 goto error_toomany; /* still Arguments! */
5213 else
5214 /* SUBR with only REST, without KEY */
5215 goto apply_subr_rest_ok;
5216 } else
5217 /* SUBR with Keywords. */
5218 goto apply_subr_key_;
5219 }
5220 apply_subr_key:
5221 key_count = TheSubr(fun)->key_count;
5222 apply_subr_key_:
5223 /* shift down remaining arguments in STACK and thus
5224 create room for the Keyword-parameters: */
5225 argcount = args_on_stack; /* (> 0) */
5226 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)key_count);
5227 {
5228 var gcv_object_t* new_args_end_pointer = args_end_pointer STACKop -(uintP)key_count;
5229 var gcv_object_t* ptr1 = args_end_pointer;
5230 var gcv_object_t* ptr2 = new_args_end_pointer;
5231 var uintC count;
5232 dotimespC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
5233 key_args_pointer = ptr1;
5234 rest_args_pointer = ptr2;
5235 dotimesC(count,key_count, { NEXT(ptr1) = unbound; } );
5236 set_args_end_pointer(new_args_end_pointer);
5237 }
5238 /* assign Keywords and poss. discard remaining Arguments: */
5239 match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
5240 if (TheSubr(fun)->rest_flag != subr_norest)
5241 /* SUBR with &REST-Flag: */
5242 goto apply_subr_rest;
5243 else
5244 /* SUBR without &REST-Flag: */
5245 goto apply_subr_norest;
5246 }
5247 apply_subr_rest_ok:
5248 argcount = args_on_stack;
5249 rest_args_pointer = args_end_pointer STACKop argcount;
5250 apply_subr_rest:
5251 with_saved_back_trace_subr(fun,STACK,
5252 TheSubr(fun)->req_count + TheSubr(fun)->opt_count + argcount,
5253 (*(subr_rest_function_t*)(TheSubr(fun)->function))(argcount,rest_args_pointer); );
5254 goto done;
5255 apply_subr_norest:
5256 with_saved_back_trace_subr(fun,STACK,args_on_stack,
5257 (*(subr_norest_function_t*)(TheSubr(fun)->function))(); );
5258 done:
5259 CHECK_STACK_S(args_end_pointer,fun);
5260 return; /* finished */
5261 /* Gathered error-messages: */
5262 error_count:
5263 if (args_on_stack < TheSubr(fun)->req_count)
5264 goto error_toofew; /* too few Arguments */
5265 else
5266 goto error_toomany; /* too many Arguments */
5267 error_toofew: { error_subr_toofew(fun,NIL); }
5268 error_toomany: { error_subr_toomany(fun); }
5269 }
5270
5271 /* In FUNCALL: Applies a Closure to Arguments, cleans up STACK
5272 and returns the values.
5273 funcall_closure(fun,args_on_stack);
5274 > fun: function, a Closure
5275 > Arguments: args_on_stack arguments on STACK
5276 < STACK: cleaned up (i.e. STACK is increased by args_on_stack)
5277 < mv_count/mv_space: values
5278 changes STACK, can trigger GC */
funcall_closure(object closure,uintC args_on_stack)5279 local maygc Values funcall_closure (object closure, uintC args_on_stack)
5280 {
5281 TRACE_CALL(closure,'F','C');
5282 if (simple_bit_vector_p(Atype_8Bit,TheClosure(closure)->clos_codevec)) {
5283 /* closure is a compiled Closure */
5284 #if STACKCHECKC
5285 var gcv_object_t* args_pointer = args_end_pointer STACKop args_on_stack; /* Pointer to the Arguments */
5286 #endif
5287 var object codevec = TheCclosure(closure)->clos_codevec; /* Code-Vector */
5288 var gcv_object_t* key_args_pointer; /* Pointer to the &key */
5289 var gcv_object_t* rest_args_pointer; /* Pointer to the remaining Arguments */
5290 var uintL argcount; /* number of remaining Arguments */
5291 check_SP(); check_STACK();
5292 /* store arguments in STACK:
5293 First a Dispatch for the most important cases: */
5294 switch (TheCodevec(codevec)->ccv_signature) {
5295 case (uintB)cclos_argtype_0_0: /* no Arguments */
5296 if (!(args_on_stack==0)) goto error_toomany;
5297 goto apply_cclosure_nokey;
5298 case (uintB)cclos_argtype_1_0: /* 1 required argument */
5299 if (!(args_on_stack==1)) goto error_count;
5300 goto apply_cclosure_nokey;
5301 case (uintB)cclos_argtype_2_0: /* 2 required arguments */
5302 if (!(args_on_stack==2)) goto error_count;
5303 goto apply_cclosure_nokey;
5304 case (uintB)cclos_argtype_3_0: /* 3 required arguments */
5305 if (!(args_on_stack==3)) goto error_count;
5306 goto apply_cclosure_nokey;
5307 case (uintB)cclos_argtype_4_0: /* 4 required arguments */
5308 if (!(args_on_stack==4)) goto error_count;
5309 goto apply_cclosure_nokey;
5310 case (uintB)cclos_argtype_5_0: /* 5 required arguments */
5311 if (!(args_on_stack==5)) goto error_count;
5312 goto apply_cclosure_nokey;
5313 case (uintB)cclos_argtype_0_1: /* 1 optional argument */
5314 if (args_on_stack==1) goto apply_cclosure_nokey;
5315 else if (args_on_stack>1) goto error_toomany;
5316 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
5317 case (uintB)cclos_argtype_1_1: /* 1 required and 1 optional */
5318 if (args_on_stack==2) goto apply_cclosure_nokey;
5319 else if (args_on_stack>2) goto error_toomany;
5320 else if (args_on_stack==0) goto error_toofew;
5321 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
5322 case (uintB)cclos_argtype_2_1: /* 2 required and 1 optional */
5323 if (args_on_stack==3) goto apply_cclosure_nokey;
5324 else if (args_on_stack>3) goto error_toomany;
5325 else if (args_on_stack<2) goto error_toofew;
5326 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
5327 case (uintB)cclos_argtype_3_1: /* 3 required and 1 optional */
5328 if (args_on_stack==4) goto apply_cclosure_nokey;
5329 else if (args_on_stack>4) goto error_toomany;
5330 else if (args_on_stack<3) goto error_toofew;
5331 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
5332 case (uintB)cclos_argtype_4_1: /* 4 required and 1 optional */
5333 if (args_on_stack==5) goto apply_cclosure_nokey;
5334 else if (args_on_stack>5) goto error_toomany;
5335 else if (args_on_stack<4) goto error_toofew;
5336 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
5337 case (uintB)cclos_argtype_0_2: /* 2 optional arguments */
5338 switch (args_on_stack) {
5339 case 0: { pushSTACK(unbound); }
5340 case 1: { pushSTACK(unbound); }
5341 case 2: goto apply_cclosure_nokey;
5342 default: goto error_toomany;
5343 }
5344 case (uintB)cclos_argtype_1_2: /* 1 required and 2 optional */
5345 switch (args_on_stack) {
5346 case 0: goto error_toofew;
5347 case 1: { pushSTACK(unbound); }
5348 case 2: { pushSTACK(unbound); }
5349 case 3: goto apply_cclosure_nokey;
5350 default: goto error_toomany;
5351 }
5352 case (uintB)cclos_argtype_2_2: /* 2 required and 2 optional */
5353 switch (args_on_stack) {
5354 case 0: case 1: goto error_toofew;
5355 case 2: { pushSTACK(unbound); }
5356 case 3: { pushSTACK(unbound); }
5357 case 4: goto apply_cclosure_nokey;
5358 default: goto error_toomany;
5359 }
5360 case (uintB)cclos_argtype_3_2: /* 3 required and 2 optional */
5361 switch (args_on_stack) {
5362 case 0: case 1: case 2: goto error_toofew;
5363 case 3: { pushSTACK(unbound); }
5364 case 4: { pushSTACK(unbound); }
5365 case 5: goto apply_cclosure_nokey;
5366 default: goto error_toomany;
5367 }
5368 case (uintB)cclos_argtype_0_3: /* 3 optional arguments */
5369 switch (args_on_stack) {
5370 case 0: { pushSTACK(unbound); }
5371 case 1: { pushSTACK(unbound); }
5372 case 2: { pushSTACK(unbound); }
5373 case 3: goto apply_cclosure_nokey;
5374 default: goto error_toomany;
5375 }
5376 case (uintB)cclos_argtype_1_3: /* 1 required and 3 optional */
5377 switch (args_on_stack) {
5378 case 0: goto error_toofew;
5379 case 1: { pushSTACK(unbound); }
5380 case 2: { pushSTACK(unbound); }
5381 case 3: { pushSTACK(unbound); }
5382 case 4: goto apply_cclosure_nokey;
5383 default: goto error_toomany;
5384 }
5385 case (uintB)cclos_argtype_2_3: /* 2 required and 3 optional */
5386 switch (args_on_stack) {
5387 case 0: case 1: goto error_toofew;
5388 case 2: { pushSTACK(unbound); }
5389 case 3: { pushSTACK(unbound); }
5390 case 4: { pushSTACK(unbound); }
5391 case 5: goto apply_cclosure_nokey;
5392 default: goto error_toomany;
5393 }
5394 case (uintB)cclos_argtype_0_4: /* 4 optional arguments */
5395 switch (args_on_stack) {
5396 case 0: { pushSTACK(unbound); }
5397 case 1: { pushSTACK(unbound); }
5398 case 2: { pushSTACK(unbound); }
5399 case 3: { pushSTACK(unbound); }
5400 case 4: goto apply_cclosure_nokey;
5401 default: goto error_toomany;
5402 }
5403 case (uintB)cclos_argtype_1_4: /* 1 required and 4 optional */
5404 switch (args_on_stack) {
5405 case 0: goto error_toofew;
5406 case 1: { pushSTACK(unbound); }
5407 case 2: { pushSTACK(unbound); }
5408 case 3: { pushSTACK(unbound); }
5409 case 4: { pushSTACK(unbound); }
5410 case 5: goto apply_cclosure_nokey;
5411 default: goto error_toomany;
5412 }
5413 case (uintB)cclos_argtype_0_5: /* 5 optional arguments */
5414 switch (args_on_stack) {
5415 case 0: { pushSTACK(unbound); }
5416 case 1: { pushSTACK(unbound); }
5417 case 2: { pushSTACK(unbound); }
5418 case 3: { pushSTACK(unbound); }
5419 case 4: { pushSTACK(unbound); }
5420 case 5: goto apply_cclosure_nokey;
5421 default: goto error_toomany;
5422 }
5423 case (uintB)cclos_argtype_0_0_rest: /* no Arguments, &rest */
5424 goto apply_cclosure_rest_nokey;
5425 case (uintB)cclos_argtype_1_0_rest: /* 1 required + &rest */
5426 if (args_on_stack==0) goto error_toofew;
5427 args_on_stack -= 1;
5428 goto apply_cclosure_rest_nokey;
5429 case (uintB)cclos_argtype_2_0_rest: /* 2 required + &rest */
5430 if (args_on_stack<2) goto error_toofew;
5431 args_on_stack -= 2;
5432 goto apply_cclosure_rest_nokey;
5433 case (uintB)cclos_argtype_3_0_rest: /* 3 required + &rest */
5434 if (args_on_stack<3) goto error_toofew;
5435 args_on_stack -= 3;
5436 goto apply_cclosure_rest_nokey;
5437 case (uintB)cclos_argtype_4_0_rest: /* 4 required + &rest */
5438 if (args_on_stack<4) goto error_toofew;
5439 args_on_stack -= 4;
5440 goto apply_cclosure_rest_nokey;
5441 case (uintB)cclos_argtype_0_0_key: /* only &key */
5442 if (args_on_stack==0) goto unbound_optional_key_0;
5443 else goto apply_cclosure_key_withargs;
5444 case (uintB)cclos_argtype_1_0_key: /* 1 required argument, &key */
5445 if (args_on_stack==1) goto unbound_optional_key_0;
5446 else if (args_on_stack<1) goto error_toofew;
5447 else { args_on_stack -= 1; goto apply_cclosure_key_withargs; }
5448 case (uintB)cclos_argtype_2_0_key: /* 2 required arguments, &key */
5449 if (args_on_stack==2) goto unbound_optional_key_0;
5450 else if (args_on_stack<2) goto error_toofew;
5451 else { args_on_stack -= 2; goto apply_cclosure_key_withargs; }
5452 case (uintB)cclos_argtype_3_0_key: /* 3 required arguments, &key */
5453 if (args_on_stack==3) goto unbound_optional_key_0;
5454 else if (args_on_stack<3) goto error_toofew;
5455 else { args_on_stack -= 3; goto apply_cclosure_key_withargs; }
5456 case (uintB)cclos_argtype_4_0_key: /* 4 required arguments, &key */
5457 if (args_on_stack==4) goto unbound_optional_key_0;
5458 else if (args_on_stack<4) goto error_toofew;
5459 else { args_on_stack -= 4; goto apply_cclosure_key_withargs; }
5460 case (uintB)cclos_argtype_0_1_key: /* 1 optional argument, &key */
5461 switch (args_on_stack) {
5462 case 0: goto unbound_optional_key_1;
5463 case 1: goto unbound_optional_key_0;
5464 default: args_on_stack -= 1; goto apply_cclosure_key_withargs;
5465 }
5466 case (uintB)cclos_argtype_1_1_key:
5467 /* 1 required argument and 1 optional argument, &key */
5468 switch (args_on_stack) {
5469 case 0: goto error_toofew;
5470 case 1: goto unbound_optional_key_1;
5471 case 2: goto unbound_optional_key_0;
5472 default: args_on_stack -= 2; goto apply_cclosure_key_withargs;
5473 }
5474 case (uintB)cclos_argtype_2_1_key:
5475 /* 2 required arguments and 1 optional argument, &key */
5476 switch (args_on_stack) {
5477 case 0: case 1: goto error_toofew;
5478 case 2: goto unbound_optional_key_1;
5479 case 3: goto unbound_optional_key_0;
5480 default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
5481 }
5482 case (uintB)cclos_argtype_3_1_key:
5483 /* 3 required arguments and 1 optional argument, &key */
5484 switch (args_on_stack) {
5485 case 0: case 1: case 2: goto error_toofew;
5486 case 3: goto unbound_optional_key_1;
5487 case 4: goto unbound_optional_key_0;
5488 default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
5489 }
5490 case (uintB)cclos_argtype_0_2_key: /* 2 optional arguments, &key */
5491 switch (args_on_stack) {
5492 case 0: goto unbound_optional_key_2;
5493 case 1: goto unbound_optional_key_1;
5494 case 2: goto unbound_optional_key_0;
5495 default: args_on_stack -= 2; goto apply_cclosure_key_withargs;
5496 }
5497 case (uintB)cclos_argtype_1_2_key:
5498 /* 1 required argument and 2 optional arguments, &key */
5499 switch (args_on_stack) {
5500 case 0: goto error_toofew;
5501 case 1: goto unbound_optional_key_2;
5502 case 2: goto unbound_optional_key_1;
5503 case 3: goto unbound_optional_key_0;
5504 default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
5505 }
5506 case (uintB)cclos_argtype_2_2_key:
5507 /* 2 required arguments and 2 optional arguments, &key */
5508 switch (args_on_stack) {
5509 case 0: case 1: goto error_toofew;
5510 case 2: goto unbound_optional_key_2;
5511 case 3: goto unbound_optional_key_1;
5512 case 4: goto unbound_optional_key_0;
5513 default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
5514 }
5515 case (uintB)cclos_argtype_0_3_key: /* 3 optional arguments, &key */
5516 switch (args_on_stack) {
5517 case 0: goto unbound_optional_key_3;
5518 case 1: goto unbound_optional_key_2;
5519 case 2: goto unbound_optional_key_1;
5520 case 3: goto unbound_optional_key_0;
5521 default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
5522 }
5523 case (uintB)cclos_argtype_1_3_key:
5524 /* 1 required argument and 3 optional arguments, &key */
5525 switch (args_on_stack) {
5526 case 0: goto error_toofew;
5527 case 1: goto unbound_optional_key_3;
5528 case 2: goto unbound_optional_key_2;
5529 case 3: goto unbound_optional_key_1;
5530 case 4: goto unbound_optional_key_0;
5531 default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
5532 }
5533 case (uintB)cclos_argtype_0_4_key: /* 4 optional arguments, &key */
5534 switch (args_on_stack) {
5535 case 0: goto unbound_optional_key_4;
5536 case 1: goto unbound_optional_key_3;
5537 case 2: goto unbound_optional_key_2;
5538 case 3: goto unbound_optional_key_1;
5539 case 4: goto unbound_optional_key_0;
5540 default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
5541 }
5542 unbound_optional_key_4: /* Still 4 optionals, but args_on_stack=0 */
5543 { pushSTACK(unbound); }
5544 unbound_optional_key_3: /* Still 3 optionals, but args_on_stack=0 */
5545 { pushSTACK(unbound); }
5546 unbound_optional_key_2: /* Still 2 optionals, but args_on_stack=0 */
5547 { pushSTACK(unbound); }
5548 unbound_optional_key_1: /* Still 1 optional, but args_on_stack=0 */
5549 { pushSTACK(unbound); }
5550 unbound_optional_key_0: /* Before the Keywords is args_on_stack=0 */
5551 goto apply_cclosure_key_noargs;
5552 case (uintB)cclos_argtype_default:
5553 /* General Version */
5554 break;
5555 default: NOTREACHED;
5556 }
5557 /* Now the general version: */
5558 {
5559 var uintB flags;
5560 {
5561 var uintC req_count = TheCodevec(codevec)->ccv_numreq; /* number of required Parameters */
5562 var uintC opt_count = TheCodevec(codevec)->ccv_numopt; /* number of optional Parameters */
5563 flags = TheCodevec(codevec)->ccv_flags; /* Flags */
5564 if (args_on_stack < req_count)
5565 /* fewer Arguments than demanded */
5566 goto error_toofew;
5567 args_on_stack -= req_count; /* remaining number */
5568 if (args_on_stack <= opt_count) {
5569 /* Arguments in Stack don't last for the optional ones */
5570 opt_count = opt_count - args_on_stack; /* as many as these must go on STACK */
5571 if (opt_count > 0) {
5572 /* reserve space on STACK: */
5573 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)opt_count);
5574 /* All further count optional parameters receive the "value"
5575 #<UNBOUND>, the &REST-parameter receives NIL,
5576 the Keyword-parameters receive the value #<UNBOUND> : */
5577 var uintC count;
5578 dotimespC(count,opt_count, { pushSTACK(unbound); } );
5579 }
5580 if (flags & bit(0)) /* &REST-Flag? */
5581 pushSTACK(NIL); /* yes -> initialize with NIL */
5582 if (flags & bit(7)) /* &KEY-Flag? */
5583 goto apply_cclosure_key_noargs;
5584 else
5585 goto apply_cclosure_nokey;
5586 }
5587 args_on_stack -= opt_count; /* remaining number */
5588 if (flags & bit(7)) /* Key-Flag? */
5589 goto apply_cclosure_key_withargs_;
5590 else if (flags & bit(0))
5591 goto apply_cclosure_rest_nokey;
5592 else {
5593 /* Closure without REST or KEY */
5594 if (args_on_stack>0) /* still arguments? */
5595 goto error_toomany;
5596 goto apply_cclosure_nokey;
5597 }
5598 }
5599 apply_cclosure_key_noargs:
5600 {
5601 var uintC key_count = TheCodevec(codevec)->ccv_numkey; /* number of Keyword-Parameters */
5602 if (key_count > 0) {
5603 get_space_on_STACK(sizeof(gcv_object_t) * (uintL)key_count);
5604 var uintC count;
5605 dotimespC(count,key_count, { pushSTACK(unbound); } ); /* initialize with #<UNBOUND> */
5606 }
5607 goto apply_cclosure_key;
5608 }
5609 apply_cclosure_key_withargs:
5610 flags = TheCodevec(codevec)->ccv_flags; /* initialize Flags! */
5611 apply_cclosure_key_withargs_:
5612 /* Closure with Keywords */
5613 {
5614 var uintC key_count = TheCodevec(codevec)->ccv_numkey; /* number of Keyword-Parameters */
5615 /* shift down remaining arguments in STACK and thus
5616 create room for the Keyword-parameters
5617 (and poss. Rest-parameters): */
5618 var uintL shift = key_count;
5619 if (flags & bit(0))
5620 shift++; /* poss. 1 more for Rest-Parameter */
5621 argcount = args_on_stack;
5622 get_space_on_STACK(sizeof(gcv_object_t) * shift);
5623 var gcv_object_t* new_args_end_pointer = args_end_pointer STACKop -(uintP)shift;
5624 var gcv_object_t* ptr1 = args_end_pointer;
5625 var gcv_object_t* ptr2 = new_args_end_pointer;
5626 var uintC count;
5627 dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
5628 if (flags & bit(0))
5629 NEXT(ptr1) = unbound; /* Rest-Parameter */
5630 key_args_pointer = ptr1;
5631 rest_args_pointer = ptr2;
5632 dotimesC(count,key_count, { NEXT(ptr1) = unbound; } );
5633 set_args_end_pointer(new_args_end_pointer);
5634 }
5635 /* assign Keywords, build Rest-Parameter
5636 and poss. discard remaining arguments: */
5637 closure = match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer);
5638 codevec = TheCclosure(closure)->clos_codevec;
5639 apply_cclosure_key:
5640 interpret_bytecode(closure,codevec,CCV_START_KEY); /* process Bytecode starting at Byte 12 */
5641 goto done;
5642 }
5643 apply_cclosure_rest_nokey:
5644 /* Closure with only REST, without KEY:
5645 still must cons args_on_stack arguments from stack Stack: */
5646 { pushSTACK(NIL); }
5647 if (args_on_stack > 0) {
5648 pushSTACK(closure); /* Closure must be saved */
5649 dotimesC(args_on_stack,args_on_stack, {
5650 var object new_cons = allocate_cons();
5651 Cdr(new_cons) = STACK_1;
5652 Car(new_cons) = STACK_2; /* cons next argument to it */
5653 STACK_2 = new_cons;
5654 STACK_1 = STACK_0; skipSTACK(1);
5655 });
5656 closure = popSTACK(); codevec = TheCclosure(closure)->clos_codevec;
5657 }
5658 apply_cclosure_nokey: /* jump to Closure without &KEY: */
5659 interpret_bytecode(closure,codevec,CCV_START_NONKEY); /* process Bytecode starting at Byte 8 */
5660 done:
5661 CHECK_STACK_C(args_end_pointer,closure);
5662 return; /* finished */
5663 error_count: /* collected error-messages: */
5664 if (args_on_stack < TheCodevec(codevec)->ccv_numreq)
5665 goto error_toofew; /* too few arguments */
5666 else
5667 goto error_toomany; /* too many arguments */
5668 error_toofew: { error_closure_toofew(closure,NIL); }
5669 error_toomany: { error_closure_toomany(closure); }
5670 } else {
5671 /* closure is an interpreted Closure */
5672 var gcv_object_t* args_pointer = args_end_pointer STACKop args_on_stack;
5673 with_saved_back_trace_iclosure(closure,args_pointer,args_on_stack,
5674 funcall_iclosure(closure,args_pointer,args_on_stack); );
5675 }
5676 }
5677
5678
5679 /* ---------------------- BYTECODE-INTERPRETER ---------------------- */
5680
5681 /* Interpretes the bytecode of a compiled Closure.
5682 interpret_bytecode_(closure,codeptr,byteptr);
5683 > closure: compiled closure
5684 > codeptr: its Codevector, a Simple-Bit-Vector, pointable
5685 > byteptr: Start-Bytecodepointer
5686 < mv_count/mv_space: values
5687 changes STACK, can trigger GC
5688 Syntax of local labels in GNU-C assembler-statements: */
5689 #if (defined(GNU) || defined(INTEL)) && !defined(NO_ASM)
5690 /* LD(x) defines Label with number x
5691 LR(x,f) references label with number x forwards
5692 LR(x,b) references label with number x backwards
5693 The scope of the labels is only one assembler-statement. */
5694 #if defined(I80386)
5695 #ifdef ASM_UNDERSCORE
5696 #define LD(nr) "LASM%=X" STRING(nr)
5697 #define LR(nr,fb) "LASM%=X" STRING(nr)
5698 #else
5699 #define LD(nr) ".LASM%=X" STRING(nr)
5700 #define LR(nr,fb) ".LASM%=X" STRING(nr)
5701 #endif
5702 #elif defined(ARM)
5703 #define LD(nr) "LASM%=X" STRING(nr)
5704 #define LR(nr,fb) "LASM%=X" STRING(nr)
5705 #else
5706 #define LD(nr) STRING(nr)
5707 #define LR(nr,fb) STRING(nr) STRING(fb)
5708 #endif
5709 #endif
5710 /* Persuade GNU-C, to keep closure and byteptr in registers: */
5711 #if defined(GNU) && !defined(NO_ASM)
5712 #ifdef M68K
5713 #define closure_register "a2"
5714 #define byteptr_register "a3"
5715 #endif
5716 #ifdef SPARC
5717 #define closure_register "%l0"
5718 #define byteptr_register "%l1"
5719 #endif
5720 #ifdef I80386
5721 #if (__GNUC__ >= 2) /* The register-names have changed */
5722 #define byteptr_register "%edi"
5723 #else
5724 #define byteptr_register "di"
5725 #endif
5726 #endif
5727 #ifdef ARM
5728 /* Code is better without defining registers for closure and byteptr,
5729 says Peter Burwood.
5730 not define closure_register "%r6"
5731 not define byteptr_register "%r7"
5732 We have assembler macros below, but if they are used with gcc-2.7.2.1,
5733 (setf cdddr) is miscompiled. So here we temporarily disable them. */
5734 #ifndef NO_ASM
5735 #define NO_ASM
5736 #endif
5737 #endif
5738 #ifdef DECALPHA
5739 #define byteptr_register "$14"
5740 #endif
5741 #if defined(WIDE) && !defined(WIDE_HARD)
5742 /* An `object' does not fit into a single register, GCC is overcharged. */
5743 #undef closure_register
5744 #endif
5745 #endif
5746 #ifndef closure_register
5747 #define closure_in closure
5748 #endif
5749 #ifndef byteptr_register
5750 #define byteptr_in byteptr
5751 #endif
5752 #ifdef DEBUG_BYTECODE
5753 #define GOTO_ERROR(label) \
5754 do { \
5755 fprintf(stderr,"\n[%s:%d] ",__FILE__,__LINE__); \
5756 goto label; \
5757 } while(0)
5758 #define DEBUG_CHECK_BYTEPTR(nb) do { \
5759 var const uintL b = nb - codeptr->data; \
5760 if ((b < byteptr_min) || (b > byteptr_max)) { \
5761 var uintL bp = byteptr - codeptr->data; \
5762 fprintf(stderr,"\n[%s:%d] ",__FILE__,__LINE__); \
5763 byteptr_bad_jump = b - bp; \
5764 /*nobject_out(stderr,closure);*/ \
5765 /*fprintf(stderr," jump by %d takes %d outside [%d;%d]",byteptr_bad_jump,bp,byteptr_min,byteptr_max);*/ \
5766 goto error_byteptr; \
5767 }} while(0)
5768 #else
5769 #define GOTO_ERROR(label) goto label
5770 #define DEBUG_CHECK_BYTEPTR(b) do{}while(0)
5771 #endif
interpret_bytecode_(object closure_in,Sbvector codeptr,const uintB * byteptr_in)5772 local /*maygc*/ Values interpret_bytecode_ (object closure_in, Sbvector codeptr,
5773 const uintB* byteptr_in)
5774 {
5775 GCTRIGGER_IF(true, {
5776 if (*byteptr_in == cod_handler_begin_push)
5777 GCTRIGGER3(closure_in,handler_args.condition,handler_args.spdepth);
5778 else
5779 GCTRIGGER1(closure_in);
5780 });
5781 #if STACKCHECKC || defined(DEBUG_BYTECODE)
5782 var const uintL byteptr_min = ((Codevec)codeptr)->ccv_flags & bit(7)
5783 ? CCV_START_KEY : CCV_START_NONKEY;
5784 #endif
5785 #ifdef DEBUG_BYTECODE
5786 var const uintL byteptr_max = sbvector_length(codeptr)-1;
5787 var sintL byteptr_bad_jump;
5788 #endif
5789 /* situate argument closure in register: */
5790 #ifdef closure_register
5791 var object closure __asm__(closure_register);
5792 closure = closure_in;
5793 #endif
5794 /* situate argument byteptr in register: */
5795 #ifdef byteptr_register
5796 var register const uintB* byteptr __asm__(byteptr_register);
5797 byteptr = byteptr_in;
5798 #endif
5799 TRACE_CALL(closure,'B','C');
5800 /* situate closure in STACK, below the arguments: */
5801 var gcv_object_t* closureptr = (pushSTACK(closure), &STACK_0);
5802 #ifndef FAST_SP
5803 /* If there is no fast SP-Access, one has to introduce
5804 an extra pointer: */
5805 var uintL private_SP_length =
5806 (uintL)(((Codevec)codeptr)->ccv_spdepth_1)
5807 + jmpbufsize * (uintL)(((Codevec)codeptr)->ccv_spdepth_jmpbufsize);
5808 var DYNAMIC_ARRAY(private_SP_space,SPint,private_SP_length);
5809 var SPint* private_SP = &private_SP_space[private_SP_length];
5810 #undef SP_
5811 #undef _SP_
5812 #undef skipSP
5813 #undef pushSP
5814 #undef popSP
5815 #define SP_(n) (private_SP[n])
5816 #define _SP_(n) &SP_(n)
5817 #define skipSP(n) (private_SP += (n))
5818 #define pushSP(item) (*--private_SP = (item))
5819 #define popSP(item_assignment) (item_assignment *private_SP++)
5820 #endif
5821 /* var JMPBUF_on_SP(name); allocates a sp_jmp_buf in SP.
5822 FREE_JMPBUF_on_SP(); deallocates it.
5823 finish_entry_frame_1(frametype,returner,reentry_statement); is like
5824 finish_entry_frame(frametype,returner,,reentry_statement); but
5825 also private_SP is saved. */
5826 #ifndef FAST_SP
5827 #define JMPBUF_on_SP(name) \
5828 sp_jmp_buf* name = (sp_jmp_buf*)(private_SP -= jmpbufsize);
5829 #define FREE_JMPBUF_on_SP() \
5830 private_SP += jmpbufsize;
5831 #define finish_entry_frame_1(frametype,returner,reentry_statement) \
5832 finish_entry_frame(frametype,*returner, /* On entry: returner = private_SP */ \
5833 returner = (sp_jmp_buf*) , /* returner is set again on return */ \
5834 { private_SP = (SPint*)returner; reentry_statement }) /* and private_SP is reconstructed */
5835 #else
5836 #ifdef SP_DOWN
5837 #define JMPBUF_on_SP(name) \
5838 sp_jmp_buf* name; \
5839 {var SPint* sp = (SPint*)SP(); \
5840 sp -= jmpbufsize; \
5841 setSP(sp); \
5842 name = (sp_jmp_buf*)&sp[SPoffset];}
5843 #endif
5844 #ifdef SP_UP
5845 #define JMPBUF_on_SP(name) \
5846 sp_jmp_buf* name; \
5847 {var SPint* sp = (SPint*)SP(); \
5848 name = (sp_jmp_buf*)&sp[SPoffset+1]; \
5849 sp += jmpbufsize; \
5850 setSP(sp);}
5851 #endif
5852 #define FREE_JMPBUF_on_SP() \
5853 skipSP(jmpbufsize);
5854 #define finish_entry_frame_1(frametype,returner,reentry_statement) \
5855 finish_entry_frame(frametype,*returner,,reentry_statement)
5856 #endif
5857 #ifdef FAST_DISPATCH
5858 static void* const cod_labels[] = {
5859 #define BYTECODE(code) &&code,
5860 #include "bytecode.c"
5861 #undef BYTECODE
5862 };
5863 #endif
5864 /* next Byte to be interpreted
5865 > mv_count/mv_space: current values
5866 > closureptr: pointer to the compiled closure on Stack
5867 > closure: compiled closure
5868 > codeptr: its codevector, a Simple-Bit-Vektor, pointable
5869 (no LISP-object, but nevertheless endangered by GC!)
5870 > byteptr: pointer to the next byte in code
5871 (no LISP-object, but nevertheless endangered by GC!) */
5872 next_byte:
5873 /* definition by cases, according to byte to be interpreted byte */
5874 #ifndef FAST_DISPATCH
5875 switch (*byteptr++)
5876 #define CASE case (uintB)
5877 #else /* FAST_DISPATCH */
5878 /* This is faster by about 2%, because the index-check is dropped. */
5879 goto *cod_labels[*byteptr++];
5880 #define CASE
5881 #ifdef FAST_DISPATCH_THREADED
5882 /* The jump-statement goto next_byte; can be omitted: */
5883 #define next_byte *cod_labels[*byteptr++]
5884 #endif
5885 #endif
5886 {
5887 /* Operand-Fetch:
5888 next Byte:
5889 Bit 7 = 0 --> Bits 6..0 are the Operand (7 Bits).
5890 Bit 7 = 1 --> Bits 6..0 and next Byte form the
5891 Operand (15 Bits).
5892 For jump-distances: Should this be =0, the next
5893 4 Bytes form the Operand
5894 (32 Bits).
5895
5896 Macro B_operand(where);
5897 moves the next Operand (a Byte as Unsigned Integer)
5898 to (uintL)where and advances bytecodepointer. */
5899 #define B_operand(where) \
5900 { where = *byteptr++; }
5901
5902 /* Macro U_operand(where);
5903 moves the next Operand (an Unsigned Integer)
5904 to (uintL)where or (uintC)where
5905 and advances the Bytecodepointer. */
5906 #define U_operand(where) \
5907 { where = *byteptr++; /* read first Byte */ \
5908 if ((uintB)where & bit(7)) /* Bit 7 set? */ \
5909 { where &= ~bit(7); /* yes -> delete */ \
5910 where = where << 8; \
5911 where |= *byteptr++; /* and read next Byte */ \
5912 } }
5913 #if defined(GNU) && defined(M68K) && !defined(NO_ASM)
5914 #undef U_operand
5915 #define U_operand(where) \
5916 __asm__( \
5917 "moveq #0,%0" "\n\t" \
5918 "moveb %1@+,%0" "\n\t" \
5919 "bpl 1f" "\n\t" \
5920 "addb %0,%0" "\n\t" \
5921 "lslw #7,%0" "\n\t" \
5922 "moveb %1@+,%0" "\n" \
5923 "1:" \
5924 : "=d" (where), "=a" (byteptr) : "1" (byteptr) )
5925 #endif
5926 #if defined(GNU) && defined(SPARC) && !(__GNUC__ == 5) && !defined(NO_ASM) /* this gets miscompiled by gcc-5.2 */
5927 #undef U_operand
5928 #define U_operand(where) \
5929 { var uintL dummy; \
5930 __asm__( \
5931 "ldub [%1],%0" "\n\t" \
5932 "andcc %0,0x80,%%g0" "\n\t" \
5933 "be 1f" "\n\t" \
5934 " add %1,1,%1" "\n\t" \
5935 "sll %0,25,%2" "\n\t" \
5936 "ldub [%1],%0" "\n\t" \
5937 "srl %2,17,%2" "\n\t" \
5938 "add %1,1,%1" "\n\t" \
5939 "or %0,%2,%0" "\n" \
5940 "1:" \
5941 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
5942 }
5943 #endif
5944 #if (defined(GNU) || defined(INTEL)) && defined(I80386) && !defined(NO_ASM)
5945 #if 0
5946 /* In earlier times, the GNU assembler assembled
5947 "testb %edx,%edx" as "testb %dl,%dl". This made possible to
5948 produce the output in any register. */
5949 #define OUT_EAX "=q"
5950 #define EAX "%0"
5951 #define AL "%0"
5952 #else
5953 /* Now "testb %edx,%edx" is invalid everywhere. The macros must
5954 put their result in %eax. */
5955 #define OUT_EAX "=a"
5956 #define EAX "%%eax"
5957 #define AL "%%al"
5958 #endif
5959 #undef U_operand
5960 #define U_operand(where) \
5961 __asm__( \
5962 "movzbl (%1),"EAX "\n\t" \
5963 "incl %1" "\n\t" \
5964 "testb "AL","AL "\n\t" \
5965 "jge "LR(1,f) "\n\t" \
5966 "andb $127,"AL "\n\t" \
5967 "sall $8,"EAX "\n\t" \
5968 "movb (%1),"AL "\n\t" \
5969 "incl %1" "\n" \
5970 LD(1)":" \
5971 : OUT_EAX (where), "=r" (byteptr) : "1" (byteptr) );
5972 /* Caution: 1. The Sun Assembler doesn't know this Syntax for local labels.
5973 That's why we generate our local labels ourselves.
5974 Caution: 2. ccr is changed. How is this to be declared?? */
5975 #endif
5976 #if defined(GNU) && defined(ARM) && !defined(NO_ASM)
5977 /* Macros written by Peter Burwood.
5978 Two versions. Which one to choose?
5979 instructions short case long case
5980 v1: 5 2 + 3 skipped 5
5981 v2: 5 3 + 2 skipped 4 + 1 skipped
5982 Let's choose the first one. 1-byte operands are most frequent. */
5983 #undef U_operand
5984 #define U_operand(where) /* (v1) */ \
5985 { var uintL dummy; \
5986 __asm__( \
5987 "ldrb %0,[%1],#1" "\n\t" \
5988 "tst %0,#0x80" "\n\t" \
5989 "bicne %0,%0,#0x80" "\n\t" \
5990 "ldrneb %2,[%1],#1" "\n\t" \
5991 "orrne %0,%2,%0,LSL#8" \
5992 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "cc" ); \
5993 }
5994 #if 0
5995 #undef U_operand
5996 #define U_operand(where) /* (v2) */ \
5997 { var uintL dummy; \
5998 __asm__( \
5999 "ldrb %0,[%1],#1" "\n\t" \
6000 "movs %0,%0,LSL#25" "\n\t" \
6001 "movcc %0,%0,LSR#25" "\n\t" \
6002 "ldrcsb %2,[%1],#1" "\n\t" \
6003 "orrcs %0,%2,%0,LSR#17" \
6004 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "cc" ); \
6005 }
6006 #endif
6007 #endif
6008
6009 /* Macro S_operand(where);
6010 moves the next Operand (a Signed Integer)
6011 to (uintL)where and advances the bytecodepointer. */
6012 #define S_operand(where) \
6013 { where = *byteptr++; /* read first byte */ \
6014 if ((uintB)where & bit(7)) \
6015 /* Bit 7 was set */ \
6016 { where = where << 8; \
6017 where |= *byteptr++; /* subjoin next Byte */ \
6018 /* Sign-Extend from 15 to 32 Bits: */ \
6019 where = (sintL)((sintL)(sintWL)((sintWL)where << (intWLsize-15)) >> (intWLsize-15)); \
6020 if (where == 0) \
6021 /* special case: 2-Byte-Operand = 0 -> 6-Byte-Operand */ \
6022 { where = (uintL)( ((uintWL)(byteptr[0]) << 8) \
6023 | (uintWL)(byteptr[1]) \
6024 ) << 16 \
6025 | (uintL)( ((uintWL)(byteptr[2]) << 8) \
6026 | (uintWL)(byteptr[3]) \
6027 ); \
6028 byteptr += 4; \
6029 } } \
6030 else \
6031 /* Bit 7 was deleted */ \
6032 { /* Sign-Extend from 7 to 32 Bits: */ \
6033 where = (sintL)((sintL)(sintBWL)((sintBWL)where << (intBWLsize-7)) >> (intBWLsize-7)); \
6034 } \
6035 }
6036 #if defined(GNU) && defined(M68K) && !defined(NO_ASM)
6037 #undef S_operand
6038 #define S_operand(where) \
6039 __asm__( \
6040 "moveb %1@+,%0" "\n\t" \
6041 "bpl 1f" "\n\t" \
6042 "lslw #8,%0" "\n\t" \
6043 "moveb %1@+,%0" "\n\t" \
6044 "addw %0,%0" "\n\t" \
6045 "asrw #1,%0" "\n\t" \
6046 "bne 2f" "\n\t" \
6047 "moveb %1@(2),%0" "\n\t" \
6048 "swap %0" "\n\t" \
6049 "moveb %1@+,%0" "\n\t" \
6050 "lsll #8,%0" "\n\t" \
6051 "moveb %1@,%0" "\n\t" \
6052 "swap %0" "\n\t" \
6053 "addql #2,%0" "\n\t" \
6054 "moveb %1@+,%0" "\n\t" \
6055 "jra 3f" "\n" \
6056 "1:" "\t" \
6057 "addb %0,%0" "\n\t" \
6058 "asrb #1,%0" "\n\t" \
6059 "extw %0" "\n" \
6060 "2:" "\t" \
6061 "extl %0" "\n" \
6062 "3:" \
6063 : "=d" (where), "=a" (byteptr) : "1" (byteptr) )
6064 #endif
6065 #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
6066 #undef S_operand
6067 #define S_operand(where) \
6068 { var uintL dummy; \
6069 __asm__( \
6070 "ldub [%1],%0" "\n\t" \
6071 "andcc %0,0x80,%%g0" "\n\t" \
6072 "be 2f" "\n\t" \
6073 " add %1,1,%1" "\n\t" \
6074 "sll %0,25,%2" "\n\t" \
6075 "ldub [%1],%0" "\n\t" \
6076 "sra %2,17,%2" "\n\t" \
6077 "orcc %2,%0,%0" "\n\t" \
6078 "bne 3f" "\n\t" \
6079 " add %1,1,%1" "\n\t" \
6080 "ldub [%1],%0" "\n\t" \
6081 "sll %0,24,%2" "\n\t" \
6082 "ldub [%1+1],%0" "\n\t" \
6083 "sll %0,16,%0" "\n\t" \
6084 "or %2,%0,%2" "\n\t" \
6085 "ldub [%1+2],%0" "\n\t" \
6086 "sll %0,8,%0" "\n\t" \
6087 "or %2,%0,%2" "\n\t" \
6088 "ldub [%1+3],%0" "\n\t" \
6089 "or %2,%0,%0" "\n\t" \
6090 "b 3f" "\n\t" \
6091 " add %1,4,%1" "\n" \
6092 "2:" "\t" \
6093 "sll %0,25,%0" "\n\t" \
6094 "sra %0,25,%0" "\n" \
6095 "3:" "\t" \
6096 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
6097 }
6098 #endif
6099 #if (defined(GNU) || defined(INTEL)) && defined(I80386) && !defined(NO_ASM)
6100 #undef S_operand
6101 #define S_operand(where) \
6102 __asm__( \
6103 "movzbl (%1),"EAX "\n\t" \
6104 "incl %1" "\n\t" \
6105 "testb "AL","AL "\n\t" \
6106 "jge "LR(1,f) "\n\t" \
6107 "sall $8,"EAX "\n\t" \
6108 "movb (%1),"AL "\n\t" \
6109 "incl %1" "\n\t" \
6110 "sall $17,"EAX "\n\t" \
6111 "sarl $17,"EAX "\n\t" \
6112 "jne "LR(2,f) "\n\t" \
6113 "movb (%1),"AL "\n\t" \
6114 "sall $8,"EAX "\n\t" \
6115 "movb 1(%1),"AL "\n\t" \
6116 "sall $8,"EAX "\n\t" \
6117 "movb 2(%1),"AL "\n\t" \
6118 "sall $8,"EAX "\n\t" \
6119 "movb 3(%1),"AL "\n\t" \
6120 "addl $4,"EAX "\n\t" \
6121 "jmp "LR(2,f) "\n" \
6122 LD(1)":" "\t" \
6123 "sall $25,"EAX "\n\t" \
6124 "sarl $25,"EAX "\n" \
6125 LD(2)":" \
6126 : OUT_EAX (where), "=r" (byteptr) : "1" (byteptr) );
6127 #endif
6128 #if defined(GNU) && defined(ARM) && !defined(NO_ASM)
6129 /* Macro written by Peter Burwood. */
6130 #undef S_operand
6131 #define S_operand(where) \
6132 { var uintL dummy; \
6133 __asm__( \
6134 "ldrb %0,[%1],#1" "\n\t" \
6135 "movs %0,%0,LSL#25" "\n\t" \
6136 "movcc %0,%0,ASR#25" "\n\t" \
6137 "bcc "LR(1,f) "\n\t" \
6138 "ldrb %2,[%1],#1" "\n\t" \
6139 "orr %0,%0,%2,LSL#17" "\n\t" \
6140 "movs %0,%0,ASR#17" "\n\t" \
6141 "bne "LR(1,f) "\n\t" \
6142 "ldrb %0,[%1],#1" "\n\t" \
6143 "ldrb %2,[%1],#1" "\n\t" \
6144 "orr %0,%2,%0,LSL#8" "\n\t" \
6145 "ldrb %2,[%1],#1" "\n\t" \
6146 "orr %0,%2,%0,LSL#8" "\n\t" \
6147 "ldrb %2,[%1],#1" "\n\t" \
6148 "orr %0,%2,%0,LSL#8" "\n" \
6149 LD(1)":" \
6150 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "cc" ); \
6151 }
6152 #endif
6153
6154 /* Macro S_operand_ignore();
6155 skips the next Operand (a Signed Integer)
6156 and advances the bytecodepointer. */
6157 #define S_operand_ignore() \
6158 { var uintB where = *byteptr++; /* read first byte */ \
6159 if ((uintB)where & bit(7)) \
6160 /* Bit 7 was set */ \
6161 { if ((uintB)((where<<1) | *byteptr++) == 0) /* next Byte */ \
6162 /* special case: 2-Byte-Operand = 0 -> 6-Byte-Operand */ \
6163 { byteptr += 4; } \
6164 } }
6165 #if defined(GNU) && defined(M68K) && !defined(NO_ASM)
6166 #undef S_operand_ignore
6167 #define S_operand_ignore() \
6168 { var uintB where; \
6169 __asm__( \
6170 "moveb %1@+,%0" "\n\t" \
6171 "bpl 1f" "\n\t" \
6172 "addb %0,%0" "\n\t" \
6173 "orb %1@+,%0" "\n\t" \
6174 "bne 1f" "\n\t" \
6175 "addql #4,%1" "\n" \
6176 "1:" \
6177 : "=d" (where), "=a" (byteptr) : "1" (byteptr) ); \
6178 }
6179 #endif
6180 #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
6181 #undef S_operand_ignore
6182 #define S_operand_ignore() \
6183 { var uintL where; \
6184 var uintL dummy; \
6185 __asm__( \
6186 "ldub [%1],%0" "\n\t" \
6187 "andcc %0,0x80,%%g0" "\n\t" \
6188 "be 1f" "\n\t" \
6189 " add %1,1,%1" "\n\t" \
6190 "sll %0,1,%2" "\n\t" \
6191 "ldub [%1],%0" "\n\t" \
6192 "orcc %2,%0,%0" "\n\t" \
6193 "bne 1f" "\n\t" \
6194 " add %1,1,%1" "\n\t" \
6195 "add %1,4,%1" "\n" \
6196 "1:" \
6197 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
6198 }
6199 #endif
6200 #if defined(GNU) && defined(ARM) && !defined(NO_ASM)
6201 /* Macro written by Peter Burwood. */
6202 #undef S_operand_ignore
6203 #define S_operand_ignore() \
6204 { var uintL where; \
6205 var uintL dummy; \
6206 __asm__( \
6207 "ldrb %0,[%1],#1" "\n\t" \
6208 "movs %0,%0,LSL#25" "\n\t" \
6209 "bcc "LR(1,f) "\n\t" \
6210 "ldrb %2,[%1],#1" "\n\t" \
6211 "orrs %0,%2,%0,LSR#24" "\n\t" \
6212 "addeq %1,%1,#4" "\n" \
6213 LD(1)":" \
6214 : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "cc" ); \
6215 }
6216 #endif
6217
6218 /* Macro L_operand(where);
6219 moves the next Operand (a Label)
6220 to (uintB*)where and advances the bytecodepointer. */
6221 #define L_operand(Lwhere) \
6222 { var uintL where; /* variable for the displacement */ \
6223 S_operand(where); /* Displacement */ \
6224 Lwhere = byteptr + (sintL)where; /* add */ \
6225 }
6226
6227 /* Macro L_operand_ignore();
6228 skips the next Operand (a Label)
6229 and advances the Bytecodepointer. */
6230 #define L_operand_ignore() S_operand_ignore()
6231 /* Each of the bytecodes is interpreted:
6232 for the most part: mv_count/mv_space = values,
6233 closureptr = pointer to the compiled closure in Stack,
6234 closure = compiled closure,
6235 codeptr = pointer to its codevector,
6236 byteptr = pointer to the next Byte in code.
6237 (byteptr is no LISP-object, but nevertheless endangered by GC!
6238 To make it GC-invariant, substract CODEPTR from it.
6239 If one then adds Fixnum_0 to it,
6240 one receives the bytenumber as Fixnum.) */
6241 #if 0
6242 #define CODEPTR (&codeptr->data[0])
6243 #else /* returns more efficient Code */
6244 #define CODEPTR (uintB*)(codeptr)
6245 #endif
6246
6247 /* store context-information:
6248 If sth. is called, that can trigger a GC, this must be framed within
6249 with_saved_context( ... ) . */
6250 #define with_saved_context(statement) \
6251 { var uintL index = byteptr - CODEPTR; \
6252 statement; \
6253 closure = *closureptr; /* fetch Closure from Stack */ \
6254 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec); \
6255 byteptr = CODEPTR + index; \
6256 }
6257
6258 /* ------------------- (1) Constants ----------------------- */
6259 CASE cod_nil: code_nil: { /* (NIL) */
6260 VALUES1(NIL);
6261 } goto next_byte;
6262 CASE cod_nil_push: { /* (NIL&PUSH) */
6263 pushSTACK(NIL);
6264 } goto next_byte;
6265 CASE cod_push_nil: { /* (PUSH-NIL n) */
6266 var uintC n;
6267 U_operand(n);
6268 dotimesC(n,n, { pushSTACK(NIL); } );
6269 } goto next_byte;
6270 CASE cod_t: code_t: { /* (T) */
6271 VALUES1(T);
6272 } goto next_byte;
6273 CASE cod_t_push: { /* (T&PUSH) */
6274 pushSTACK(T);
6275 } goto next_byte;
6276 CASE cod_const: { /* (CONST n) */
6277 var uintL n;
6278 U_operand(n);
6279 VALUES1(TheCclosure(closure)->clos_consts[n]);
6280 } goto next_byte;
6281 CASE cod_const_push: { /* (CONST&PUSH n) */
6282 var uintL n;
6283 U_operand(n);
6284 pushSTACK(TheCclosure(closure)->clos_consts[n]);
6285 } goto next_byte;
6286 /* ------------------- (2) static Variables ----------------------- */
6287 CASE cod_load: { /* (LOAD n) */
6288 var uintL n;
6289 U_operand(n);
6290 VALUES1(STACK_(n));
6291 } goto next_byte;
6292 CASE cod_load_push: { /* (LOAD&PUSH n) */
6293 var uintL n;
6294 U_operand(n);
6295 pushSTACK(STACK_(n));
6296 } goto next_byte;
6297 CASE cod_loadi: { /* (LOADI k1 k2 n) */
6298 var uintL k1;
6299 var uintL k2;
6300 var uintL n;
6301 U_operand(k1);
6302 U_operand(k2);
6303 U_operand(n);
6304 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
6305 VALUES1(FRAME_(n));
6306 } goto next_byte;
6307 CASE cod_loadi_push: { /* (LOADI&PUSH k1 k2 n) */
6308 var uintL k1;
6309 var uintL k2;
6310 var uintL n;
6311 U_operand(k1);
6312 U_operand(k2);
6313 U_operand(n);
6314 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
6315 pushSTACK(FRAME_(n));
6316 } goto next_byte;
6317 CASE cod_loadc: { /* (LOADC n m) */
6318 var uintL n;
6319 var uintL m;
6320 U_operand(n);
6321 U_operand(m);
6322 VALUES1(TheSvector(STACK_(n))->data[1+m]);
6323 } goto next_byte;
6324 CASE cod_loadc_push: { /* (LOADC&PUSH n m) */
6325 var uintL n;
6326 var uintL m;
6327 U_operand(n);
6328 U_operand(m);
6329 pushSTACK(TheSvector(STACK_(n))->data[1+m]);
6330 } goto next_byte;
6331 CASE cod_loadv: { /* (LOADV k m) */
6332 var uintC k;
6333 var uintL m;
6334 U_operand(k);
6335 U_operand(m);
6336 var object venv = TheCclosure(closure)->clos_venv; /* VenvConst */
6337 /* take (svref ... 0) k times: */
6338 dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
6339 /* fetch (svref ... m) : */
6340 VALUES1(TheSvector(venv)->data[m]);
6341 } goto next_byte;
6342 CASE cod_loadv_push: { /* (LOADV&PUSH k m) */
6343 var uintC k;
6344 var uintL m;
6345 U_operand(k);
6346 U_operand(m);
6347 var object venv = TheCclosure(closure)->clos_venv; /* VenvConst */
6348 /* take (svref ... 0) k times: */
6349 dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
6350 /* fetch (svref ... m) : */
6351 pushSTACK(TheSvector(venv)->data[m]);
6352 } goto next_byte;
6353 CASE cod_loadic: { /* (LOADIC k1 k2 n m) */
6354 var uintL k1;
6355 var uintL k2;
6356 var uintL n;
6357 var uintL m;
6358 U_operand(k1);
6359 U_operand(k2);
6360 U_operand(n);
6361 U_operand(m);
6362 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
6363 VALUES1(TheSvector(FRAME_(n))->data[1+m]);
6364 } goto next_byte;
6365 CASE cod_store: store: { /* (STORE n) */
6366 var uintL n;
6367 U_operand(n);
6368 VALUES1(STACK_(n) = value1);
6369 } goto next_byte;
6370 CASE cod_pop_store: { /* (POP&STORE n) */
6371 var uintL n;
6372 U_operand(n);
6373 var object obj = popSTACK();
6374 VALUES1(STACK_(n) = obj);
6375 } goto next_byte;
6376 CASE cod_storei: { /* (STOREI k1 k2 n) */
6377 var uintL k1;
6378 var uintL k2;
6379 var uintL n;
6380 U_operand(k1);
6381 U_operand(k2);
6382 U_operand(n);
6383 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
6384 VALUES1(FRAME_(n) = value1);
6385 } goto next_byte;
6386 CASE cod_load_storec: { /* (LOAD&STOREC k m n) */
6387 var uintL k;
6388 U_operand(k);
6389 value1 = STACK_(k);
6390 } /* FALLTHROUGH */
6391 CASE cod_storec: { /* (STOREC n m) */
6392 var uintL n;
6393 var uintL m;
6394 U_operand(n);
6395 U_operand(m);
6396 TheSvector(STACK_(n))->data[1+m] = value1; mv_count=1;
6397 } goto next_byte;
6398 CASE cod_storev: { /* (STOREV k m) */
6399 var uintC k;
6400 var uintL m;
6401 U_operand(k);
6402 U_operand(m);
6403 var object venv = TheCclosure(closure)->clos_venv; /* VenvConst */
6404 /* take (svref ... 0) k times: */
6405 dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
6406 /* save (svref ... m) : */
6407 TheSvector(venv)->data[m] = value1; mv_count=1;
6408 } goto next_byte;
6409 CASE cod_storeic: { /* (STOREIC k1 k2 n m) */
6410 var uintL k1;
6411 var uintL k2;
6412 var uintL n;
6413 var uintL m;
6414 U_operand(k1);
6415 U_operand(k2);
6416 U_operand(n);
6417 U_operand(m);
6418 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
6419 TheSvector(FRAME_(n))->data[1+m] = value1; mv_count=1;
6420 } goto next_byte;
6421 /* ------------------- (3) dynamic Variables ----------------------- */
6422 CASE cod_getvalue: { /* (GETVALUE n) */
6423 var uintL n;
6424 U_operand(n);
6425 var object symbol = TheCclosure(closure)->clos_consts[n];
6426 /* The Compiler has already checked, that it's a Symbol. */
6427 if (!boundp(Symbol_value(symbol))) {
6428 pushSTACK(symbol); check_variable_value_replacement(&STACK_0,false);
6429 }
6430 VALUES1(Symbol_value(symbol));
6431 } goto next_byte;
6432 CASE cod_getvalue_push: { /* (GETVALUE&PUSH n) */
6433 var uintL n;
6434 U_operand(n);
6435 var object symbol = TheCclosure(closure)->clos_consts[n];
6436 /* The Compiler has already checked, that it's a Symbol. */
6437 if (!boundp(Symbol_value(symbol))) {
6438 pushSTACK(symbol); check_variable_value_replacement(&STACK_0,false);
6439 }
6440 pushSTACK(Symbol_value(symbol));
6441 } goto next_byte;
6442 CASE cod_setvalue: { /* (SETVALUE n) */
6443 var uintL n;
6444 U_operand(n);
6445 var object symbol = TheCclosure(closure)->clos_consts[n];
6446 /* The Compiler has already checked, that it's a Symbol. */
6447 if (constant_var_p(TheSymbol(symbol))) {
6448 pushSTACK(symbol); pushSTACK(Closure_name(closure));
6449 error(error_condition,
6450 GETTEXT("~S: assignment to constant symbol ~S is impossible"));
6451 }
6452 Symbol_value(symbol) = value1; mv_count=1;
6453 } goto next_byte;
6454 CASE cod_bind: { /* (BIND n) */
6455 var uintL n;
6456 U_operand(n);
6457 #if defined(MULTITHREAD)
6458 var object symbol = TheCclosure(closure)->clos_consts[n];
6459 if (TheSymbol(symbol)->tls_index == SYMBOL_TLS_INDEX_NONE) {
6460 var uintC mvc = mv_count;
6461 mv_to_STACK(); /* save mv_space */
6462 with_saved_context({add_per_thread_special_var(symbol); /* maygc */});
6463 STACK_to_mv(mvc); /* restore mv_space */
6464 }
6465 #endif
6466 dynamic_bind(TheCclosure(closure)->clos_consts[n],value1);
6467 } goto next_byte;
6468 CASE cod_unbind1: /* (UNBIND1) */
6469 #if STACKCHECKC
6470 if (!(framecode(STACK_0) == DYNBIND_frame_info))
6471 GOTO_ERROR(error_STACK_putt);
6472 #endif
6473 { /* unwind variable-binding-frame: */
6474 var gcv_object_t* new_STACK = topofframe(STACK_0); /* pointer above frame */
6475 var gcv_object_t* frame_end = STACKpointable(new_STACK);
6476 var gcv_object_t* bindingptr = &STACK_1; /* begin of bindings */
6477 /* bindingptr loops upwards through the bindings */
6478 while (bindingptr != frame_end) {
6479 /* write back old value: */
6480 Symbol_value(*(bindingptr STACKop 0)) = *(bindingptr STACKop 1);
6481 bindingptr skipSTACKop 2; /* next binding */
6482 }
6483 /* set STACK newly, thus unwind frame: */
6484 setSTACK(STACK = new_STACK);
6485 } goto next_byte;
6486 CASE cod_unbind: { /* (UNBIND n) */
6487 var uintC n;
6488 U_operand(n); /* n>0 */
6489 var gcv_object_t* FRAME = STACK;
6490 do {
6491 #if STACKCHECKC
6492 if (!(framecode(FRAME_(0)) == DYNBIND_frame_info))
6493 GOTO_ERROR(error_STACK_putt);
6494 #endif
6495 /* unwind variable-binding-frame: */
6496 var gcv_object_t* new_FRAME = topofframe(FRAME_(0)); /* pointer above frame */
6497 var gcv_object_t* frame_end = STACKpointable(new_FRAME);
6498 var gcv_object_t* bindingptr = &FRAME_(1); /* begin of the bindings */
6499 /* bindingptr loops upwards through the bindings */
6500 while (bindingptr != frame_end) {
6501 /* write back old value: */
6502 Symbol_value(*(bindingptr STACKop 0)) = *(bindingptr STACKop 1);
6503 bindingptr skipSTACKop 2; /* next binding */
6504 }
6505 FRAME = new_FRAME;
6506 } while (--n != 0);
6507 setSTACK(STACK = FRAME); /* set STACK newly */
6508 } goto next_byte;
6509 CASE cod_progv: { /* (PROGV) */
6510 var object vallist = value1; /* value-list */
6511 var object symlist = popSTACK(); /* symbol-list */
6512 pushSP((aint)STACK); /* push STACK into SP */
6513 with_saved_context( progv(symlist,vallist); ); /* build frame */
6514 } goto next_byte;
6515 /* ------------------- (4) Stackoperations ----------------------- */
6516 CASE cod_push: /* (PUSH) */
6517 pushSTACK(value1);
6518 goto next_byte;
6519 CASE cod_pop: /* (POP) */
6520 VALUES1(popSTACK());
6521 goto next_byte;
6522 CASE cod_skip: { /* (SKIP n) */
6523 var uintL n;
6524 U_operand(n);
6525 skipSTACK(n);
6526 } goto next_byte;
6527 CASE cod_skipi: { /* (SKIPI k1 k2 n) */
6528 var uintL k1;
6529 var uintL k2;
6530 var uintL n;
6531 U_operand(k1);
6532 U_operand(k2);
6533 U_operand(n);
6534 skipSP(k1+jmpbufsize*k2);
6535 var gcv_object_t* newSTACK;
6536 popSP( newSTACK = (gcv_object_t*) );
6537 setSTACK(STACK = newSTACK STACKop n);
6538 } goto next_byte;
6539 CASE cod_skipsp: { /* (SKIPSP k1 k2) */
6540 var uintL k1;
6541 var uintL k2;
6542 U_operand(k1);
6543 U_operand(k2);
6544 skipSP(k1+jmpbufsize*k2);
6545 } goto next_byte;
6546 /* ------------------- (5) Control Flow and Jumps --------------------- */
6547 CASE cod_skip_ret: { /* (SKIP&RET n) */
6548 var uintL n;
6549 U_operand(n);
6550 skipSTACK(n);
6551 } goto finished; /* return (jump) to caller */
6552 CASE cod_skip_retgf: { /* (SKIP&RETGF n) */
6553 var uintL n;
6554 U_operand(n);
6555 if (((Codevec)codeptr)->ccv_flags & bit(3)) { /* call inhibition? */
6556 skipSTACK(n);
6557 mv_count=1;
6558 goto finished; /* return (jump) to caller */
6559 }
6560 /* It is known (refer to clos.lisp), that this function
6561 has no optional parameters, but poss. Rest-parameters.
6562 If there's no Rest-parameter: (FUNCALL value1 arg1 ... argr)
6563 If there's a Rest-Parameter: (APPLY value1 arg1 ... argr restarg) */
6564 var uintL r = ((Codevec)codeptr)->ccv_numreq;
6565 n -= r;
6566 if (((Codevec)codeptr)->ccv_flags & bit(0)) {
6567 skipSTACK(n-1); apply(value1,r,popSTACK());
6568 } else {
6569 skipSTACK(n); funcall(value1,r);
6570 } goto finished; /* return (jump) to caller */
6571 }
6572 #define JMP() \
6573 { GC_SAFE_POINT_IF( \
6574 with_saved_context( \
6575 {var uintC cnt=mv_count; mv_to_STACK(); \
6576 GC_SAFE_ACK_SUSPEND_REQUEST_(); \
6577 STACK_to_mv(cnt); \
6578 }),;); \
6579 {var const uintB* label_byteptr; \
6580 L_operand(label_byteptr); \
6581 DEBUG_CHECK_BYTEPTR(label_byteptr); \
6582 byteptr = label_byteptr; \
6583 goto next_byte; \
6584 }}
6585 #define NOTJMP() \
6586 { L_operand_ignore(); goto next_byte; }
6587 jmp0:
6588 #ifdef MULTITHREAD
6589 mv_count=0;
6590 #endif
6591 CASE cod_jmp: jmp: /* (JMP label) */
6592 JMP();
6593 CASE cod_jmpif: /* (JMPIF label) */
6594 if (!nullp(value1)) goto jmp;
6595 notjmp:
6596 NOTJMP();
6597 CASE cod_jmpifnot: /* (JMPIFNOT label) */
6598 if (nullp(value1)) goto jmp;
6599 NOTJMP();
6600 CASE cod_jmpif1: /* (JMPIF1 label) */
6601 if (!nullp(value1)) { mv_count=1; goto jmp; }
6602 NOTJMP();
6603 CASE cod_jmpifnot1: /* (JMPIFNOT1 label) */
6604 if (nullp(value1)) { mv_count=1; goto jmp; }
6605 NOTJMP();
6606 CASE cod_jmpifatom: /* (JMPIFATOM label) */
6607 if (atomp(value1)) goto jmp0;
6608 NOTJMP();
6609 CASE cod_jmpifconsp: /* (JMPIFCONSP label) */
6610 if (consp(value1)) goto jmp0;
6611 NOTJMP();
6612 CASE cod_jmpifeq: /* (JMPIFEQ label) */
6613 if (eq(popSTACK(),value1)) goto jmp0;
6614 NOTJMP();
6615 CASE cod_jmpifnoteq: /* (JMPIFNOTEQ label) */
6616 if (!eq(popSTACK(),value1)) goto jmp0;
6617 NOTJMP();
6618 CASE cod_jmpifeqto: { /* (JMPIFEQTO n label) */
6619 var uintL n;
6620 U_operand(n);
6621 if (eq(popSTACK(),TheCclosure(closure)->clos_consts[n])) goto jmp0;
6622 } NOTJMP();
6623 CASE cod_jmpifnoteqto: { /* (JMPIFNOTEQTO n label) */
6624 var uintL n;
6625 U_operand(n);
6626 if (!eq(popSTACK(),TheCclosure(closure)->clos_consts[n])) goto jmp0;
6627 } NOTJMP();
6628 CASE cod_jmphash: { /* (JMPHASH n label) */
6629 var uintL n;
6630 U_operand(n);
6631 var object hashvalue = /* search value1 in the Hash-table */
6632 gethash(value1,TheCclosure(closure)->clos_consts[n],false);
6633 if (eq(hashvalue,nullobj))
6634 goto jmp0; /* not found -> jump to label */
6635 else { /* interpret found Fixnum as label: */
6636 DEBUG_CHECK_BYTEPTR(byteptr + fixnum_to_V(hashvalue));
6637 byteptr += fixnum_to_V(hashvalue);
6638 }
6639 } goto next_byte;
6640 CASE cod_jmphashv: { /* (JMPHASHV n label) */
6641 var uintL n;
6642 U_operand(n);
6643 var object hashvalue = /* search value1 in the Hash-table */
6644 gethash(value1,TheSvector(TheCclosure(closure)->clos_consts[0])->data[n],false);
6645 if (eq(hashvalue,nullobj))
6646 goto jmp0; /* not found -> jump to label */
6647 else { /* interpret found Fixnum as label: */
6648 DEBUG_CHECK_BYTEPTR(byteptr + fixnum_to_V(hashvalue));
6649 byteptr += fixnum_to_V(hashvalue);
6650 }
6651 } goto next_byte;
6652 /* executes a (JSR label)-command. */
6653 #define JSR() \
6654 check_STACK(); check_SP(); \
6655 { var const uintB* label_byteptr; \
6656 L_operand(label_byteptr); \
6657 with_saved_context( \
6658 with_saved_back_trace_cclosure(closure, \
6659 interpret_bytecode_(closure,codeptr,label_byteptr); \
6660 )); \
6661 }
6662 CASE cod_jsr: /* (JSR label) */
6663 JSR();
6664 goto next_byte;
6665 CASE cod_jsr_push: /* (JSR&PUSH label) */
6666 JSR(); pushSTACK(value1);
6667 goto next_byte;
6668 CASE cod_jmptail: { /* (JMPTAIL m n label) */
6669 var uintL m;
6670 var uintL n;
6671 U_operand(m);
6672 U_operand(n);
6673 /* It is n>=m. Copy m stack-entries upwards by n-m : */
6674 var gcv_object_t* ptr1 = STACK STACKop m;
6675 var gcv_object_t* ptr2 = STACK STACKop n;
6676 var uintC count;
6677 dotimesC(count,m, { NEXT(ptr2) = NEXT(ptr1); } );
6678 /* Now ptr1 = STACK and ptr2 = STACK STACKop (n-m). */
6679 *(closureptr = &NEXT(ptr2)) = closure; /* store closure in stack */
6680 setSTACK(STACK = ptr2); /* shorten STACK */
6681 } goto jmp0; /* jump to label */
6682 /* ------------------- (6) Environments and Closures -------------------- */
6683 CASE cod_venv: /* (VENV) */
6684 /* fetch VenvConst from the closure: */
6685 VALUES1(TheCclosure(closure)->clos_venv);
6686 goto next_byte;
6687 CASE cod_make_vector1_push: { /* (MAKE-VECTOR1&PUSH n) */
6688 var uintL n;
6689 U_operand(n);
6690 pushSTACK(value1);
6691 /* create vector: */
6692 var object vec;
6693 with_saved_context( { vec = allocate_vector(n+1); } );
6694 /* fill first element: */
6695 TheSvector(vec)->data[0] = STACK_0;
6696 STACK_0 = vec;
6697 } goto next_byte;
6698 CASE cod_copy_closure: { /* (COPY-CLOSURE m n) */
6699 var object oldclos;
6700 { /* fetch closure to be copied: */
6701 var uintL m;
6702 U_operand(m);
6703 oldclos = TheCclosure(closure)->clos_consts[m];
6704 }
6705 /* allocate closure of equal length: */
6706 var object newclos;
6707 pushSTACK(oldclos);
6708 with_saved_context(newclos = allocate_cclosure_copy(oldclos););
6709 oldclos = popSTACK();
6710 /* copy contents of the old closure into the new one: */
6711 do_cclosure_copy(newclos,oldclos);
6712 { /* copy stack content into the new closure: */
6713 var uintL n;
6714 U_operand(n);
6715 var gcv_object_t* newptr = &TheCclosure(newclos)->clos_consts[n];
6716 dotimespL(n,n, { *--newptr = popSTACK(); } );
6717 }
6718 VALUES1(newclos);
6719 } goto next_byte;
6720 CASE cod_copy_closure_push: { /* (COPY-CLOSURE&PUSH m n) */
6721 var object oldclos;
6722 { /* fetch closure to be copied: */
6723 var uintL m;
6724 U_operand(m);
6725 oldclos = TheCclosure(closure)->clos_consts[m];
6726 }
6727 /* allocate closure of equal length: */
6728 var object newclos;
6729 pushSTACK(oldclos);
6730 with_saved_context(newclos = allocate_cclosure_copy(oldclos););
6731 oldclos = popSTACK();
6732 /* copy contents of the old closure into the new one: */
6733 do_cclosure_copy(newclos,oldclos);
6734 { /* copy stack content into the new closure: */
6735 var uintL n;
6736 U_operand(n);
6737 var gcv_object_t* newptr = &TheCclosure(newclos)->clos_consts[n];
6738 dotimespL(n,n, { *--newptr = popSTACK(); } );
6739 }
6740 pushSTACK(newclos);
6741 } goto next_byte;
6742 /* ------------------- (7) Function Calls -----------------------
6743 executes (CALL k n)-command. */
6744 #define CALL() \
6745 { var uintC k; /* number of arguments */ \
6746 var uintL n; \
6747 U_operand(k); \
6748 U_operand(n); \
6749 with_saved_context( \
6750 funcall(TheCclosure(closure)->clos_consts[n],k); \
6751 ); \
6752 }
6753 /* executes (CALL0 n)-command. */
6754 #define CALL0() \
6755 { var uintL n; \
6756 U_operand(n); \
6757 with_saved_context( \
6758 funcall(TheCclosure(closure)->clos_consts[n],0); \
6759 ); \
6760 }
6761 /* executes (CALL1 n)-command. */
6762 #define CALL1() \
6763 { var uintL n; \
6764 U_operand(n); \
6765 with_saved_context( \
6766 funcall(TheCclosure(closure)->clos_consts[n],1); \
6767 ); \
6768 }
6769 /* executes (CALL2 n)-command. */
6770 #define CALL2() \
6771 { var uintL n; \
6772 U_operand(n); \
6773 with_saved_context( \
6774 funcall(TheCclosure(closure)->clos_consts[n],2); \
6775 ); \
6776 }
6777 /* executes (CALLS1 n)-command. */
6778 #define CALLS1() \
6779 { var uintL n; \
6780 B_operand(n); \
6781 /* The compiler has already done the argument-check. */ \
6782 {var Subr fun = FUNTAB1[n]; \
6783 with_saved_context( \
6784 with_saved_back_trace_subr(subr_tab_ptr_as_object(fun),STACK,-1, \
6785 (*(subr_norest_function_t*)(fun->function))(); \
6786 )); \
6787 }}
6788 /* executes (CALLS2 n)-command. */
6789 #define CALLS2() \
6790 { var uintL n; \
6791 B_operand(n); \
6792 /* The compiler has already done the argument-check. */ \
6793 {var Subr fun = FUNTAB2[n]; \
6794 with_saved_context( \
6795 with_saved_back_trace_subr(subr_tab_ptr_as_object(fun),STACK,-1, \
6796 (*(subr_norest_function_t*)(fun->function))(); \
6797 )); \
6798 }} \
6799 /* executes (CALLSR m n)-command. */
6800 #define CALLSR() \
6801 { var uintL m; \
6802 var uintL n; \
6803 U_operand(m); \
6804 B_operand(n); \
6805 /* The compiler has already done the argument-check. */ \
6806 {var Subr fun = FUNTABR[n]; \
6807 with_saved_context( \
6808 with_saved_back_trace_subr(subr_tab_ptr_as_object(fun),STACK,-1, \
6809 (*(subr_rest_function_t*)(fun->function))(m,args_end_pointer STACKop m); \
6810 )); \
6811 }}
6812 CASE cod_call: /* (CALL k n) */
6813 CALL();
6814 goto next_byte;
6815 CASE cod_call_push: /* (CALL&PUSH k n) */
6816 CALL(); pushSTACK(value1);
6817 goto next_byte;
6818 CASE cod_call0: /* (CALL0 n) */
6819 CALL0();
6820 goto next_byte;
6821 CASE cod_call1: /* (CALL1 n) */
6822 CALL1();
6823 goto next_byte;
6824 CASE cod_call1_push: /* (CALL1&PUSH n) */
6825 CALL1(); pushSTACK(value1);
6826 goto next_byte;
6827 CASE cod_call2: /* (CALL2 n) */
6828 CALL2();
6829 goto next_byte;
6830 CASE cod_call2_push: /* (CALL2&PUSH n) */
6831 CALL2(); pushSTACK(value1);
6832 goto next_byte;
6833 CASE cod_calls1: /* (CALLS1 n) */
6834 CALLS1();
6835 goto next_byte;
6836 CASE cod_calls1_push: /* (CALLS1&PUSH n) */
6837 CALLS1(); pushSTACK(value1);
6838 goto next_byte;
6839 CASE cod_calls2: /* (CALLS2 n) */
6840 CALLS2();
6841 goto next_byte;
6842 CASE cod_calls2_push: /* (CALLS2&PUSH n) */
6843 CALLS2(); pushSTACK(value1);
6844 goto next_byte;
6845 CASE cod_callsr: /* (CALLSR m n) */
6846 CALLSR();
6847 goto next_byte;
6848 CASE cod_callsr_push: /* (CALLSR&PUSH m n) */
6849 CALLSR(); pushSTACK(value1);
6850 goto next_byte;
6851 /* executes a (CALLC)-command. */
6852 #define CALLC() \
6853 { check_STACK(); check_SP(); /* check STACK and SP */ \
6854 with_saved_context( \
6855 /* interpret compiled closure starting at Byte 8 */ \
6856 interpret_bytecode(value1,TheCclosure(value1)->clos_codevec,CCV_START_NONKEY); \
6857 ); \
6858 }
6859 /* executes a (CALLCKEY)-command. */
6860 #define CALLCKEY() \
6861 { check_STACK(); check_SP(); /* check STACK and SP */ \
6862 with_saved_context( \
6863 /* interpret compiled closure starting at Byte 12: */ \
6864 interpret_bytecode(value1,TheCclosure(value1)->clos_codevec,CCV_START_KEY); \
6865 ); \
6866 }
6867 CASE cod_callc: /* (CALLC) */
6868 CALLC();
6869 goto next_byte;
6870 CASE cod_callc_push: /* (CALLC&PUSH) */
6871 CALLC(); pushSTACK(value1);
6872 goto next_byte;
6873 CASE cod_callckey: /* (CALLCKEY) */
6874 CALLCKEY();
6875 goto next_byte;
6876 CASE cod_callckey_push: /* (CALLCKEY&PUSH) */
6877 CALLCKEY(); pushSTACK(value1);
6878 goto next_byte;
6879 CASE cod_funcall: { /* (FUNCALL n) */
6880 var uintL n;
6881 U_operand(n);
6882 var object fun = STACK_(n); /* Function */
6883 with_saved_context( funcall(fun,n); ); /* call Function */
6884 skipSTACK(1); /* discard function from Stack */
6885 } goto next_byte;
6886 CASE cod_funcall_push: { /* (FUNCALL&PUSH n) */
6887 var uintL n;
6888 U_operand(n);
6889 var object fun = STACK_(n); /* Function */
6890 with_saved_context( funcall(fun,n); ); /* call Function */
6891 STACK_0 = value1; /* replace Function in Stack by value */
6892 } goto next_byte;
6893 CASE cod_apply: { /* (APPLY n) */
6894 var uintL n;
6895 U_operand(n);
6896 var object fun = STACK_(n); /* Function */
6897 with_saved_context( apply(fun,n,value1); ); /* call Function */
6898 skipSTACK(1); /* discard Function from Stack */
6899 } goto next_byte;
6900 CASE cod_apply_push: { /* (APPLY&PUSH n) */
6901 var uintL n;
6902 U_operand(n);
6903 var object fun = STACK_(n); /* Function */
6904 with_saved_context( apply(fun,n,value1); ); /* call Function */
6905 STACK_0 = value1; /* replace Function in Stack by value */
6906 } goto next_byte;
6907 /* ---------------- (8) optional and Keyword-arguments ---------------- */
6908 CASE cod_push_unbound: { /* (PUSH-UNBOUND n) */
6909 var uintC n;
6910 U_operand(n);
6911 dotimesC(n,n, { pushSTACK(unbound); } );
6912 } goto next_byte;
6913 CASE cod_unlist: { /* (UNLIST n m) */
6914 var uintC n;
6915 var uintC m;
6916 U_operand(n);
6917 U_operand(m);
6918 var object l = value1;
6919 if (n > 0)
6920 do {
6921 if (atomp(l)) goto unlist_unbound;
6922 pushSTACK(Car(l)); l = Cdr(l);
6923 } while (--n != 0);
6924 if (atomp(l))
6925 goto next_byte;
6926 else
6927 error_apply_toomany(S(lambda));
6928 unlist_unbound:
6929 if (n > m) error_apply_toofew(S(lambda),l);
6930 do { pushSTACK(unbound); } while (--n != 0);
6931 } goto next_byte;
6932 CASE cod_unliststar: { /* (UNLIST* n m) */
6933 var uintC n;
6934 var uintC m;
6935 U_operand(n);
6936 U_operand(m);
6937 var object l = value1;
6938 do {
6939 if (atomp(l)) goto unliststar_unbound;
6940 pushSTACK(Car(l)); l = Cdr(l);
6941 } while (--n != 0);
6942 pushSTACK(l);
6943 goto next_byte;
6944 unliststar_unbound:
6945 if (n > m) error_apply_toofew(S(lambda),l);
6946 do { pushSTACK(unbound); } while (--n != 0);
6947 pushSTACK(NIL);
6948 } goto next_byte;
6949 CASE cod_jmpifboundp: { /* (JMPIFBOUNDP n label) */
6950 var uintL n;
6951 U_operand(n);
6952 var object obj = STACK_(n);
6953 if (!boundp(obj)) goto notjmp;
6954 VALUES1(obj);
6955 } JMP();
6956 CASE cod_boundp: { /* (BOUNDP n) */
6957 var uintL n;
6958 U_operand(n);
6959 var object obj = STACK_(n);
6960 if (!boundp(obj)) goto code_nil; else goto code_t;
6961 }
6962 CASE cod_unbound_nil: { /* (UNBOUND->NIL n) */
6963 var uintL n;
6964 U_operand(n);
6965 if (!boundp(STACK_(n))) { STACK_(n) = NIL; }
6966 } goto next_byte;
6967 /* ------------------- (9) Treatment of multiple values -------------- */
6968 CASE cod_values0: /* (VALUES0) */
6969 VALUES0;
6970 goto next_byte;
6971 CASE cod_values1: /* (VALUES1) */
6972 mv_count = 1;
6973 goto next_byte;
6974 CASE cod_stack_to_mv: { /* (STACK-TO-MV n) */
6975 var uintL n;
6976 U_operand(n);
6977 if (n >= mv_limit) GOTO_ERROR(error_toomany_values);
6978 STACK_to_mv(n);
6979 } goto next_byte;
6980 CASE cod_mv_to_stack: /* (MV-TO-STACK) */
6981 mv_to_STACK(); /* push values on Stack */
6982 goto next_byte;
6983 CASE cod_nv_to_stack: { /* (NV-TO-STACK n) */
6984 var uintL n;
6985 U_operand(n);
6986 /* test for Stack-Overflow: */
6987 get_space_on_STACK(n*sizeof(gcv_object_t));
6988 /* push n values in the Stack: */
6989 var uintC count = mv_count;
6990 if (n==0) goto nv_to_stack_end; /* no value desired -> finished */
6991 /* at least 1 value desired */
6992 pushSTACK(value1);
6993 n--; if (n==0) goto nv_to_stack_end; /* only 1 value desired -> finished */
6994 if (count<=1) goto nv_to_stack_fill; /* only 1 value present -> fill with NILs */
6995 count--;
6996 { /* at least 2 values desired and present */
6997 var object* mvp = &mv_space[1];
6998 while (1) {
6999 pushSTACK(*mvp++);
7000 n--; if (n==0) goto nv_to_stack_end; /* no further value desired -> finished */
7001 count--; if (count==0) goto nv_to_stack_fill; /* no further value present -> fill with NILs */
7002 }
7003 }
7004 nv_to_stack_fill: /* fill up with n>0 NILs as additional values: */
7005 dotimespL(n,n, { pushSTACK(NIL); } );
7006 nv_to_stack_end: ;
7007 } goto next_byte;
7008 CASE cod_mv_to_list: /* (MV-TO-LIST) */
7009 with_saved_context(
7010 /* push values on Stack and handicraft list out of it: */
7011 mv_to_list();
7012 );
7013 VALUES1(popSTACK());
7014 goto next_byte;
7015 CASE cod_list_to_mv: /* (LIST-TO-MV) */
7016 list_to_mv(value1, GOTO_ERROR(error_toomany_values));
7017 goto next_byte;
7018 CASE cod_mvcallp: /* (MVCALLP) */
7019 pushSP((aint)STACK); /* save STACK */
7020 pushSTACK(value1); /* save function to be executed */
7021 goto next_byte;
7022 CASE cod_mvcall: { /* (MVCALL) */
7023 var gcv_object_t* FRAME; popSP( FRAME = (gcv_object_t*) ); /* Pointer to Arguments and Function */
7024 var object fun = NEXT(FRAME); /* Function */
7025 with_saved_context({
7026 var uintL argcount = /* number of arguments on stack */
7027 STACK_item_count(STACK,FRAME);
7028 if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
7029 error_too_many_args(S(multiple_value_call),fun,argcount,ca_limit_1);
7030 /* apply Function, lift Stack until below the Function: */
7031 funcall(fun,argcount);
7032 skipSTACK(1); /* discard Function from STACK */
7033 });
7034 } goto next_byte;
7035 /* ------------------- (10) BLOCK ----------------------- */
7036 CASE cod_block_open: { /* (BLOCK-OPEN n label) */
7037 /* occupies 3 STACK-entries and 1 SP-jmp_buf-entry and 2 SP-entries */
7038 var uintL n;
7039 var sintL label_dist;
7040 U_operand(n);
7041 S_operand(label_dist);
7042 /* create Block_Cons: */
7043 var object block_cons;
7044 with_saved_context(
7045 block_cons = allocate_cons();
7046 label_dist += index; /* CODEPTR+label_dist is the jump destination */
7047 );
7048 /* fill Block-Cons: (CONST n) as CAR */
7049 Car(block_cons) = TheCclosure(closure)->clos_consts[n];
7050 /* jump destination into SP: */
7051 pushSP(label_dist); pushSP((aint)closureptr);
7052 { /* build up CBLOCK-Frame: */
7053 var gcv_object_t* top_of_frame = STACK; /* Pointer above Frame */
7054 pushSTACK(block_cons); /* Cons ( (CONST n) . ...) */
7055 var JMPBUF_on_SP(returner); /* memorize return-point */
7056 finish_entry_frame_1(CBLOCK,returner, goto block_return; );
7057 }
7058 /* store Framepointer in Block-Cons: */
7059 Cdr(block_cons) = make_framepointer(STACK);
7060 } goto next_byte;
7061 block_return: { /* jump to this label takes place, if the previously
7062 built CBLOCK-Frame has catched a RETURN-FROM. */
7063 FREE_JMPBUF_on_SP();
7064 skipSTACK(2); /* unwind CBLOCK-Frame and mark */
7065 Cdr(popSTACK()) = disabled; /* Block-Cons as Disabled */
7066 var uintL index;
7067 /* get closure back, byteptr:=label_byteptr : */
7068 popSP(closureptr = (gcv_object_t*) ); popSP(index = );
7069 closure = *closureptr; /* fetch Closure from Stack */
7070 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
7071 DEBUG_CHECK_BYTEPTR(CODEPTR + index);
7072 byteptr = CODEPTR + index;
7073 } goto next_byte; /* continue interpretation at Label */
7074 CASE cod_block_close: /* (BLOCK-CLOSE) */
7075 /* unwind CBLOCK-Frame: */
7076 #if STACKCHECKC
7077 if (!(framecode(STACK_0) == CBLOCK_frame_info))
7078 GOTO_ERROR(error_STACK_putt);
7079 #endif
7080 {
7081 FREE_JMPBUF_on_SP();
7082 skipSTACK(2); /* unwind CBLOCK-Frame and mark */
7083 Cdr(popSTACK()) = disabled; /* Block-Cons as Disabled */
7084 skipSP(2); /* we know Destination-Closureptr and Destination-Label */
7085 } goto next_byte; /* at Label continue interpretation */
7086 CASE cod_return_from: { /* (RETURN-FROM n) */
7087 var uintL n;
7088 U_operand(n);
7089 var object block_cons = TheCclosure(closure)->clos_consts[n];
7090 if (eq(Cdr(block_cons),disabled))
7091 error_block_left(Car(block_cons));
7092 /* unwind upto Block-Frame, then jump to its routine for freeing: */
7093 #ifndef FAST_SP
7094 FREE_DYNAMIC_ARRAY(private_SP_space);
7095 #endif
7096 unwind_upto(uTheFramepointer(Cdr(block_cons)));
7097 }
7098 CASE cod_return_from_i: { /* (RETURN-FROM-I k1 k2 n) */
7099 var uintL k1;
7100 var uintL k2;
7101 var uintL n;
7102 U_operand(k1);
7103 U_operand(k2);
7104 U_operand(n);
7105 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
7106 var object block_cons = FRAME_(n);
7107 if (eq(Cdr(block_cons),disabled))
7108 error_block_left(Car(block_cons));
7109 /* unwind upto Block-Frame, then jump to its routine for freeing: */
7110 #ifndef FAST_SP
7111 FREE_DYNAMIC_ARRAY(private_SP_space);
7112 #endif
7113 unwind_upto(uTheFramepointer(Cdr(block_cons)));
7114 }
7115 /* ------------------- (11) TAGBODY ----------------------- */
7116 CASE cod_tagbody_open: { /* (TAGBODY-OPEN n label1 ... labelm) */
7117 /* occupies 3+m STACK-Entries and 1 SP-jmp_buf-Entry and 1 SP-Entry */
7118 var uintL n;
7119 U_operand(n);
7120 /* create Tagbody-Cons: */
7121 var object tagbody_cons;
7122 with_saved_context(tagbody_cons = allocate_cons(););
7123 { /* fill Tagbody-Cons: Tag-Vector (CONST n) as CAR */
7124 var object tag_vector = TheCclosure(closure)->clos_consts[n];
7125 var uintL m = Svector_length(tag_vector);
7126 Car(tagbody_cons) = tag_vector;
7127 get_space_on_STACK(m*sizeof(gcv_object_t)); /* allocate space */
7128 /* push all labeli as Fixnums on the STACK: */
7129 var uintL count;
7130 dotimespL(count,m, {
7131 var const uintB* label_byteptr;
7132 L_operand(label_byteptr);
7133 pushSTACK(fixnum(label_byteptr - CODEPTR));
7134 });
7135 }
7136 /* jump destination in the SP: */
7137 pushSP((aint)closureptr);
7138 { /* build upCTAGBODY-Frame: */
7139 var gcv_object_t* top_of_frame = STACK; /* Pointer above Frame */
7140 pushSTACK(tagbody_cons); /* Cons ( (CONST n) . ...) */
7141 var JMPBUF_on_SP(returner); /* memorize return-point */
7142 finish_entry_frame_1(CTAGBODY,returner, goto tagbody_go; );
7143 }
7144 /* store Framepointer in Tagbody-Cons: */
7145 Cdr(tagbody_cons) = make_framepointer(STACK);
7146 } goto next_byte;
7147 tagbody_go: { /* jump to this label takes place, if the previously
7148 built CTAGBODY-Frame has catched a GO to Label nr. i. */
7149 var uintL m = Svector_length(Car(STACK_2)); /* Number of Labels */
7150 /* (I could also declare the m above as 'auto' and use it here.) */
7151 var uintL i = posfixnum_to_V(value1); /* Number of Labels */
7152 var uintL index = posfixnum_to_V(STACK_((m-i)+3)); /* labeli */
7153 /* get closure back, byteptr:=labeli_byteptr : */
7154 closureptr = (gcv_object_t*) SP_(jmpbufsize+0);
7155 closure = *closureptr; /* fetch Closure from Stack */
7156 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
7157 DEBUG_CHECK_BYTEPTR(CODEPTR + index);
7158 byteptr = CODEPTR + index;
7159 } goto next_byte; /* continue interpretation at Label i */
7160 CASE cod_tagbody_close_nil: /* (TAGBODY-CLOSE-NIL) */
7161 VALUES1(NIL); /* value of Tagbody is NIL */
7162 CASE cod_tagbody_close: /* (TAGBODY-CLOSE) */
7163 /* unwind CTAGBODY-Frame: */
7164 #if STACKCHECKC
7165 if (!(framecode(STACK_0) == CTAGBODY_frame_info))
7166 GOTO_ERROR(error_STACK_putt);
7167 #endif
7168 {
7169 FREE_JMPBUF_on_SP();
7170 var object tagbody_cons = STACK_2; /* Tagbody-Cons */
7171 Cdr(tagbody_cons) = disabled; /* mark as Disabled */
7172 skipSTACK(3+Svector_length(Car(tagbody_cons)));
7173 skipSP(1);
7174 } goto next_byte;
7175 CASE cod_go: { /* (GO n l) */
7176 var uintL n;
7177 var uintL l;
7178 U_operand(n);
7179 U_operand(l);
7180 var object tagbody_cons = /* (CONST n) */
7181 TheCclosure(closure)->clos_consts[n];
7182 if (eq(Cdr(tagbody_cons),disabled)) {
7183 var object tag_vector = Car(tagbody_cons);
7184 pushSTACK(tag_vector);
7185 pushSTACK(TheSvector(tag_vector)->data[l]); /* label l */
7186 pushSTACK(S(go));
7187 error(control_error,GETTEXT("(~S ~S): the tagbody of the tags ~S has already been left"));
7188 }
7189 /* value passed to the Tagbody:
7190 For CTAGBODY-Frames: 1+l as Fixnum,
7191 For ITAGBODY-Frames: the form-list for Tag nr. l. */
7192 var gcv_object_t* FRAME = uTheFramepointer(Cdr(tagbody_cons));
7193 VALUES1(framecode(FRAME_(0)) == CTAGBODY_frame_info
7194 ? fixnum(1+l)
7195 : (object)FRAME_(frame_bindings+2*l+1));
7196 /* unwind upto Tagbody-Frame, then jump to its Routine,
7197 which then jumps to Label l: */
7198 #ifndef FAST_SP
7199 FREE_DYNAMIC_ARRAY(private_SP_space);
7200 #endif
7201 unwind_upto(FRAME);
7202 }
7203 CASE cod_go_i: { /* (GO-I k1 k2 n l) */
7204 var uintL k1;
7205 var uintL k2;
7206 var uintL n;
7207 var uintL l;
7208 U_operand(k1);
7209 U_operand(k2);
7210 U_operand(n);
7211 U_operand(l);
7212 var gcv_object_t* FRAME = (gcv_object_t*) SP_(k1+jmpbufsize*k2);
7213 var object tagbody_cons = FRAME_(n);
7214 if (eq(Cdr(tagbody_cons),disabled)) {
7215 var object tag_vector = Car(tagbody_cons);
7216 pushSTACK(tag_vector);
7217 pushSTACK(TheSvector(tag_vector)->data[l]); /* label l */
7218 pushSTACK(S(go));
7219 error(control_error,GETTEXT("(~S ~S): the tagbody of the tags ~S has already been left"));
7220 }
7221 /* value passed to Tagbody:
7222 For CTAGBODY-Frames 1+l as Fixnum. */
7223 FRAME = uTheFramepointer(Cdr(tagbody_cons));
7224 VALUES1(fixnum(1+l));
7225 /* unwind upto Tagbody-Frame, then jump to its Routine,
7226 which then jumps to Label l: */
7227 #ifndef FAST_SP
7228 FREE_DYNAMIC_ARRAY(private_SP_space);
7229 #endif
7230 unwind_upto(FRAME);
7231 }
7232 /* ------------------- (12) CATCH and THROW ----------------------- */
7233 CASE cod_catch_open: /* (CATCH-OPEN label) */
7234 { /* occupies 3 STACK-Entries and 1 SP-jmp_buf-Entry and 2 SP-Entries */
7235 var const uintB* label_byteptr;
7236 L_operand(label_byteptr);
7237 /* save closureptr, label_byteptr: */
7238 pushSP(label_byteptr - CODEPTR); pushSP((aint)closureptr);
7239 }
7240 { /* build up Frame: */
7241 var gcv_object_t* top_of_frame = STACK;
7242 pushSTACK(value1); /* Tag */
7243 var JMPBUF_on_SP(returner); /* memorize return-point */
7244 finish_entry_frame_1(CATCH,returner, goto catch_return; );
7245 } goto next_byte;
7246 catch_return: { /* jump to this label takes place, if the previoulsy
7247 built Catch-Frame has catched a Throw. */
7248 FREE_JMPBUF_on_SP();
7249 skipSTACK(3); /* unwind CATCH-Frame */
7250 var uintL index;
7251 /* get closure back, byteptr:=label_byteptr : */
7252 popSP(closureptr = (gcv_object_t*) ); popSP(index = );
7253 closure = *closureptr; /* fetch Closure from Stack */
7254 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
7255 DEBUG_CHECK_BYTEPTR(CODEPTR + index);
7256 byteptr = CODEPTR + index;
7257 } goto next_byte; /* continue interpretation at Label */
7258 CASE cod_catch_close: /* (CATCH-CLOSE) */
7259 /* a CATCH-Frame has to come: */
7260 #if STACKCHECKC
7261 if (!(framecode(STACK_0) == CATCH_frame_info))
7262 GOTO_ERROR(error_STACK_putt);
7263 #endif
7264 FREE_JMPBUF_on_SP();
7265 #if STACKCHECKC
7266 if (!(closureptr == (gcv_object_t*)SP_(0))) /* that Closureptr must be the current one */
7267 GOTO_ERROR(error_STACK_putt);
7268 #endif
7269 skipSP(2); skipSTACK(3); /* unwind CATCH-Frame */
7270 goto next_byte;
7271 CASE cod_throw: { /* (THROW) */
7272 var object tag = popSTACK();
7273 throw_to(tag);
7274 pushSTACK(tag);
7275 pushSTACK(S(throw));
7276 error(control_error,GETTEXT("~S: there is no CATCHer for tag ~S"));
7277 }
7278 /* ------------------- (13) UNWIND-PROTECT ----------------------- */
7279 CASE cod_uwp_open: /* (UNWIND-PROTECT-OPEN label) */
7280 { /* occupies 2 STACK-Entries and 1 SP-jmp_buf-Entry and 2 SP-Entries */
7281 var const uintB* label_byteptr;
7282 L_operand(label_byteptr);
7283 /* save closureptr, label_byteptr: */
7284 pushSP(label_byteptr - CODEPTR); pushSP((aint)closureptr);
7285 }
7286 { /* build Frame: */
7287 var gcv_object_t* top_of_frame = STACK;
7288 var JMPBUF_on_SP(returner); /* memorize return-point */
7289 finish_entry_frame_1(UNWIND_PROTECT,returner, goto throw_save; );
7290 } goto next_byte;
7291 throw_save: /* jump to this label takes place, if the previously
7292 built Unwind-Protect-Frame has stopped a Throw.
7293 unwind_protect_to_save is to be saved and jumped to at the end. */
7294 #if STACKCHECKC
7295 if (!(framecode(STACK_0) == UNWIND_PROTECT_frame_info)) {
7296 error(serious_condition,GETTEXT("STACK corrupted"));
7297 }
7298 #endif
7299 /* unwind Frame: */
7300 FREE_JMPBUF_on_SP();
7301 skipSTACK(2);
7302 {
7303 var uintL index;
7304 /* get closure back, byteptr:=label_byteptr : */
7305 popSP(closureptr = (gcv_object_t*) );
7306 popSP(index = );
7307 /* save unwind_protect_to_save: */
7308 pushSP((aint)unwind_protect_to_save.fun);
7309 pushSP((aint)unwind_protect_to_save.upto_frame);
7310 pushSP((aint)STACK); /* push Pointer above Frame additionally on the SP */
7311 /* move all values to the Stack: */
7312 mv_to_STACK();
7313 /* execute Cleanup-Forms: */
7314 closure = *closureptr; /* fetch Closure from Stack */
7315 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
7316 DEBUG_CHECK_BYTEPTR(CODEPTR + index);
7317 byteptr = CODEPTR + index;
7318 } goto next_byte;
7319 CASE cod_uwp_normal_exit: /* (UNWIND-PROTECT-NORMAL-EXIT) */
7320 #if STACKCHECKC
7321 if (!(framecode(STACK_0) == UNWIND_PROTECT_frame_info))
7322 GOTO_ERROR(error_STACK_putt);
7323 if (!(closureptr == (gcv_object_t*)SP_(jmpbufsize+0))) /* that Closureptr must be the current one */
7324 GOTO_ERROR(error_STACK_putt);
7325 #endif
7326 /* unwind Frame:
7327 nothing to do, because closure and byteptr stay unmodified. */
7328 FREE_JMPBUF_on_SP(); skipSP(2);
7329 skipSTACK(2);
7330 /* dummy value for 'unwind_protect_to_save': */
7331 pushSP((aint)NULL); pushSP((aint)NULL); /* NULL,NULL -> uwp_continue */
7332 pushSP((aint)STACK); /* push Pointer above Frame additionally on the SP */
7333 /* move all values to the Stack: */
7334 mv_to_STACK();
7335 /* execute Cleanup-Forms: */
7336 goto next_byte;
7337 CASE cod_uwp_close: /* (UNWIND-PROTECT-CLOSE) */
7338 { /* jump to this label takes place at the end of the Cleanup-Forms. */
7339 var gcv_object_t* oldSTACK; /* value of STACK before saveing the values */
7340 popSP( oldSTACK = (gcv_object_t*) );
7341 var uintL mvcount = /* number of saved values on Stack */
7342 STACK_item_count(STACK,oldSTACK);
7343 if (mvcount >= mv_limit) GOTO_ERROR(error_toomany_values);
7344 STACK_to_mv(mvcount);
7345 }
7346 { /* return to the saved unwind_protect_to_save.fun : */
7347 var restartf_t fun;
7348 var gcv_object_t* arg;
7349 popSP( arg = (gcv_object_t*) ); popSP( fun = (restartf_t) );
7350 /* return to uwp_continue or uwp_jmpback or unwind_upto: */
7351 if (fun != NULL) {
7352 (*fun)(arg); /* return to unwind_upto or similar. */
7353 NOTREACHED;
7354 }
7355 if (arg == (gcv_object_t*)NULL) {
7356 /* uwp_continue:
7357 jump to this label takes place, if after the execution of
7358 the Cleanup-Forms simply interpretation shall continue. */
7359 goto next_byte;
7360 } else {
7361 /* uwp_jmpback:
7362 jump to this label takes place, if after the execution of
7363 the Cleanup-Forms interpretation shall continue at the old
7364 location in the same Closure. */
7365 DEBUG_CHECK_BYTEPTR(CODEPTR + (uintP)arg);
7366 byteptr = CODEPTR + (uintP)arg;
7367 goto next_byte;
7368 }
7369 }
7370 CASE cod_uwp_cleanup: /* (UNWIND-PROTECT-CLEANUP) */
7371 /* this is executed, if within the same Closure an execution
7372 of the Cleanup-Code is necessary. */
7373 #if STACKCHECKC
7374 if (!(framecode(STACK_0) == UNWIND_PROTECT_frame_info))
7375 GOTO_ERROR(error_STACK_putt);
7376 if (!(closureptr == (gcv_object_t*)SP_(jmpbufsize+0))) /* that Closureptr must be the current one */
7377 GOTO_ERROR(error_STACK_putt);
7378 #endif
7379 { /* closure remains, byteptr:=label_byteptr : */
7380 var uintL index = SP_(jmpbufsize+1);
7381 /* unwind Frame: */
7382 FREE_JMPBUF_on_SP(); skipSP(2);
7383 skipSTACK(2);
7384 /* Dummy-values for 'unwind_protect_to_save': */
7385 pushSP((aint)NULL); /* NULL -> uwp_jmpback */
7386 pushSP(byteptr - CODEPTR);
7387 pushSP((aint)STACK); /* push Pointer above Frame additionally on the SP */
7388 /* move all values to the Stack: */
7389 mv_to_STACK();
7390 /* execute Cleanup-Forms: */
7391 DEBUG_CHECK_BYTEPTR(CODEPTR + index);
7392 byteptr = CODEPTR + index;
7393 } goto next_byte;
7394 /* ------------------- (14) HANDLER-BIND ----------------------- */
7395 CASE cod_handler_open: { /* (HANDLER-OPEN n) */
7396 /* occupies 4 STACK-Entries */
7397 var uintL n;
7398 U_operand(n);
7399 /* build up Frame: */
7400 var gcv_object_t* top_of_frame = STACK; /* Pointer above Frame */
7401 pushSTACK(TheCclosure(closure)->clos_consts[n]);
7402 pushSTACK(closure);
7403 pushSTACK(fake_gcv_object((aint)(_SP_(0))));
7404 finish_frame(HANDLER);
7405 } goto next_byte;
7406 CASE cod_handler_begin_push: /* (HANDLER-BEGIN&PUSH) */
7407 /* builds up SP newly, occupies 1 SP-Entry and
7408 starts a new STACK-Region. */
7409 {
7410 var uintL count = (uintL)posfixnum_to_V(Car(handler_args.spdepth))
7411 + jmpbufsize * (uintL)posfixnum_to_V(Cdr(handler_args.spdepth));
7412 if (count > 0) {
7413 var SPint* oldsp = handler_args.sp; /* was formerly &SP_(0) */
7414 /* copy oldsp[0..count-1] to the current SP: */
7415 oldsp skipSPop count;
7416 dotimespL(count,count, { oldsp skipSPop -1; pushSP(*oldsp); } );
7417 }
7418 }
7419 pushSP((aint)handler_args.stack); /* Pointer above Handler-Frame */
7420 VALUES1(handler_args.condition);
7421 pushSTACK(value1);
7422 goto next_byte;
7423 /* ------------------- (15) a few Functions ----------------------- */
7424 CASE cod_not: /* (NOT) */
7425 if (nullp(value1)) goto code_t; else goto code_nil;
7426 CASE cod_eq: /* (EQ) */
7427 if (!eq(value1,popSTACK())) goto code_nil; else goto code_t;
7428 CASE cod_car: { /* (CAR) */
7429 var object arg = value1;
7430 if (consp(arg)) {
7431 value1 = Car(arg); /* CAR of a Cons */
7432 } else if (nullp(arg)) {
7433 /* (CAR NIL) = NIL: value1 remains NIL */
7434 } else
7435 with_saved_back_trace_subr(L(car),STACK STACKop -1,-1,
7436 error_list(arg); );
7437 mv_count=1;
7438 } goto next_byte;
7439 CASE cod_car_push: { /* (CAR&PUSH) */
7440 var object arg = value1;
7441 if (consp(arg)) {
7442 pushSTACK(Car(arg)); /* CAR of a Cons */
7443 } else if (nullp(arg)) {
7444 pushSTACK(arg); /* (CAR NIL) = NIL */
7445 } else
7446 with_saved_back_trace_subr(L(car),STACK STACKop -1,-1,
7447 error_list(arg); );
7448 } goto next_byte;
7449 CASE cod_load_car_push: { /* (LOAD&CAR&PUSH n) */
7450 var uintL n;
7451 U_operand(n);
7452 var object arg = STACK_(n);
7453 if (consp(arg)) {
7454 pushSTACK(Car(arg)); /* CAR of a Cons */
7455 } else if (nullp(arg)) {
7456 pushSTACK(arg); /* (CAR NIL) = NIL */
7457 } else
7458 with_saved_back_trace_subr(L(car),STACK STACKop -1,-1,
7459 error_list(arg); );
7460 } goto next_byte;
7461 CASE cod_load_car_store: { /* (LOAD&CAR&STORE m n) */
7462 var uintL m;
7463 var uintL n;
7464 U_operand(m);
7465 U_operand(n);
7466 var object arg = STACK_(m);
7467 if (consp(arg)) {
7468 STACK_(n) = value1 = Car(arg); /* CAR of a Cons */
7469 } else if (nullp(arg)) {
7470 STACK_(n) = value1 = arg; /* (CAR NIL) = NIL */
7471 } else
7472 with_saved_back_trace_subr(L(car),STACK STACKop -1,-1,
7473 error_list(arg); );
7474 mv_count=1;
7475 } goto next_byte;
7476 CASE cod_cdr: { /* (CDR) */
7477 var object arg = value1;
7478 if (consp(arg)) {
7479 value1 = Cdr(arg); /* CDR of a Cons */
7480 } else if (nullp(arg)) {
7481 /* (CDR NIL) = NIL: value1 remains NIL */
7482 } else
7483 with_saved_back_trace_subr(L(cdr),STACK STACKop -1,-1,
7484 error_list(arg); );
7485 mv_count=1;
7486 } goto next_byte;
7487 CASE cod_cdr_push: { /* (CDR&PUSH) */
7488 var object arg = value1;
7489 if (consp(arg)) {
7490 pushSTACK(Cdr(arg)); /* CDR of a Cons */
7491 } else if (nullp(arg)) {
7492 pushSTACK(arg); /* (CDR NIL) = NIL */
7493 } else
7494 with_saved_back_trace_subr(L(cdr),STACK STACKop -1,-1,
7495 error_list(arg); );
7496 } goto next_byte;
7497 CASE cod_load_cdr_push: { /* (LOAD&CDR&PUSH n) */
7498 var uintL n;
7499 U_operand(n);
7500 var object arg = STACK_(n);
7501 if (consp(arg)) {
7502 pushSTACK(Cdr(arg)); /* CDR of a Cons */
7503 } else if (nullp(arg)) {
7504 pushSTACK(arg); /* (CDR NIL) = NIL */
7505 } else
7506 with_saved_back_trace_subr(L(cdr),STACK STACKop -1,-1,
7507 error_list(arg); );
7508 } goto next_byte;
7509 CASE cod_load_cdr_store: { /* (LOAD&CDR&STORE n) */
7510 var uintL n;
7511 U_operand(n);
7512 var gcv_object_t* arg_ = &STACK_(n);
7513 var object arg = *arg_;
7514 if (consp(arg)) {
7515 *arg_ = value1 = Cdr(arg); /* CDR of a Cons */
7516 } else if (nullp(arg)) {
7517 value1 = arg; /* (CDR NIL) = NIL */
7518 } else
7519 with_saved_back_trace_subr(L(cdr),STACK STACKop -1,-1,
7520 error_list(arg); );
7521 mv_count=1;
7522 } goto next_byte;
7523 CASE cod_cons: { /* (CONS) */
7524 pushSTACK(value1);
7525 /* request Cons: */
7526 var object new_cons;
7527 with_saved_context( { new_cons = allocate_cons(); } );
7528 /* fill Cons: */
7529 Cdr(new_cons) = popSTACK();
7530 Car(new_cons) = popSTACK();
7531 VALUES1(new_cons);
7532 } goto next_byte;
7533 CASE cod_cons_push: { /* (CONS&PUSH) */
7534 pushSTACK(value1);
7535 /* request Cons: */
7536 var object new_cons;
7537 with_saved_context( { new_cons = allocate_cons(); } );
7538 /* fill Cons: */
7539 Cdr(new_cons) = popSTACK();
7540 Car(new_cons) = STACK_0;
7541 STACK_0 = new_cons;
7542 } goto next_byte;
7543 CASE cod_load_cons_store: { /* (LOAD&CONS&STORE n) */
7544 var uintL n;
7545 U_operand(n);
7546 /* request Cons: */
7547 var object new_cons;
7548 with_saved_context( { new_cons = allocate_cons(); } );
7549 /* fill Cons: */
7550 Car(new_cons) = popSTACK();
7551 var gcv_object_t* arg_ = &STACK_(n);
7552 Cdr(new_cons) = *arg_;
7553 VALUES1(*arg_ = new_cons);
7554 } goto next_byte;
7555 {var object symbol;
7556 var object fdef;
7557 #define CHECK_FDEF() \
7558 if (!symbolp(symbol)) \
7559 with_saved_back_trace_subr(L(symbol_function),STACK STACKop -1,-1, \
7560 symbol = check_symbol(symbol); ); \
7561 fdef = Symbol_function(symbol); \
7562 if (!boundp(fdef)) \
7563 /* (symbol may be not the actual function-name, for e.g. \
7564 (FUNCTION (SETF FOO)) shows as (SYMBOL-FUNCTION '#:|(SETF FOO)|),\
7565 but that should be enough for the error message.) */ \
7566 fdef = check_fdefinition(symbol,S(symbol_function))
7567 CASE cod_symbol_function: /* (SYMBOL-FUNCTION) */
7568 symbol = value1;
7569 CHECK_FDEF();
7570 VALUES1(fdef);
7571 goto next_byte;
7572 CASE cod_const_symbol_function: { /* (CONST&SYMBOL-FUNCTION n) */
7573 var uintL n;
7574 U_operand(n);
7575 symbol = TheCclosure(closure)->clos_consts[n];
7576 } CHECK_FDEF();
7577 VALUES1(fdef);
7578 goto next_byte;
7579 CASE cod_const_symbol_function_push: { /* (CONST&SYMBOL-FUNCTION&PUSH n) */
7580 var uintL n;
7581 U_operand(n);
7582 symbol = TheCclosure(closure)->clos_consts[n];
7583 } CHECK_FDEF();
7584 pushSTACK(fdef);
7585 goto next_byte;
7586 CASE cod_const_symbol_function_store: { /* (CONST&SYMBOL-FUNCTION&STORE n k) */
7587 var uintL n;
7588 U_operand(n);
7589 symbol = TheCclosure(closure)->clos_consts[n];
7590 } CHECK_FDEF(); {
7591 var uintL k;
7592 U_operand(k);
7593 STACK_(k) = value1 = fdef; mv_count=1;
7594 } goto next_byte;
7595 }
7596 {var object vec; var object index;
7597 CASE cod_svref: /* (SVREF) */
7598 /* STACK_0 must be a Simple-Vector: */
7599 if (!simple_vector_p(STACK_0)) goto svref_not_a_svector;
7600 vec = popSTACK(); /* Simple-Vector */
7601 index = value1;
7602 { /* and the Index must be Fixnum >= 0, < length(vec) : */
7603 var uintV i;
7604 if (!(posfixnump(index)
7605 && ((i = posfixnum_to_V(index)) < Svector_length(vec))))
7606 goto svref_not_an_index;
7607 VALUES1(TheSvector(vec)->data[i]); /* indexed Element as value */
7608 } goto next_byte;
7609 CASE cod_svset: /* (SVSET) */
7610 /* STACK_0 must be a Simple-Vector: */
7611 if (!simple_vector_p(STACK_0)) goto svref_not_a_svector;
7612 vec = popSTACK(); /* Simple-Vector */
7613 index = value1;
7614 { /* and the Index must be a Fixnum >=0, <Length(vec) : */
7615 var uintV i;
7616 if (!(posfixnump(index)
7617 && ((i = posfixnum_to_V(index)) < Svector_length(vec))))
7618 goto svref_not_an_index;
7619 VALUES1(TheSvector(vec)->data[i] = popSTACK()); /* put in new element */
7620 } goto next_byte;
7621 svref_not_a_svector: /* Non-Simple-Vector in STACK_0 */
7622 { error_no_svector(S(svref),STACK_0); }
7623 svref_not_an_index: /* unsuitable Index in index, for Vector vec */
7624 pushSTACK(vec);
7625 pushSTACK(index);
7626 pushSTACK(index); /* TYPE-ERROR slot DATUM */
7627 {
7628 var object tmp;
7629 pushSTACK(S(integer)); pushSTACK(Fixnum_0); pushSTACK(UL_to_I(Svector_length(vec)));
7630 tmp = listof(1); pushSTACK(tmp); tmp = listof(3);
7631 pushSTACK(tmp); /* TYPE-ERROR slot EXPECTED-TYPE */
7632 }
7633 pushSTACK(STACK_(1+2)); /* vec */
7634 pushSTACK(STACK_(0+3)); /* index */
7635 pushSTACK(S(svref));
7636 error(type_error,GETTEXT("~S: ~S is not a correct index into ~S"));
7637 }
7638 CASE cod_list: { /* (LIST n) */
7639 var uintC n;
7640 U_operand(n);
7641 with_saved_context( { value1 = listof(n); mv_count=1; } );
7642 } goto next_byte;
7643 CASE cod_list_push: { /* (LIST&PUSH n) */
7644 var uintC n;
7645 U_operand(n);
7646 with_saved_context( { object res = listof(n); pushSTACK(res); } );
7647 } goto next_byte;
7648 CASE cod_liststar: { /* (LIST* n) */
7649 var uintC n;
7650 U_operand(n);
7651 with_saved_context({
7652 pushSTACK(value1);
7653 dotimespC(n,n, {
7654 var object new_cons = allocate_cons();
7655 Cdr(new_cons) = popSTACK();
7656 Car(new_cons) = STACK_0;
7657 STACK_0 = new_cons;
7658 });
7659 value1 = popSTACK(); mv_count=1;
7660 });
7661 } goto next_byte;
7662 CASE cod_liststar_push: { /* (LIST*&PUSH n) */
7663 var uintC n;
7664 U_operand(n);
7665 with_saved_context({
7666 pushSTACK(value1);
7667 dotimespC(n,n, {
7668 var object new_cons = allocate_cons();
7669 Cdr(new_cons) = popSTACK();
7670 Car(new_cons) = STACK_0;
7671 STACK_0 = new_cons;
7672 });
7673 });
7674 } goto next_byte;
7675 /* ------------------- (16) combined Operations ----------------------- */
7676 CASE cod_nil_store: { /* (NIL&STORE n) */
7677 var uintL n;
7678 U_operand(n);
7679 STACK_(n) = value1 = NIL; mv_count=1;
7680 } goto next_byte;
7681 CASE cod_t_store: { /* (T&STORE n) */
7682 var uintL n;
7683 U_operand(n);
7684 STACK_(n) = value1 = T; mv_count=1;
7685 } goto next_byte;
7686 CASE cod_calls1_store: /* (CALLS1&STORE n k) */
7687 CALLS1();
7688 goto store;
7689 CASE cod_calls2_store: /* (CALLS2&STORE n k) */
7690 CALLS2();
7691 goto store;
7692 CASE cod_callsr_store: /* (CALLSR&STORE m n k) */
7693 CALLSR();
7694 goto store;
7695 /* Increment. Optimized specifically for Fixnums >=0. */
7696 #define INC(arg,statement) \
7697 { if (posfixnump(arg) /* Fixnum >= 0 and < most-positive-fixnum ? */ \
7698 && !eq(arg,fixnum(vbitm(oint_data_len)-1))) { \
7699 arg = fixnum_inc(arg,1); statement; \
7700 } else { \
7701 with_saved_context( \
7702 /* funcall(L(plus_one),1): */ \
7703 pushSTACK(arg); \
7704 with_saved_back_trace_subr(L(plus_one),STACK,1, \
7705 { C_plus_one(); }); \
7706 ); \
7707 arg = value1; \
7708 } \
7709 }
7710 /* Decrement. Optimized specifically for Fixnums >=0. */
7711 #define DEC(arg,statement) \
7712 { if (posfixnump(arg) && !eq(arg,Fixnum_0)) { /* Fixnum > 0 ? */ \
7713 arg = fixnum_inc(arg,-1); statement; \
7714 } else { \
7715 with_saved_context( \
7716 /* funcall(L(minus_one),1): */ \
7717 pushSTACK(arg); \
7718 with_saved_back_trace_subr(L(minus_one),STACK,1, \
7719 { C_minus_one(); }); \
7720 ); \
7721 arg = value1; \
7722 } \
7723 }
7724 CASE cod_load_inc_push: { /* (LOAD&INC&PUSH n) */
7725 var uintL n;
7726 U_operand(n);
7727 var object arg = STACK_(n);
7728 INC(arg,); /* increment */
7729 pushSTACK(arg);
7730 } goto next_byte;
7731 CASE cod_load_inc_store: { /* (LOAD&INC&STORE n) */
7732 var uintL n;
7733 U_operand(n);
7734 var gcv_object_t* arg_ = &STACK_(n);
7735 var object arg = *arg_;
7736 INC(arg,mv_count=1); /* increment, one value */
7737 value1 = *arg_ = arg;
7738 } goto next_byte;
7739 CASE cod_load_dec_push: { /* (LOAD&DEC&PUSH n) */
7740 var uintL n;
7741 U_operand(n);
7742 var object arg = STACK_(n);
7743 DEC(arg,); /* decrement */
7744 pushSTACK(arg);
7745 } goto next_byte;
7746 CASE cod_load_dec_store: { /* (LOAD&DEC&STORE n) */
7747 var uintL n;
7748 U_operand(n);
7749 var gcv_object_t* arg_ = &STACK_(n);
7750 var object arg = *arg_;
7751 DEC(arg,mv_count=1); /* decrement, one value */
7752 value1 = *arg_ = arg;
7753 } goto next_byte;
7754 CASE cod_call1_jmpif: /* (CALL1&JMPIF n label) */
7755 CALL1();
7756 if (!nullp(value1)) goto jmp; else goto notjmp;
7757 CASE cod_call1_jmpifnot: /* (CALL1&JMPIFNOT n label) */
7758 CALL1();
7759 if (nullp(value1)) goto jmp; else goto notjmp;
7760 CASE cod_call2_jmpif: /* (CALL2&JMPIF n label) */
7761 CALL2();
7762 if (!nullp(value1)) goto jmp; else goto notjmp;
7763 CASE cod_call2_jmpifnot: /* (CALL2&JMPIFNOT n label) */
7764 CALL2();
7765 if (nullp(value1)) goto jmp; else goto notjmp;
7766 CASE cod_calls1_jmpif: /* (CALLS1&JMPIF n label) */
7767 CALLS1();
7768 if (!nullp(value1)) goto jmp; else goto notjmp;
7769 CASE cod_calls1_jmpifnot: /* (CALLS1&JMPIFNOT n label) */
7770 CALLS1();
7771 if (nullp(value1)) goto jmp; else goto notjmp;
7772 CASE cod_calls2_jmpif: /* (CALLS2&JMPIF n label) */
7773 CALLS2();
7774 if (!nullp(value1)) goto jmp; else goto notjmp;
7775 CASE cod_calls2_jmpifnot: /* (CALLS2&JMPIFNOT n label) */
7776 CALLS2();
7777 if (nullp(value1)) goto jmp; else goto notjmp;
7778 CASE cod_callsr_jmpif: /* (CALLSR&JMPIF m n label) */
7779 CALLSR();
7780 if (!nullp(value1)) goto jmp; else goto notjmp;
7781 CASE cod_callsr_jmpifnot: /* (CALLSR&JMPIFNOT m n label) */
7782 CALLSR();
7783 if (nullp(value1)) goto jmp; else goto notjmp;
7784 CASE cod_load_jmpif: { /* (LOAD&JMPIF n label) */
7785 var uintL n;
7786 U_operand(n);
7787 mv_count=1;
7788 if (!nullp(value1 = STACK_(n))) goto jmp; else goto notjmp;
7789 }
7790 CASE cod_load_jmpifnot: { /* (LOAD&JMPIFNOT n label) */
7791 var uintL n;
7792 U_operand(n);
7793 mv_count=1;
7794 if (nullp(value1 = STACK_(n))) goto jmp; else goto notjmp;
7795 }
7796 CASE cod_apply_skip_ret: { /* (APPLY&SKIP&RET n k) */
7797 var uintL n;
7798 var uintL k;
7799 U_operand(n);
7800 U_operand(k);
7801 var object fun = STACK_(n); /* Function */
7802 with_saved_context({
7803 apply(fun,n,value1); /* call Function */
7804 skipSTACK(k+1); /* discard Function and others from Stack */
7805 goto finished; /* return (jump) to caller */
7806 }); /* the context is not restored */
7807 }
7808 CASE cod_funcall_skip_retgf: { /* (FUNCALL&SKIP&RETGF n k) */
7809 var uintL n;
7810 var uintL k;
7811 U_operand(n);
7812 U_operand(k);
7813 var object fun = STACK_(n); /* Function */
7814 var uintL r = ((Codevec)codeptr)->ccv_numreq;
7815 var uintB flags = ((Codevec)codeptr)->ccv_flags;
7816 with_saved_context({
7817 funcall(fun,n); /* call Function */
7818 if (flags & bit(3)) { /* call inhibition? */
7819 skipSTACK(k+1);
7820 mv_count=1;
7821 goto finished; /* return (jump) to caller */
7822 }
7823 k -= r;
7824 if (flags & bit(0)) {
7825 skipSTACK(k); apply(value1,r,popSTACK());
7826 } else {
7827 skipSTACK(k+1); funcall(value1,r);
7828 }
7829 goto finished; /* return (jump) to caller */
7830 }); /* the context is not restored */
7831 }
7832 /* ------------------- (17) short codes ----------------------- */
7833 CASE cod_load0: /* (LOAD.S 0) */
7834 VALUES1(STACK_(0));
7835 goto next_byte;
7836 CASE cod_load1: /* (LOAD.S 1) */
7837 VALUES1(STACK_(1));
7838 goto next_byte;
7839 CASE cod_load2: /* (LOAD.S 2) */
7840 VALUES1(STACK_(2));
7841 goto next_byte;
7842 CASE cod_load3: /* (LOAD.S 3) */
7843 VALUES1(STACK_(3));
7844 goto next_byte;
7845 CASE cod_load4: /* (LOAD.S 4) */
7846 VALUES1(STACK_(4));
7847 goto next_byte;
7848 CASE cod_load5: /* (LOAD.S 5) */
7849 VALUES1(STACK_(5));
7850 goto next_byte;
7851 CASE cod_load6: /* (LOAD.S 6) */
7852 VALUES1(STACK_(6));
7853 goto next_byte;
7854 CASE cod_load7: /* (LOAD.S 7) */
7855 VALUES1(STACK_(7));
7856 goto next_byte;
7857 CASE cod_load8: /* (LOAD.S 8) */
7858 VALUES1(STACK_(8));
7859 goto next_byte;
7860 CASE cod_load9: /* (LOAD.S 9) */
7861 VALUES1(STACK_(9));
7862 goto next_byte;
7863 CASE cod_load10: /* (LOAD.S 10) */
7864 VALUES1(STACK_(10));
7865 goto next_byte;
7866 CASE cod_load11: /* (LOAD.S 11) */
7867 VALUES1(STACK_(11));
7868 goto next_byte;
7869 CASE cod_load12: /* (LOAD.S 12) */
7870 VALUES1(STACK_(12));
7871 goto next_byte;
7872 CASE cod_load13: /* (LOAD.S 13) */
7873 VALUES1(STACK_(13));
7874 goto next_byte;
7875 CASE cod_load14: /* (LOAD.S 14) */
7876 VALUES1(STACK_(14));
7877 goto next_byte;
7878 #if 0
7879 CASE cod_load15: /* (LOAD.S 15) */
7880 VALUES1(STACK_(15));
7881 goto next_byte;
7882 CASE cod_load16: /* (LOAD.S 16) */
7883 VALUES1(STACK_(16));
7884 goto next_byte;
7885 CASE cod_load17: /* (LOAD.S 17) */
7886 VALUES1(STACK_(17));
7887 goto next_byte;
7888 CASE cod_load18: /* (LOAD.S 18) */
7889 VALUES1(STACK_(18));
7890 goto next_byte;
7891 CASE cod_load19: /* (LOAD.S 19) */
7892 VALUES1(STACK_(19));
7893 goto next_byte;
7894 CASE cod_load20: /* (LOAD.S 20) */
7895 VALUES1(STACK_(20));
7896 goto next_byte;
7897 CASE cod_load21: /* (LOAD.S 21) */
7898 VALUES1(STACK_(21));
7899 goto next_byte;
7900 #endif
7901 CASE cod_load_push0: /* (LOAD&PUSH.S 0) */
7902 pushSTACK(STACK_(0));
7903 goto next_byte;
7904 CASE cod_load_push1: /* (LOAD&PUSH.S 1) */
7905 pushSTACK(STACK_(1));
7906 goto next_byte;
7907 CASE cod_load_push2: /* (LOAD&PUSH.S 2) */
7908 pushSTACK(STACK_(2));
7909 goto next_byte;
7910 CASE cod_load_push3: /* (LOAD&PUSH.S 3) */
7911 pushSTACK(STACK_(3));
7912 goto next_byte;
7913 CASE cod_load_push4: /* (LOAD&PUSH.S 4) */
7914 pushSTACK(STACK_(4));
7915 goto next_byte;
7916 CASE cod_load_push5: /* (LOAD&PUSH.S 5) */
7917 pushSTACK(STACK_(5));
7918 goto next_byte;
7919 CASE cod_load_push6: /* (LOAD&PUSH.S 6) */
7920 pushSTACK(STACK_(6));
7921 goto next_byte;
7922 CASE cod_load_push7: /* (LOAD&PUSH.S 7) */
7923 pushSTACK(STACK_(7));
7924 goto next_byte;
7925 CASE cod_load_push8: /* (LOAD&PUSH.S 8) */
7926 pushSTACK(STACK_(8));
7927 goto next_byte;
7928 CASE cod_load_push9: /* (LOAD&PUSH.S 9) */
7929 pushSTACK(STACK_(9));
7930 goto next_byte;
7931 CASE cod_load_push10: /* (LOAD&PUSH.S 10) */
7932 pushSTACK(STACK_(10));
7933 goto next_byte;
7934 CASE cod_load_push11: /* (LOAD&PUSH.S 11) */
7935 pushSTACK(STACK_(11));
7936 goto next_byte;
7937 CASE cod_load_push12: /* (LOAD&PUSH.S 12) */
7938 pushSTACK(STACK_(12));
7939 goto next_byte;
7940 CASE cod_load_push13: /* (LOAD&PUSH.S 13) */
7941 pushSTACK(STACK_(13));
7942 goto next_byte;
7943 CASE cod_load_push14: /* (LOAD&PUSH.S 14) */
7944 pushSTACK(STACK_(14));
7945 goto next_byte;
7946 CASE cod_load_push15: /* (LOAD&PUSH.S 15) */
7947 pushSTACK(STACK_(15));
7948 goto next_byte;
7949 CASE cod_load_push16: /* (LOAD&PUSH.S 16) */
7950 pushSTACK(STACK_(16));
7951 goto next_byte;
7952 CASE cod_load_push17: /* (LOAD&PUSH.S 17) */
7953 pushSTACK(STACK_(17));
7954 goto next_byte;
7955 CASE cod_load_push18: /* (LOAD&PUSH.S 18) */
7956 pushSTACK(STACK_(18));
7957 goto next_byte;
7958 CASE cod_load_push19: /* (LOAD&PUSH.S 19) */
7959 pushSTACK(STACK_(19));
7960 goto next_byte;
7961 CASE cod_load_push20: /* (LOAD&PUSH.S 20) */
7962 pushSTACK(STACK_(20));
7963 goto next_byte;
7964 CASE cod_load_push21: /* (LOAD&PUSH.S 21) */
7965 pushSTACK(STACK_(21));
7966 goto next_byte;
7967 CASE cod_load_push22: /* (LOAD&PUSH.S 22) */
7968 pushSTACK(STACK_(22));
7969 goto next_byte;
7970 CASE cod_load_push23: /* (LOAD&PUSH.S 23) */
7971 pushSTACK(STACK_(23));
7972 goto next_byte;
7973 CASE cod_load_push24: /* (LOAD&PUSH.S 24) */
7974 pushSTACK(STACK_(24));
7975 goto next_byte;
7976 CASE cod_const0: /* (CONST.S 0) */
7977 VALUES1(TheCclosure(closure)->clos_consts[0]);
7978 goto next_byte;
7979 CASE cod_const1: /* (CONST.S 1) */
7980 VALUES1(TheCclosure(closure)->clos_consts[1]);
7981 goto next_byte;
7982 CASE cod_const2: /* (CONST.S 2) */
7983 VALUES1(TheCclosure(closure)->clos_consts[2]);
7984 goto next_byte;
7985 CASE cod_const3: /* (CONST.S 3) */
7986 VALUES1(TheCclosure(closure)->clos_consts[3]);
7987 goto next_byte;
7988 CASE cod_const4: /* (CONST.S 4) */
7989 VALUES1(TheCclosure(closure)->clos_consts[4]);
7990 goto next_byte;
7991 CASE cod_const5: /* (CONST.S 5) */
7992 VALUES1(TheCclosure(closure)->clos_consts[5]);
7993 goto next_byte;
7994 CASE cod_const6: /* (CONST.S 6) */
7995 VALUES1(TheCclosure(closure)->clos_consts[6]);
7996 goto next_byte;
7997 CASE cod_const7: /* (CONST.S 7) */
7998 VALUES1(TheCclosure(closure)->clos_consts[7]);
7999 goto next_byte;
8000 CASE cod_const8: /* (CONST.S 8) */
8001 VALUES1(TheCclosure(closure)->clos_consts[8]);
8002 goto next_byte;
8003 CASE cod_const9: /* (CONST.S 9) */
8004 VALUES1(TheCclosure(closure)->clos_consts[9]);
8005 goto next_byte;
8006 CASE cod_const10: /* (CONST.S 10) */
8007 VALUES1(TheCclosure(closure)->clos_consts[10]);
8008 goto next_byte;
8009 CASE cod_const11: /* (CONST.S 11) */
8010 VALUES1(TheCclosure(closure)->clos_consts[11]);
8011 goto next_byte;
8012 CASE cod_const12: /* (CONST.S 12) */
8013 VALUES1(TheCclosure(closure)->clos_consts[12]);
8014 goto next_byte;
8015 CASE cod_const13: /* (CONST.S 13) */
8016 VALUES1(TheCclosure(closure)->clos_consts[13]);
8017 goto next_byte;
8018 CASE cod_const14: /* (CONST.S 14) */
8019 VALUES1(TheCclosure(closure)->clos_consts[14]);
8020 goto next_byte;
8021 CASE cod_const15: /* (CONST.S 15) */
8022 VALUES1(TheCclosure(closure)->clos_consts[15]);
8023 goto next_byte;
8024 CASE cod_const16: /* (CONST.S 16) */
8025 VALUES1(TheCclosure(closure)->clos_consts[16]);
8026 goto next_byte;
8027 CASE cod_const17: /* (CONST.S 17) */
8028 VALUES1(TheCclosure(closure)->clos_consts[17]);
8029 goto next_byte;
8030 CASE cod_const18: /* (CONST.S 18) */
8031 VALUES1(TheCclosure(closure)->clos_consts[18]);
8032 goto next_byte;
8033 CASE cod_const19: /* (CONST.S 19) */
8034 VALUES1(TheCclosure(closure)->clos_consts[19]);
8035 goto next_byte;
8036 CASE cod_const20: /* (CONST.S 20) */
8037 VALUES1(TheCclosure(closure)->clos_consts[20]);
8038 goto next_byte;
8039 #if 0
8040 CASE cod_const21: /* (CONST.S 21) */
8041 VALUES1(TheCclosure(closure)->clos_consts[21]);
8042 goto next_byte;
8043 CASE cod_const22: /* (CONST.S 22) */
8044 VALUES1(TheCclosure(closure)->clos_consts[22]);
8045 goto next_byte;
8046 CASE cod_const23: /* (CONST.S 23) */
8047 VALUES1(TheCclosure(closure)->clos_consts[23]);
8048 goto next_byte;
8049 CASE cod_const24: /* (CONST.S 24) */
8050 VALUES1(TheCclosure(closure)->clos_consts[24]);
8051 goto next_byte;
8052 #endif
8053 CASE cod_const_push0: /* (CONST&PUSH.S 0) */
8054 pushSTACK(TheCclosure(closure)->clos_consts[0]);
8055 goto next_byte;
8056 CASE cod_const_push1: /* (CONST&PUSH.S 1) */
8057 pushSTACK(TheCclosure(closure)->clos_consts[1]);
8058 goto next_byte;
8059 CASE cod_const_push2: /* (CONST&PUSH.S 2) */
8060 pushSTACK(TheCclosure(closure)->clos_consts[2]);
8061 goto next_byte;
8062 CASE cod_const_push3: /* (CONST&PUSH.S 3) */
8063 pushSTACK(TheCclosure(closure)->clos_consts[3]);
8064 goto next_byte;
8065 CASE cod_const_push4: /* (CONST&PUSH.S 4) */
8066 pushSTACK(TheCclosure(closure)->clos_consts[4]);
8067 goto next_byte;
8068 CASE cod_const_push5: /* (CONST&PUSH.S 5) */
8069 pushSTACK(TheCclosure(closure)->clos_consts[5]);
8070 goto next_byte;
8071 CASE cod_const_push6: /* (CONST&PUSH.S 6) */
8072 pushSTACK(TheCclosure(closure)->clos_consts[6]);
8073 goto next_byte;
8074 CASE cod_const_push7: /* (CONST&PUSH.S 7) */
8075 pushSTACK(TheCclosure(closure)->clos_consts[7]);
8076 goto next_byte;
8077 CASE cod_const_push8: /* (CONST&PUSH.S 8) */
8078 pushSTACK(TheCclosure(closure)->clos_consts[8]);
8079 goto next_byte;
8080 CASE cod_const_push9: /* (CONST&PUSH.S 9) */
8081 pushSTACK(TheCclosure(closure)->clos_consts[9]);
8082 goto next_byte;
8083 CASE cod_const_push10: /* (CONST&PUSH.S 10) */
8084 pushSTACK(TheCclosure(closure)->clos_consts[10]);
8085 goto next_byte;
8086 CASE cod_const_push11: /* (CONST&PUSH.S 11) */
8087 pushSTACK(TheCclosure(closure)->clos_consts[11]);
8088 goto next_byte;
8089 CASE cod_const_push12: /* (CONST&PUSH.S 12) */
8090 pushSTACK(TheCclosure(closure)->clos_consts[12]);
8091 goto next_byte;
8092 CASE cod_const_push13: /* (CONST&PUSH.S 13) */
8093 pushSTACK(TheCclosure(closure)->clos_consts[13]);
8094 goto next_byte;
8095 CASE cod_const_push14: /* (CONST&PUSH.S 14) */
8096 pushSTACK(TheCclosure(closure)->clos_consts[14]);
8097 goto next_byte;
8098 CASE cod_const_push15: /* (CONST&PUSH.S 15) */
8099 pushSTACK(TheCclosure(closure)->clos_consts[15]);
8100 goto next_byte;
8101 CASE cod_const_push16: /* (CONST&PUSH.S 16) */
8102 pushSTACK(TheCclosure(closure)->clos_consts[16]);
8103 goto next_byte;
8104 CASE cod_const_push17: /* (CONST&PUSH.S 17) */
8105 pushSTACK(TheCclosure(closure)->clos_consts[17]);
8106 goto next_byte;
8107 CASE cod_const_push18: /* (CONST&PUSH.S 18) */
8108 pushSTACK(TheCclosure(closure)->clos_consts[18]);
8109 goto next_byte;
8110 CASE cod_const_push19: /* (CONST&PUSH.S 19) */
8111 pushSTACK(TheCclosure(closure)->clos_consts[19]);
8112 goto next_byte;
8113 CASE cod_const_push20: /* (CONST&PUSH.S 20) */
8114 pushSTACK(TheCclosure(closure)->clos_consts[20]);
8115 goto next_byte;
8116 CASE cod_const_push21: /* (CONST&PUSH.S 21) */
8117 pushSTACK(TheCclosure(closure)->clos_consts[21]);
8118 goto next_byte;
8119 CASE cod_const_push22: /* (CONST&PUSH.S 22) */
8120 pushSTACK(TheCclosure(closure)->clos_consts[22]);
8121 goto next_byte;
8122 CASE cod_const_push23: /* (CONST&PUSH.S 23) */
8123 pushSTACK(TheCclosure(closure)->clos_consts[23]);
8124 goto next_byte;
8125 CASE cod_const_push24: /* (CONST&PUSH.S 24) */
8126 pushSTACK(TheCclosure(closure)->clos_consts[24]);
8127 goto next_byte;
8128 CASE cod_const_push25: /* (CONST&PUSH.S 25) */
8129 pushSTACK(TheCclosure(closure)->clos_consts[25]);
8130 goto next_byte;
8131 CASE cod_const_push26: /* (CONST&PUSH.S 26) */
8132 pushSTACK(TheCclosure(closure)->clos_consts[26]);
8133 goto next_byte;
8134 CASE cod_const_push27: /* (CONST&PUSH.S 27) */
8135 pushSTACK(TheCclosure(closure)->clos_consts[27]);
8136 goto next_byte;
8137 CASE cod_const_push28: /* (CONST&PUSH.S 28) */
8138 pushSTACK(TheCclosure(closure)->clos_consts[28]);
8139 goto next_byte;
8140 CASE cod_const_push29: /* (CONST&PUSH.S 29) */
8141 pushSTACK(TheCclosure(closure)->clos_consts[29]);
8142 goto next_byte;
8143 #if 0
8144 CASE cod_const_push30: /* (CONST&PUSH.S 30) */
8145 pushSTACK(TheCclosure(closure)->clos_consts[30]);
8146 goto next_byte;
8147 CASE cod_const_push31: /* (CONST&PUSH.S 31) */
8148 pushSTACK(TheCclosure(closure)->clos_consts[31]);
8149 goto next_byte;
8150 CASE cod_const_push32: /* (CONST&PUSH.S 32) */
8151 pushSTACK(TheCclosure(closure)->clos_consts[32]);
8152 goto next_byte;
8153 #endif
8154 CASE cod_store0: /* (STORE.S 0) */
8155 STACK_(0) = value1; mv_count=1;
8156 goto next_byte;
8157 CASE cod_store1: /* (STORE.S 1) */
8158 STACK_(1) = value1; mv_count=1;
8159 goto next_byte;
8160 CASE cod_store2: /* (STORE.S 2) */
8161 STACK_(2) = value1; mv_count=1;
8162 goto next_byte;
8163 CASE cod_store3: /* (STORE.S 3) */
8164 STACK_(3) = value1; mv_count=1;
8165 goto next_byte;
8166 CASE cod_store4: /* (STORE.S 4) */
8167 STACK_(4) = value1; mv_count=1;
8168 goto next_byte;
8169 CASE cod_store5: /* (STORE.S 5) */
8170 STACK_(5) = value1; mv_count=1;
8171 goto next_byte;
8172 CASE cod_store6: /* (STORE.S 6) */
8173 STACK_(6) = value1; mv_count=1;
8174 goto next_byte;
8175 CASE cod_store7: /* (STORE.S 7) */
8176 STACK_(7) = value1; mv_count=1;
8177 goto next_byte;
8178 #if 0
8179 CASE cod_store8: /* (STORE.S 8) */
8180 STACK_(8) = value1; mv_count=1;
8181 goto next_byte;
8182 CASE cod_store9: /* (STORE.S 9) */
8183 STACK_(9) = value1; mv_count=1;
8184 goto next_byte;
8185 CASE cod_store10: /* (STORE.S 10) */
8186 STACK_(10) = value1; mv_count=1;
8187 goto next_byte;
8188 CASE cod_store11: /* (STORE.S 11) */
8189 STACK_(11) = value1; mv_count=1;
8190 goto next_byte;
8191 CASE cod_store12: /* (STORE.S 12) */
8192 STACK_(12) = value1; mv_count=1;
8193 goto next_byte;
8194 CASE cod_store13: /* (STORE.S 13) */
8195 STACK_(13) = value1; mv_count=1;
8196 goto next_byte;
8197 CASE cod_store14: /* (STORE.S 14) */
8198 STACK_(14) = value1; mv_count=1;
8199 goto next_byte;
8200 CASE cod_store15: /* (STORE.S 15) */
8201 STACK_(15) = value1; mv_count=1;
8202 goto next_byte;
8203 CASE cod_store16: /* (STORE.S 16) */
8204 STACK_(16) = value1; mv_count=1;
8205 goto next_byte;
8206 CASE cod_store17: /* (STORE.S 17) */
8207 STACK_(17) = value1; mv_count=1;
8208 goto next_byte;
8209 CASE cod_store18: /* (STORE.S 18) */
8210 STACK_(18) = value1; mv_count=1;
8211 goto next_byte;
8212 CASE cod_store19: /* (STORE.S 19) */
8213 STACK_(19) = value1; mv_count=1;
8214 goto next_byte;
8215 CASE cod_store20: /* (STORE.S 20) */
8216 STACK_(20) = value1; mv_count=1;
8217 goto next_byte;
8218 CASE cod_store21: /* (STORE.S 21) */
8219 STACK_(21) = value1; mv_count=1;
8220 goto next_byte;
8221 #endif
8222 /* ------------------- miscellaneous ----------------------- */
8223 #ifndef FAST_DISPATCH
8224 default:
8225 #endif
8226 /* undefined Code */
8227 #if defined(GNU) && defined(FAST_SP)
8228 /* Undo the effect of -fomit-frame-pointer for this function,
8229 hereby allowing utilization of %sp resp. %esp as private_SP: */
8230 alloca(1);
8231 #endif
8232 pushSTACK(fixnum(byteptr-&codeptr->data[0]-1)); /* bad byte number */
8233 pushSTACK(closure); /* Closure */
8234 error(serious_condition,GETTEXT("undefined bytecode in ~S at byte ~S"));
8235 #undef L_operand
8236 #undef S_operand
8237 #undef U_operand
8238 #undef B_operand
8239 #undef CASE
8240 }
8241 #if DEBUG_BYTECODE
8242 error_byteptr: {
8243 pushSTACK(fixnum(byteptr_max));
8244 pushSTACK(fixnum(byteptr_min));
8245 pushSTACK(fixnum(byteptr - codeptr->data));
8246 pushSTACK(sfixnum(byteptr_bad_jump));
8247 pushSTACK(closure);
8248 error(error_condition,GETTEXT("~S: jump by ~S takes ~S outside [~S;~S]"));
8249 }
8250 #endif
8251 error_toomany_values: error_mv_toomany(closure);
8252 #if STACKCHECKC
8253 error_STACK_putt: {
8254 pushSTACK(fixnum(byteptr - codeptr->data - byteptr_min)); /* PC */
8255 pushSTACK(closure); /* FUNC */
8256 error(serious_condition,GETTEXT("Corrupted STACK in ~S at byte ~S"));
8257 }
8258 #endif
8259 finished:
8260 #undef FREE_JMPBUF_on_SP
8261 #undef JMPBUF_on_SP
8262 #ifndef FAST_SP
8263 FREE_DYNAMIC_ARRAY(private_SP_space);
8264 #endif
8265 return;
8266 }
8267
8268
8269 /* UP: initialize hand-made compiled closures
8270 init_cclosures();
8271 can trigger GC */
init_cclosures(void)8272 global maygc void init_cclosures (void) {
8273 /* Build #13Y(00 00 00 00 00 00 00 00 00 01 C5 19 01) ; (CONST 0) (SKIP&RET 1) */
8274 {
8275 var object codevec = allocate_bit_vector(Atype_8Bit,CCV_START_NONKEY+3);
8276 TheCodevec(codevec)->ccv_spdepth_1 = 0;
8277 TheCodevec(codevec)->ccv_spdepth_jmpbufsize = 0;
8278 TheCodevec(codevec)->ccv_numreq = 0;
8279 TheCodevec(codevec)->ccv_numopt = 0;
8280 TheCodevec(codevec)->ccv_flags = 0;
8281 TheCodevec(codevec)->ccv_signature = cclos_argtype_0_0;
8282 TheSbvector(codevec)->data[CCV_START_NONKEY+0] = cod_const0;
8283 TheSbvector(codevec)->data[CCV_START_NONKEY+1] = cod_skip_ret;
8284 TheSbvector(codevec)->data[CCV_START_NONKEY+2] = 1;
8285 O(constant_initfunction_code) = codevec;
8286 }
8287 /* Build #12Y(00 00 00 00 00 00 00 00 11 16 1B 7E) ; L0 (JMP L0) */
8288 {
8289 var object codevec = allocate_bit_vector(Atype_8Bit,CCV_START_NONKEY+2);
8290 TheCodevec(codevec)->ccv_spdepth_1 = 0;
8291 TheCodevec(codevec)->ccv_spdepth_jmpbufsize = 0;
8292 TheCodevec(codevec)->ccv_numreq = 0;
8293 TheCodevec(codevec)->ccv_numopt = 0;
8294 TheCodevec(codevec)->ccv_flags = bit(4)|bit(0);
8295 TheCodevec(codevec)->ccv_signature = cclos_argtype_0_0_rest;
8296 TheSbvector(codevec)->data[CCV_START_NONKEY+0] = cod_jmp;
8297 TheSbvector(codevec)->data[CCV_START_NONKEY+1] = 128 - 2;
8298 O(endless_loop_code) = codevec;
8299 }
8300 }
8301
8302 #if defined(USE_JITC)
8303 #if defined(lightning)
8304 #undef unused
8305 #include "lightning.c"
8306 #else
8307 #error USE_JITC: what is your JITC flavor?
8308 #endif
8309 #endif
8310
8311 /* where is check_SP() or check_STACK() to be inserted??
8312 is nest_env supposed to receive its target-environment as parameter??
8313 register-allocation in eval_subr and eval_cclosure etc.??
8314 eliminate subr_self?? */
8315