Commit | Line | Data |
---|---|---|
243ebb61 HWN |
1 | /* |
2 | * eval.i.c - actual evaluator code for GUILE | |
3 | * | |
4 | * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc. | |
5 | * | |
6 | * This library is free software; you can redistribute it and/or | |
7 | * modify it under the terms of the GNU Lesser General Public | |
8 | * License as published by the Free Software Foundation; either | |
9 | * version 2.1 of the License, or (at your option) any later version. | |
10 | * | |
11 | * This library is distributed in the hope that it will be useful, | |
12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | * Lesser General Public License for more details. | |
15 | * | |
16 | * You should have received a copy of the GNU Lesser General Public | |
17 | * License along with this library; if not, write to the Free Software | |
18 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
19 | */ | |
20 | ||
0ee05b85 HWN |
21 | #undef RETURN |
22 | #undef ENTER_APPLY | |
23 | #undef PREP_APPLY | |
24 | #undef CEVAL | |
25 | #undef SCM_APPLY | |
26 | #undef EVAL_DEBUGGING_P | |
27 | ||
28 | ||
29 | #ifdef DEVAL | |
30 | ||
31 | /* | |
32 | This code is specific for the debugging support. | |
33 | */ | |
34 | ||
35 | #define EVAL_DEBUGGING_P 1 | |
36 | #define CEVAL deval /* Substitute all uses of ceval */ | |
37 | #define SCM_APPLY scm_dapply | |
38 | #define PREP_APPLY(p, l) \ | |
39 | { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } | |
40 | ||
41 | #define ENTER_APPLY \ | |
42 | do { \ | |
43 | SCM_SET_ARGSREADY (debug);\ | |
44 | if (scm_check_apply_p && SCM_TRAPS_P)\ | |
45 | if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\ | |
46 | {\ | |
47 | SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \ | |
48 | SCM_SET_TRACED_FRAME (debug); \ | |
49 | SCM_TRAPS_P = 0;\ | |
50 | tmp = scm_make_debugobj (&debug);\ | |
51 | scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\ | |
52 | SCM_TRAPS_P = 1;\ | |
53 | }\ | |
54 | } while (0) | |
55 | ||
56 | #define RETURN(e) do { proc = (e); goto exit; } while (0) | |
57 | ||
58 | #ifdef STACK_CHECKING | |
59 | # ifndef EVAL_STACK_CHECKING | |
60 | # define EVAL_STACK_CHECKING | |
61 | # endif /* EVAL_STACK_CHECKING */ | |
62 | #endif /* STACK_CHECKING */ | |
63 | ||
64 | ||
65 | ||
66 | ||
67 | static SCM | |
68 | deval_args (SCM l, SCM env, SCM proc, SCM *lloc) | |
69 | { | |
70 | SCM *results = lloc; | |
71 | while (scm_is_pair (l)) | |
72 | { | |
73 | const SCM res = SCM_I_XEVALCAR (l, env, 1); | |
74 | ||
75 | *lloc = scm_list_1 (res); | |
76 | lloc = SCM_CDRLOC (*lloc); | |
77 | l = SCM_CDR (l); | |
78 | } | |
79 | if (!scm_is_null (l)) | |
80 | scm_wrong_num_args (proc); | |
81 | return *results; | |
82 | } | |
83 | ||
84 | ||
85 | #else /* DEVAL */ | |
86 | ||
87 | /* | |
88 | Code is specific to debugging-less support. | |
89 | */ | |
90 | ||
91 | ||
92 | #define CEVAL ceval | |
93 | #define SCM_APPLY scm_apply | |
94 | #define PREP_APPLY(proc, args) | |
95 | #define ENTER_APPLY | |
96 | #define RETURN(x) do { return x; } while (0) | |
97 | #define EVAL_DEBUGGING_P 0 | |
98 | ||
99 | #ifdef STACK_CHECKING | |
100 | # ifndef NO_CEVAL_STACK_CHECKING | |
101 | # define EVAL_STACK_CHECKING | |
102 | # endif | |
103 | #endif | |
104 | ||
105 | ||
106 | ||
107 | ||
108 | static void | |
109 | ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol) | |
110 | { | |
111 | SCM argv[10]; | |
112 | int i = 0, imax = sizeof (argv) / sizeof (SCM); | |
113 | ||
114 | while (!scm_is_null (init_forms)) | |
115 | { | |
116 | if (imax == i) | |
117 | { | |
118 | ceval_letrec_inits (env, init_forms, init_values_eol); | |
119 | break; | |
120 | } | |
121 | argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0); | |
122 | init_forms = SCM_CDR (init_forms); | |
123 | } | |
124 | ||
125 | for (i--; i >= 0; i--) | |
126 | { | |
127 | **init_values_eol = scm_list_1 (argv[i]); | |
128 | *init_values_eol = SCM_CDRLOC (**init_values_eol); | |
129 | } | |
130 | } | |
131 | ||
132 | static SCM | |
133 | scm_ceval_args (SCM l, SCM env, SCM proc) | |
134 | { | |
135 | SCM results = SCM_EOL, *lloc = &results, res; | |
136 | while (scm_is_pair (l)) | |
137 | { | |
138 | res = EVALCAR (l, env); | |
139 | ||
140 | *lloc = scm_list_1 (res); | |
141 | lloc = SCM_CDRLOC (*lloc); | |
142 | l = SCM_CDR (l); | |
143 | } | |
144 | if (!scm_is_null (l)) | |
145 | scm_wrong_num_args (proc); | |
146 | return results; | |
147 | } | |
148 | ||
149 | ||
150 | SCM | |
151 | scm_eval_args (SCM l, SCM env, SCM proc) | |
152 | { | |
153 | return scm_ceval_args (l, env, proc); | |
154 | } | |
155 | ||
156 | ||
157 | ||
158 | #endif | |
159 | ||
160 | ||
161 | ||
162 | ||
163 | #define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P) | |
164 | #define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P) | |
165 | ||
166 | ||
167 | ||
168 | /* Update the toplevel environment frame ENV so that it refers to the | |
169 | * current module. */ | |
170 | #define UPDATE_TOPLEVEL_ENV(env) \ | |
171 | do { \ | |
172 | SCM p = scm_current_module_lookup_closure (); \ | |
173 | if (p != SCM_CAR (env)) \ | |
174 | env = scm_top_level_env (p); \ | |
175 | } while (0) | |
176 | ||
177 | ||
178 | #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ | |
179 | ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x) | |
180 | ||
181 | ||
182 | /* This is the evaluator. Like any real monster, it has three heads: | |
183 | * | |
184 | * ceval is the non-debugging evaluator, deval is the debugging version. Both | |
185 | * are implemented using a common code base, using the following mechanism: | |
186 | * CEVAL is a macro, which is either defined to ceval or deval. Thus, there | |
187 | * is no function CEVAL, but the code for CEVAL actually compiles to either | |
188 | * ceval or deval. When CEVAL is defined to ceval, it is known that the macro | |
189 | * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL | |
190 | * is known to be defined. Thus, in CEVAL parts for the debugging evaluator | |
191 | * are enclosed within #ifdef DEVAL ... #endif. | |
192 | * | |
193 | * All three (ceval, deval and their common implementation CEVAL) take two | |
194 | * input parameters, x and env: x is a single expression to be evalutated. | |
195 | * env is the environment in which bindings are searched. | |
196 | * | |
197 | * x is known to be a pair. Since x is a single expression, it is necessarily | |
198 | * in a tail position. If x is just a call to another function like in the | |
199 | * expression (foo exp1 exp2 ...), the realization of that call therefore | |
200 | * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc., | |
201 | * however, may do so). This is realized by making extensive use of 'goto' | |
202 | * statements within the evaluator: The gotos replace recursive calls to | |
203 | * CEVAL, thus re-using the same stack frame that CEVAL was already using. | |
204 | * If, however, x represents some form that requires to evaluate a sequence of | |
205 | * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are | |
206 | * performed for all but the last expression of that sequence. */ | |
207 | ||
208 | static SCM | |
209 | CEVAL (SCM x, SCM env) | |
210 | { | |
211 | SCM proc, arg1; | |
212 | #ifdef DEVAL | |
213 | scm_t_debug_frame debug; | |
214 | scm_t_debug_info *debug_info_end; | |
215 | debug.prev = scm_i_last_debug_frame (); | |
216 | debug.status = 0; | |
217 | /* | |
218 | * The debug.vect contains twice as much scm_t_debug_info frames as the | |
219 | * user has specified with (debug-set! frames <n>). | |
220 | * | |
221 | * Even frames are eval frames, odd frames are apply frames. | |
222 | */ | |
223 | debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size | |
224 | * sizeof (scm_t_debug_info)); | |
225 | debug.info = debug.vect; | |
226 | debug_info_end = debug.vect + scm_debug_eframe_size; | |
227 | scm_i_set_last_debug_frame (&debug); | |
228 | #endif | |
229 | #ifdef EVAL_STACK_CHECKING | |
230 | if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc)) | |
231 | { | |
232 | #ifdef DEVAL | |
233 | debug.info->e.exp = x; | |
234 | debug.info->e.env = env; | |
235 | #endif | |
236 | scm_report_stack_overflow (); | |
237 | } | |
238 | #endif | |
239 | ||
240 | #ifdef DEVAL | |
241 | goto start; | |
242 | #endif | |
243 | ||
244 | loop: | |
245 | #ifdef DEVAL | |
246 | SCM_CLEAR_ARGSREADY (debug); | |
247 | if (SCM_OVERFLOWP (debug)) | |
248 | --debug.info; | |
249 | /* | |
250 | * In theory, this should be the only place where it is necessary to | |
251 | * check for space in debug.vect since both eval frames and | |
252 | * available space are even. | |
253 | * | |
254 | * For this to be the case, however, it is necessary that primitive | |
255 | * special forms which jump back to `loop', `begin' or some similar | |
256 | * label call PREP_APPLY. | |
257 | */ | |
258 | else if (++debug.info >= debug_info_end) | |
259 | { | |
260 | SCM_SET_OVERFLOW (debug); | |
261 | debug.info -= 2; | |
262 | } | |
263 | ||
264 | start: | |
265 | debug.info->e.exp = x; | |
266 | debug.info->e.env = env; | |
267 | if (scm_check_entry_p && SCM_TRAPS_P) | |
268 | { | |
269 | if (SCM_ENTER_FRAME_P | |
270 | || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) | |
271 | { | |
272 | SCM stackrep; | |
273 | SCM tail = scm_from_bool (SCM_TAILRECP (debug)); | |
274 | SCM_SET_TAILREC (debug); | |
275 | stackrep = scm_make_debugobj (&debug); | |
276 | SCM_TRAPS_P = 0; | |
277 | stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR, | |
278 | scm_sym_enter_frame, | |
279 | stackrep, | |
280 | tail, | |
281 | unmemoize_expression (x, env)); | |
282 | SCM_TRAPS_P = 1; | |
283 | if (scm_is_pair (stackrep) && | |
284 | scm_is_eq (SCM_CAR (stackrep), sym_instead)) | |
285 | { | |
286 | /* This gives the possibility for the debugger to modify | |
287 | the source expression before evaluation. */ | |
288 | x = SCM_CDR (stackrep); | |
289 | if (SCM_IMP (x)) | |
290 | RETURN (x); | |
291 | } | |
292 | } | |
293 | } | |
294 | #endif | |
295 | dispatch: | |
296 | SCM_TICK; | |
297 | if (SCM_ISYMP (SCM_CAR (x))) | |
298 | { | |
299 | switch (ISYMNUM (SCM_CAR (x))) | |
300 | { | |
301 | case (ISYMNUM (SCM_IM_AND)): | |
302 | x = SCM_CDR (x); | |
303 | while (!scm_is_null (SCM_CDR (x))) | |
304 | { | |
305 | SCM test_result = EVALCAR (x, env); | |
306 | if (scm_is_false (test_result) || SCM_NILP (test_result)) | |
307 | RETURN (SCM_BOOL_F); | |
308 | else | |
309 | x = SCM_CDR (x); | |
310 | } | |
311 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
312 | goto carloop; | |
313 | ||
314 | case (ISYMNUM (SCM_IM_BEGIN)): | |
315 | x = SCM_CDR (x); | |
316 | if (scm_is_null (x)) | |
317 | RETURN (SCM_UNSPECIFIED); | |
318 | ||
319 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
320 | ||
321 | begin: | |
322 | /* If we are on toplevel with a lookup closure, we need to sync | |
323 | with the current module. */ | |
324 | if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env))) | |
325 | { | |
326 | UPDATE_TOPLEVEL_ENV (env); | |
327 | while (!scm_is_null (SCM_CDR (x))) | |
328 | { | |
329 | EVALCAR (x, env); | |
330 | UPDATE_TOPLEVEL_ENV (env); | |
331 | x = SCM_CDR (x); | |
332 | } | |
333 | goto carloop; | |
334 | } | |
335 | else | |
336 | goto nontoplevel_begin; | |
337 | ||
338 | nontoplevel_begin: | |
339 | while (!scm_is_null (SCM_CDR (x))) | |
340 | { | |
341 | const SCM form = SCM_CAR (x); | |
342 | if (SCM_IMP (form)) | |
343 | { | |
344 | if (SCM_ISYMP (form)) | |
345 | { | |
346 | scm_dynwind_begin (0); | |
347 | scm_i_dynwind_pthread_mutex_lock (&source_mutex); | |
348 | /* check for race condition */ | |
349 | if (SCM_ISYMP (SCM_CAR (x))) | |
350 | m_expand_body (x, env); | |
351 | scm_dynwind_end (); | |
352 | goto nontoplevel_begin; | |
353 | } | |
354 | else | |
355 | SCM_VALIDATE_NON_EMPTY_COMBINATION (form); | |
356 | } | |
357 | else | |
358 | (void) EVAL (form, env); | |
359 | x = SCM_CDR (x); | |
360 | } | |
361 | ||
362 | carloop: | |
363 | { | |
364 | /* scm_eval last form in list */ | |
365 | const SCM last_form = SCM_CAR (x); | |
366 | ||
367 | if (scm_is_pair (last_form)) | |
368 | { | |
369 | /* This is by far the most frequent case. */ | |
370 | x = last_form; | |
371 | goto loop; /* tail recurse */ | |
372 | } | |
373 | else if (SCM_IMP (last_form)) | |
374 | RETURN (SCM_I_EVALIM (last_form, env)); | |
375 | else if (SCM_VARIABLEP (last_form)) | |
376 | RETURN (SCM_VARIABLE_REF (last_form)); | |
377 | else if (scm_is_symbol (last_form)) | |
378 | RETURN (*scm_lookupcar (x, env, 1)); | |
379 | else | |
380 | RETURN (last_form); | |
381 | } | |
382 | ||
383 | ||
384 | case (ISYMNUM (SCM_IM_CASE)): | |
385 | x = SCM_CDR (x); | |
386 | { | |
387 | const SCM key = EVALCAR (x, env); | |
388 | x = SCM_CDR (x); | |
389 | while (!scm_is_null (x)) | |
390 | { | |
391 | const SCM clause = SCM_CAR (x); | |
392 | SCM labels = SCM_CAR (clause); | |
393 | if (scm_is_eq (labels, SCM_IM_ELSE)) | |
394 | { | |
395 | x = SCM_CDR (clause); | |
396 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
397 | goto begin; | |
398 | } | |
399 | while (!scm_is_null (labels)) | |
400 | { | |
401 | const SCM label = SCM_CAR (labels); | |
402 | if (scm_is_eq (label, key) | |
403 | || scm_is_true (scm_eqv_p (label, key))) | |
404 | { | |
405 | x = SCM_CDR (clause); | |
406 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
407 | goto begin; | |
408 | } | |
409 | labels = SCM_CDR (labels); | |
410 | } | |
411 | x = SCM_CDR (x); | |
412 | } | |
413 | } | |
414 | RETURN (SCM_UNSPECIFIED); | |
415 | ||
416 | ||
417 | case (ISYMNUM (SCM_IM_COND)): | |
418 | x = SCM_CDR (x); | |
419 | while (!scm_is_null (x)) | |
420 | { | |
421 | const SCM clause = SCM_CAR (x); | |
422 | if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE)) | |
423 | { | |
424 | x = SCM_CDR (clause); | |
425 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
426 | goto begin; | |
427 | } | |
428 | else | |
429 | { | |
430 | arg1 = EVALCAR (clause, env); | |
431 | /* SRFI 61 extended cond */ | |
432 | if (!scm_is_null (SCM_CDR (clause)) | |
433 | && !scm_is_null (SCM_CDDR (clause)) | |
434 | && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW)) | |
435 | { | |
436 | SCM xx, guard_result; | |
437 | if (SCM_VALUESP (arg1)) | |
438 | arg1 = scm_struct_ref (arg1, SCM_INUM0); | |
439 | else | |
440 | arg1 = scm_list_1 (arg1); | |
441 | xx = SCM_CDR (clause); | |
442 | proc = EVALCAR (xx, env); | |
443 | guard_result = SCM_APPLY (proc, arg1, SCM_EOL); | |
444 | if (scm_is_true (guard_result) | |
445 | && !SCM_NILP (guard_result)) | |
446 | { | |
447 | proc = SCM_CDDR (xx); | |
448 | proc = EVALCAR (proc, env); | |
449 | PREP_APPLY (proc, arg1); | |
450 | goto apply_proc; | |
451 | } | |
452 | } | |
453 | else if (scm_is_true (arg1) && !SCM_NILP (arg1)) | |
454 | { | |
455 | x = SCM_CDR (clause); | |
456 | if (scm_is_null (x)) | |
457 | RETURN (arg1); | |
458 | else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW)) | |
459 | { | |
460 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
461 | goto begin; | |
462 | } | |
463 | else | |
464 | { | |
465 | proc = SCM_CDR (x); | |
466 | proc = EVALCAR (proc, env); | |
467 | PREP_APPLY (proc, scm_list_1 (arg1)); | |
468 | ENTER_APPLY; | |
469 | goto evap1; | |
470 | } | |
471 | } | |
472 | x = SCM_CDR (x); | |
473 | } | |
474 | } | |
475 | RETURN (SCM_UNSPECIFIED); | |
476 | ||
477 | ||
478 | case (ISYMNUM (SCM_IM_DO)): | |
479 | x = SCM_CDR (x); | |
480 | { | |
481 | /* Compute the initialization values and the initial environment. */ | |
482 | SCM init_forms = SCM_CAR (x); | |
483 | SCM init_values = SCM_EOL; | |
484 | while (!scm_is_null (init_forms)) | |
485 | { | |
486 | init_values = scm_cons (EVALCAR (init_forms, env), init_values); | |
487 | init_forms = SCM_CDR (init_forms); | |
488 | } | |
489 | x = SCM_CDR (x); | |
490 | env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); | |
491 | } | |
492 | x = SCM_CDR (x); | |
493 | { | |
494 | SCM test_form = SCM_CAR (x); | |
495 | SCM body_forms = SCM_CADR (x); | |
496 | SCM step_forms = SCM_CDDR (x); | |
497 | ||
498 | SCM test_result = EVALCAR (test_form, env); | |
499 | ||
500 | while (scm_is_false (test_result) || SCM_NILP (test_result)) | |
501 | { | |
502 | { | |
503 | /* Evaluate body forms. */ | |
504 | SCM temp_forms; | |
505 | for (temp_forms = body_forms; | |
506 | !scm_is_null (temp_forms); | |
507 | temp_forms = SCM_CDR (temp_forms)) | |
508 | { | |
509 | SCM form = SCM_CAR (temp_forms); | |
510 | /* Dirk:FIXME: We only need to eval forms that may have | |
511 | * a side effect here. This is only true for forms that | |
512 | * start with a pair. All others are just constants. | |
513 | * Since with the current memoizer 'form' may hold a | |
514 | * constant, we call EVAL here to handle the constant | |
515 | * cases. In the long run it would make sense to have | |
516 | * the macro transformer of 'do' eliminate all forms | |
517 | * that have no sideeffect. Then instead of EVAL we | |
518 | * could call CEVAL directly here. */ | |
519 | (void) EVAL (form, env); | |
520 | } | |
521 | } | |
522 | ||
523 | { | |
524 | /* Evaluate the step expressions. */ | |
525 | SCM temp_forms; | |
526 | SCM step_values = SCM_EOL; | |
527 | for (temp_forms = step_forms; | |
528 | !scm_is_null (temp_forms); | |
529 | temp_forms = SCM_CDR (temp_forms)) | |
530 | { | |
531 | const SCM value = EVALCAR (temp_forms, env); | |
532 | step_values = scm_cons (value, step_values); | |
533 | } | |
534 | env = SCM_EXTEND_ENV (SCM_CAAR (env), | |
535 | step_values, | |
536 | SCM_CDR (env)); | |
537 | } | |
538 | ||
539 | test_result = EVALCAR (test_form, env); | |
540 | } | |
541 | } | |
542 | x = SCM_CDAR (x); | |
543 | if (scm_is_null (x)) | |
544 | RETURN (SCM_UNSPECIFIED); | |
545 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
546 | goto nontoplevel_begin; | |
547 | ||
548 | ||
549 | case (ISYMNUM (SCM_IM_IF)): | |
550 | x = SCM_CDR (x); | |
551 | { | |
552 | SCM test_result = EVALCAR (x, env); | |
553 | x = SCM_CDR (x); /* then expression */ | |
554 | if (scm_is_false (test_result) || SCM_NILP (test_result)) | |
555 | { | |
556 | x = SCM_CDR (x); /* else expression */ | |
557 | if (scm_is_null (x)) | |
558 | RETURN (SCM_UNSPECIFIED); | |
559 | } | |
560 | } | |
561 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
562 | goto carloop; | |
563 | ||
564 | ||
565 | case (ISYMNUM (SCM_IM_LET)): | |
566 | x = SCM_CDR (x); | |
567 | { | |
568 | SCM init_forms = SCM_CADR (x); | |
569 | SCM init_values = SCM_EOL; | |
570 | do | |
571 | { | |
572 | init_values = scm_cons (EVALCAR (init_forms, env), init_values); | |
573 | init_forms = SCM_CDR (init_forms); | |
574 | } | |
575 | while (!scm_is_null (init_forms)); | |
576 | env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); | |
577 | } | |
578 | x = SCM_CDDR (x); | |
579 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
580 | goto nontoplevel_begin; | |
581 | ||
582 | ||
583 | case (ISYMNUM (SCM_IM_LETREC)): | |
584 | x = SCM_CDR (x); | |
585 | env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env); | |
586 | x = SCM_CDR (x); | |
587 | { | |
588 | SCM init_forms = SCM_CAR (x); | |
589 | SCM init_values = scm_list_1 (SCM_BOOL_T); | |
590 | SCM *init_values_eol = SCM_CDRLOC (init_values); | |
591 | ceval_letrec_inits (env, init_forms, &init_values_eol); | |
592 | SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values)); | |
593 | } | |
594 | x = SCM_CDR (x); | |
595 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
596 | goto nontoplevel_begin; | |
597 | ||
598 | ||
599 | case (ISYMNUM (SCM_IM_LETSTAR)): | |
600 | x = SCM_CDR (x); | |
601 | { | |
602 | SCM bindings = SCM_CAR (x); | |
603 | if (!scm_is_null (bindings)) | |
604 | { | |
605 | do | |
606 | { | |
607 | SCM name = SCM_CAR (bindings); | |
608 | SCM init = SCM_CDR (bindings); | |
609 | env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env); | |
610 | bindings = SCM_CDR (init); | |
611 | } | |
612 | while (!scm_is_null (bindings)); | |
613 | } | |
614 | } | |
615 | x = SCM_CDR (x); | |
616 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
617 | goto nontoplevel_begin; | |
618 | ||
619 | ||
620 | case (ISYMNUM (SCM_IM_OR)): | |
621 | x = SCM_CDR (x); | |
622 | while (!scm_is_null (SCM_CDR (x))) | |
623 | { | |
624 | SCM val = EVALCAR (x, env); | |
625 | if (scm_is_true (val) && !SCM_NILP (val)) | |
626 | RETURN (val); | |
627 | else | |
628 | x = SCM_CDR (x); | |
629 | } | |
630 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
631 | goto carloop; | |
632 | ||
633 | ||
634 | case (ISYMNUM (SCM_IM_LAMBDA)): | |
635 | RETURN (scm_closure (SCM_CDR (x), env)); | |
636 | ||
637 | ||
638 | case (ISYMNUM (SCM_IM_QUOTE)): | |
639 | RETURN (SCM_CDR (x)); | |
640 | ||
641 | ||
642 | case (ISYMNUM (SCM_IM_SET_X)): | |
643 | x = SCM_CDR (x); | |
644 | { | |
645 | SCM *location; | |
646 | SCM variable = SCM_CAR (x); | |
647 | if (SCM_ILOCP (variable)) | |
648 | location = scm_ilookup (variable, env); | |
649 | else if (SCM_VARIABLEP (variable)) | |
650 | location = SCM_VARIABLE_LOC (variable); | |
651 | else | |
652 | { | |
653 | /* (scm_is_symbol (variable)) is known to be true */ | |
654 | variable = lazy_memoize_variable (variable, env); | |
655 | SCM_SETCAR (x, variable); | |
656 | location = SCM_VARIABLE_LOC (variable); | |
657 | } | |
658 | x = SCM_CDR (x); | |
659 | *location = EVALCAR (x, env); | |
660 | } | |
661 | RETURN (SCM_UNSPECIFIED); | |
662 | ||
663 | ||
664 | case (ISYMNUM (SCM_IM_APPLY)): | |
665 | /* Evaluate the procedure to be applied. */ | |
666 | x = SCM_CDR (x); | |
667 | proc = EVALCAR (x, env); | |
668 | PREP_APPLY (proc, SCM_EOL); | |
669 | ||
670 | /* Evaluate the argument holding the list of arguments */ | |
671 | x = SCM_CDR (x); | |
672 | arg1 = EVALCAR (x, env); | |
673 | ||
674 | apply_proc: | |
675 | /* Go here to tail-apply a procedure. PROC is the procedure and | |
676 | * ARG1 is the list of arguments. PREP_APPLY must have been called | |
677 | * before jumping to apply_proc. */ | |
678 | if (SCM_CLOSUREP (proc)) | |
679 | { | |
680 | SCM formals = SCM_CLOSURE_FORMALS (proc); | |
681 | #ifdef DEVAL | |
682 | debug.info->a.args = arg1; | |
683 | #endif | |
9cc37597 | 684 | if (SCM_UNLIKELY (scm_badargsp (formals, arg1))) |
0ee05b85 HWN |
685 | scm_wrong_num_args (proc); |
686 | ENTER_APPLY; | |
687 | /* Copy argument list */ | |
688 | if (SCM_NULL_OR_NIL_P (arg1)) | |
689 | env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); | |
690 | else | |
691 | { | |
692 | SCM args = scm_list_1 (SCM_CAR (arg1)); | |
693 | SCM tail = args; | |
694 | arg1 = SCM_CDR (arg1); | |
695 | while (!SCM_NULL_OR_NIL_P (arg1)) | |
696 | { | |
697 | SCM new_tail = scm_list_1 (SCM_CAR (arg1)); | |
698 | SCM_SETCDR (tail, new_tail); | |
699 | tail = new_tail; | |
700 | arg1 = SCM_CDR (arg1); | |
701 | } | |
702 | env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc)); | |
703 | } | |
704 | ||
705 | x = SCM_CLOSURE_BODY (proc); | |
706 | goto nontoplevel_begin; | |
707 | } | |
708 | else | |
709 | { | |
710 | ENTER_APPLY; | |
711 | RETURN (SCM_APPLY (proc, arg1, SCM_EOL)); | |
712 | } | |
713 | ||
714 | ||
715 | case (ISYMNUM (SCM_IM_CONT)): | |
716 | { | |
717 | int first; | |
718 | SCM val = scm_make_continuation (&first); | |
719 | ||
720 | if (!first) | |
721 | RETURN (val); | |
722 | else | |
723 | { | |
724 | arg1 = val; | |
725 | proc = SCM_CDR (x); | |
726 | proc = EVALCAR (proc, env); | |
727 | PREP_APPLY (proc, scm_list_1 (arg1)); | |
728 | ENTER_APPLY; | |
729 | goto evap1; | |
730 | } | |
731 | } | |
732 | ||
733 | ||
734 | case (ISYMNUM (SCM_IM_DELAY)): | |
7c455996 | 735 | RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env))); |
0ee05b85 HWN |
736 | |
737 | #if 0 | |
738 | /* See futures.h for a comment why futures are not enabled. | |
739 | */ | |
740 | case (ISYMNUM (SCM_IM_FUTURE)): | |
741 | RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); | |
742 | #endif | |
743 | ||
744 | /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following | |
745 | code (type_dispatch) is intended to be the tail of the case | |
746 | clause for the internal macro SCM_IM_DISPATCH. Please don't | |
747 | remove it from this location without discussing it with Mikael | |
748 | <djurfeldt@nada.kth.se> */ | |
749 | ||
750 | /* The type dispatch code is duplicated below | |
751 | * (c.f. objects.c:scm_mcache_compute_cmethod) since that | |
752 | * cuts down execution time for type dispatch to 50%. */ | |
753 | type_dispatch: /* inputs: x, arg1 */ | |
754 | /* Type dispatch means to determine from the types of the function | |
755 | * arguments (i. e. the 'signature' of the call), which method from | |
756 | * a generic function is to be called. This process of selecting | |
757 | * the right method takes some time. To speed it up, guile uses | |
758 | * caching: Together with the macro call to dispatch the signatures | |
759 | * of some previous calls to that generic function from the same | |
760 | * place are stored (in the code!) in a cache that we call the | |
761 | * 'method cache'. This is done since it is likely, that | |
762 | * consecutive calls to dispatch from that position in the code will | |
763 | * have the same signature. Thus, the type dispatch works as | |
764 | * follows: First, determine a hash value from the signature of the | |
765 | * actual arguments. Second, use this hash value as an index to | |
766 | * find that same signature in the method cache stored at this | |
767 | * position in the code. If found, you have also found the | |
768 | * corresponding method that belongs to that signature. If the | |
769 | * signature is not found in the method cache, you have to perform a | |
770 | * full search over all signatures stored with the generic | |
771 | * function. */ | |
772 | { | |
773 | unsigned long int specializers; | |
774 | unsigned long int hash_value; | |
775 | unsigned long int cache_end_pos; | |
776 | unsigned long int mask; | |
777 | SCM method_cache; | |
778 | ||
779 | { | |
780 | SCM z = SCM_CDDR (x); | |
781 | SCM tmp = SCM_CADR (z); | |
782 | specializers = scm_to_ulong (SCM_CAR (z)); | |
783 | ||
784 | /* Compute a hash value for searching the method cache. There | |
785 | * are two variants for computing the hash value, a (rather) | |
786 | * complicated one, and a simple one. For the complicated one | |
787 | * explained below, tmp holds a number that is used in the | |
788 | * computation. */ | |
789 | if (scm_is_simple_vector (tmp)) | |
790 | { | |
791 | /* This method of determining the hash value is much | |
792 | * simpler: Set the hash value to zero and just perform a | |
793 | * linear search through the method cache. */ | |
794 | method_cache = tmp; | |
795 | mask = (unsigned long int) ((long) -1); | |
796 | hash_value = 0; | |
797 | cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache); | |
798 | } | |
799 | else | |
800 | { | |
801 | /* Use the signature of the actual arguments to determine | |
802 | * the hash value. This is done as follows: Each class has | |
803 | * an array of random numbers, that are determined when the | |
804 | * class is created. The integer 'hashset' is an index into | |
805 | * that array of random numbers. Now, from all classes that | |
806 | * are part of the signature of the actual arguments, the | |
807 | * random numbers at index 'hashset' are taken and summed | |
808 | * up, giving the hash value. The value of 'hashset' is | |
809 | * stored at the call to dispatch. This allows to have | |
810 | * different 'formulas' for calculating the hash value at | |
811 | * different places where dispatch is called. This allows | |
812 | * to optimize the hash formula at every individual place | |
813 | * where dispatch is called, such that hopefully the hash | |
814 | * value that is computed will directly point to the right | |
815 | * method in the method cache. */ | |
816 | unsigned long int hashset = scm_to_ulong (tmp); | |
817 | unsigned long int counter = specializers + 1; | |
818 | SCM tmp_arg = arg1; | |
819 | hash_value = 0; | |
820 | while (!scm_is_null (tmp_arg) && counter != 0) | |
821 | { | |
822 | SCM class = scm_class_of (SCM_CAR (tmp_arg)); | |
823 | hash_value += SCM_INSTANCE_HASH (class, hashset); | |
824 | tmp_arg = SCM_CDR (tmp_arg); | |
825 | counter--; | |
826 | } | |
827 | z = SCM_CDDR (z); | |
828 | method_cache = SCM_CADR (z); | |
829 | mask = scm_to_ulong (SCM_CAR (z)); | |
830 | hash_value &= mask; | |
831 | cache_end_pos = hash_value; | |
832 | } | |
833 | } | |
834 | ||
835 | { | |
836 | /* Search the method cache for a method with a matching | |
837 | * signature. Start the search at position 'hash_value'. The | |
838 | * hashing implementation uses linear probing for conflict | |
839 | * resolution, that is, if the signature in question is not | |
840 | * found at the starting index in the hash table, the next table | |
841 | * entry is tried, and so on, until in the worst case the whole | |
842 | * cache has been searched, but still the signature has not been | |
843 | * found. */ | |
844 | SCM z; | |
845 | do | |
846 | { | |
847 | SCM args = arg1; /* list of arguments */ | |
848 | z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value); | |
849 | while (!scm_is_null (args)) | |
850 | { | |
851 | /* More arguments than specifiers => CLASS != ENV */ | |
852 | SCM class_of_arg = scm_class_of (SCM_CAR (args)); | |
853 | if (!scm_is_eq (class_of_arg, SCM_CAR (z))) | |
854 | goto next_method; | |
855 | args = SCM_CDR (args); | |
856 | z = SCM_CDR (z); | |
857 | } | |
5487977b | 858 | /* Fewer arguments than specifiers => CAR != CLASS */ |
05b37c17 AW |
859 | if (!scm_is_pair (z)) |
860 | goto apply_vm_cmethod; | |
861 | else if (!SCM_CLASSP (SCM_CAR (z)) | |
862 | && !scm_is_symbol (SCM_CAR (z))) | |
863 | goto apply_memoized_cmethod; | |
0ee05b85 HWN |
864 | next_method: |
865 | hash_value = (hash_value + 1) & mask; | |
866 | } while (hash_value != cache_end_pos); | |
867 | ||
868 | /* No appropriate method was found in the cache. */ | |
869 | z = scm_memoize_method (x, arg1); | |
870 | ||
05b37c17 AW |
871 | if (scm_is_pair (z)) |
872 | goto apply_memoized_cmethod; | |
873 | ||
874 | apply_vm_cmethod: | |
875 | proc = z; | |
876 | PREP_APPLY (proc, arg1); | |
877 | goto apply_proc; | |
878 | ||
879 | apply_memoized_cmethod: /* inputs: z, arg1 */ | |
880 | { | |
881 | SCM formals = SCM_CMETHOD_FORMALS (z); | |
882 | env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); | |
883 | x = SCM_CMETHOD_BODY (z); | |
884 | goto nontoplevel_begin; | |
885 | } | |
0ee05b85 HWN |
886 | } |
887 | } | |
888 | ||
889 | ||
890 | case (ISYMNUM (SCM_IM_SLOT_REF)): | |
891 | x = SCM_CDR (x); | |
892 | { | |
893 | SCM instance = EVALCAR (x, env); | |
894 | unsigned long int slot = SCM_I_INUM (SCM_CDR (x)); | |
895 | RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); | |
896 | } | |
897 | ||
898 | ||
899 | case (ISYMNUM (SCM_IM_SLOT_SET_X)): | |
900 | x = SCM_CDR (x); | |
901 | { | |
902 | SCM instance = EVALCAR (x, env); | |
903 | unsigned long int slot = SCM_I_INUM (SCM_CADR (x)); | |
904 | SCM value = EVALCAR (SCM_CDDR (x), env); | |
905 | SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value); | |
906 | RETURN (SCM_UNSPECIFIED); | |
907 | } | |
908 | ||
909 | ||
910 | #if SCM_ENABLE_ELISP | |
911 | ||
912 | case (ISYMNUM (SCM_IM_NIL_COND)): | |
913 | { | |
914 | SCM test_form = SCM_CDR (x); | |
915 | x = SCM_CDR (test_form); | |
916 | while (!SCM_NULL_OR_NIL_P (x)) | |
917 | { | |
918 | SCM test_result = EVALCAR (test_form, env); | |
919 | if (!(scm_is_false (test_result) | |
920 | || SCM_NULL_OR_NIL_P (test_result))) | |
921 | { | |
922 | if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED)) | |
923 | RETURN (test_result); | |
924 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
925 | goto carloop; | |
926 | } | |
927 | else | |
928 | { | |
929 | test_form = SCM_CDR (x); | |
930 | x = SCM_CDR (test_form); | |
931 | } | |
932 | } | |
933 | x = test_form; | |
934 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
935 | goto carloop; | |
936 | } | |
937 | ||
938 | #endif /* SCM_ENABLE_ELISP */ | |
939 | ||
940 | case (ISYMNUM (SCM_IM_BIND)): | |
941 | { | |
942 | SCM vars, exps, vals; | |
943 | ||
944 | x = SCM_CDR (x); | |
945 | vars = SCM_CAAR (x); | |
946 | exps = SCM_CDAR (x); | |
947 | vals = SCM_EOL; | |
948 | while (!scm_is_null (exps)) | |
949 | { | |
950 | vals = scm_cons (EVALCAR (exps, env), vals); | |
951 | exps = SCM_CDR (exps); | |
952 | } | |
953 | ||
954 | scm_swap_bindings (vars, vals); | |
955 | scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ())); | |
956 | ||
957 | /* Ignore all but the last evaluation result. */ | |
958 | for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x)) | |
959 | { | |
960 | if (scm_is_pair (SCM_CAR (x))) | |
961 | CEVAL (SCM_CAR (x), env); | |
962 | } | |
963 | proc = EVALCAR (x, env); | |
964 | ||
965 | scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ())); | |
966 | scm_swap_bindings (vars, vals); | |
967 | ||
968 | RETURN (proc); | |
969 | } | |
970 | ||
971 | ||
972 | case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)): | |
973 | { | |
974 | SCM producer; | |
975 | ||
976 | x = SCM_CDR (x); | |
977 | producer = EVALCAR (x, env); | |
978 | x = SCM_CDR (x); | |
979 | proc = EVALCAR (x, env); /* proc is the consumer. */ | |
980 | arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); | |
981 | if (SCM_VALUESP (arg1)) | |
982 | { | |
983 | /* The list of arguments is not copied. Rather, it is assumed | |
984 | * that this has been done by the 'values' procedure. */ | |
985 | arg1 = scm_struct_ref (arg1, SCM_INUM0); | |
986 | } | |
987 | else | |
988 | { | |
989 | arg1 = scm_list_1 (arg1); | |
990 | } | |
991 | PREP_APPLY (proc, arg1); | |
992 | goto apply_proc; | |
993 | } | |
994 | ||
995 | ||
996 | default: | |
997 | break; | |
998 | } | |
999 | } | |
1000 | else | |
1001 | { | |
1002 | if (SCM_VARIABLEP (SCM_CAR (x))) | |
1003 | proc = SCM_VARIABLE_REF (SCM_CAR (x)); | |
1004 | else if (SCM_ILOCP (SCM_CAR (x))) | |
1005 | proc = *scm_ilookup (SCM_CAR (x), env); | |
1006 | else if (scm_is_pair (SCM_CAR (x))) | |
1007 | proc = CEVAL (SCM_CAR (x), env); | |
1008 | else if (scm_is_symbol (SCM_CAR (x))) | |
1009 | { | |
1010 | SCM orig_sym = SCM_CAR (x); | |
1011 | { | |
1012 | SCM *location = scm_lookupcar1 (x, env, 1); | |
1013 | if (location == NULL) | |
1014 | { | |
1015 | /* we have lost the race, start again. */ | |
1016 | goto dispatch; | |
1017 | } | |
1018 | proc = *location; | |
1019 | #ifdef DEVAL | |
1020 | if (scm_check_memoize_p && SCM_TRAPS_P) | |
1021 | { | |
1022 | SCM_CLEAR_TRACED_FRAME (debug); | |
1023 | SCM arg1 = scm_make_debugobj (&debug); | |
1024 | SCM retval = SCM_BOOL_T; | |
1025 | SCM_TRAPS_P = 0; | |
1026 | retval = scm_call_4 (SCM_MEMOIZE_HDLR, | |
1027 | scm_sym_memoize_symbol, | |
1028 | arg1, x, env); | |
1029 | ||
1030 | /* | |
1031 | do something with retval? | |
1032 | */ | |
1033 | SCM_TRAPS_P = 1; | |
1034 | } | |
1035 | #endif | |
1036 | } | |
1037 | ||
1038 | if (SCM_MACROP (proc)) | |
1039 | { | |
1040 | SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of | |
1041 | lookupcar */ | |
1042 | handle_a_macro: /* inputs: x, env, proc */ | |
1043 | #ifdef DEVAL | |
1044 | /* Set a flag during macro expansion so that macro | |
1045 | application frames can be deleted from the backtrace. */ | |
1046 | SCM_SET_MACROEXP (debug); | |
1047 | #endif | |
1048 | arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, | |
1049 | scm_cons (env, scm_listofnull)); | |
1050 | #ifdef DEVAL | |
1051 | SCM_CLEAR_MACROEXP (debug); | |
1052 | #endif | |
1053 | switch (SCM_MACRO_TYPE (proc)) | |
1054 | { | |
1055 | case 3: | |
1056 | case 2: | |
1057 | if (!scm_is_pair (arg1)) | |
1058 | arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); | |
1059 | ||
1060 | assert (!scm_is_eq (x, SCM_CAR (arg1)) | |
1061 | && !scm_is_eq (x, SCM_CDR (arg1))); | |
1062 | ||
1063 | #ifdef DEVAL | |
1064 | if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) | |
1065 | { | |
1066 | SCM_CRITICAL_SECTION_START; | |
1067 | SCM_SETCAR (x, SCM_CAR (arg1)); | |
1068 | SCM_SETCDR (x, SCM_CDR (arg1)); | |
1069 | SCM_CRITICAL_SECTION_END; | |
1070 | goto dispatch; | |
1071 | } | |
1072 | /* Prevent memoizing of debug info expression. */ | |
1073 | debug.info->e.exp = scm_cons_source (debug.info->e.exp, | |
1074 | SCM_CAR (x), | |
1075 | SCM_CDR (x)); | |
1076 | #endif | |
1077 | SCM_CRITICAL_SECTION_START; | |
1078 | SCM_SETCAR (x, SCM_CAR (arg1)); | |
1079 | SCM_SETCDR (x, SCM_CDR (arg1)); | |
1080 | SCM_CRITICAL_SECTION_END; | |
1081 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
1082 | goto loop; | |
1083 | #if SCM_ENABLE_DEPRECATED == 1 | |
1084 | case 1: | |
1085 | x = arg1; | |
1086 | if (SCM_NIMP (x)) | |
1087 | { | |
1088 | PREP_APPLY (SCM_UNDEFINED, SCM_EOL); | |
1089 | goto loop; | |
1090 | } | |
1091 | else | |
1092 | RETURN (arg1); | |
1093 | #endif | |
1094 | case 0: | |
1095 | RETURN (arg1); | |
1096 | } | |
1097 | } | |
1098 | } | |
1099 | else | |
1100 | proc = SCM_CAR (x); | |
1101 | ||
1102 | if (SCM_MACROP (proc)) | |
1103 | goto handle_a_macro; | |
1104 | } | |
1105 | ||
1106 | ||
1107 | /* When reaching this part of the code, the following is granted: Variable x | |
1108 | * holds the first pair of an expression of the form (<function> arg ...). | |
1109 | * Variable proc holds the object that resulted from the evaluation of | |
1110 | * <function>. In the following, the arguments (if any) will be evaluated, | |
1111 | * and proc will be applied to them. If proc does not really hold a | |
1112 | * function object, this will be signalled as an error on the scheme | |
1113 | * level. If the number of arguments does not match the number of arguments | |
1114 | * that are allowed to be passed to proc, also an error on the scheme level | |
1115 | * will be signalled. */ | |
1116 | ||
1117 | PREP_APPLY (proc, SCM_EOL); | |
1118 | if (scm_is_null (SCM_CDR (x))) { | |
1119 | ENTER_APPLY; | |
1120 | evap0: | |
1121 | SCM_ASRTGO (!SCM_IMP (proc), badfun); | |
1122 | switch (SCM_TYP7 (proc)) | |
1123 | { /* no arguments given */ | |
1124 | case scm_tc7_subr_0: | |
1125 | RETURN (SCM_SUBRF (proc) ()); | |
1126 | case scm_tc7_subr_1o: | |
1127 | RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED)); | |
1128 | case scm_tc7_lsubr: | |
1129 | RETURN (SCM_SUBRF (proc) (SCM_EOL)); | |
1130 | case scm_tc7_rpsubr: | |
1131 | RETURN (SCM_BOOL_T); | |
1132 | case scm_tc7_asubr: | |
1133 | RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); | |
1134 | case scm_tc7_smob: | |
1135 | if (!SCM_SMOB_APPLICABLE_P (proc)) | |
1136 | goto badfun; | |
1137 | RETURN (SCM_SMOB_APPLY_0 (proc)); | |
1138 | case scm_tc7_cclo: | |
1139 | arg1 = proc; | |
1140 | proc = SCM_CCLO_SUBR (proc); | |
1141 | #ifdef DEVAL | |
1142 | debug.info->a.proc = proc; | |
1143 | debug.info->a.args = scm_list_1 (arg1); | |
1144 | #endif | |
1145 | goto evap1; | |
1146 | case scm_tc7_pws: | |
1147 | proc = SCM_PROCEDURE (proc); | |
1148 | #ifdef DEVAL | |
1149 | debug.info->a.proc = proc; | |
1150 | #endif | |
1151 | if (!SCM_CLOSUREP (proc)) | |
1152 | goto evap0; | |
1153 | /* fallthrough */ | |
1154 | case scm_tcs_closures: | |
1155 | { | |
1156 | const SCM formals = SCM_CLOSURE_FORMALS (proc); | |
9cc37597 | 1157 | if (SCM_UNLIKELY (scm_is_pair (formals))) |
0ee05b85 HWN |
1158 | goto wrongnumargs; |
1159 | x = SCM_CLOSURE_BODY (proc); | |
1160 | env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); | |
1161 | goto nontoplevel_begin; | |
1162 | } | |
1163 | case scm_tcs_struct: | |
1164 | if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) | |
1165 | { | |
1166 | x = SCM_ENTITY_PROCEDURE (proc); | |
1167 | arg1 = SCM_EOL; | |
1168 | goto type_dispatch; | |
1169 | } | |
1170 | else if (SCM_I_OPERATORP (proc)) | |
1171 | { | |
1172 | arg1 = proc; | |
1173 | proc = (SCM_I_ENTITYP (proc) | |
1174 | ? SCM_ENTITY_PROCEDURE (proc) | |
1175 | : SCM_OPERATOR_PROCEDURE (proc)); | |
1176 | #ifdef DEVAL | |
1177 | debug.info->a.proc = proc; | |
1178 | debug.info->a.args = scm_list_1 (arg1); | |
1179 | #endif | |
1180 | goto evap1; | |
1181 | } | |
1182 | else | |
1183 | goto badfun; | |
1184 | case scm_tc7_subr_1: | |
1185 | case scm_tc7_subr_2: | |
1186 | case scm_tc7_subr_2o: | |
1187 | case scm_tc7_dsubr: | |
1188 | case scm_tc7_cxr: | |
1189 | case scm_tc7_subr_3: | |
1190 | case scm_tc7_lsubr_2: | |
1191 | wrongnumargs: | |
1192 | scm_wrong_num_args (proc); | |
1193 | default: | |
1194 | badfun: | |
1195 | scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); | |
1196 | } | |
1197 | } | |
1198 | ||
1199 | /* must handle macros by here */ | |
1200 | x = SCM_CDR (x); | |
9cc37597 | 1201 | if (SCM_LIKELY (scm_is_pair (x))) |
0ee05b85 HWN |
1202 | arg1 = EVALCAR (x, env); |
1203 | else | |
1204 | scm_wrong_num_args (proc); | |
1205 | #ifdef DEVAL | |
1206 | debug.info->a.args = scm_list_1 (arg1); | |
1207 | #endif | |
1208 | x = SCM_CDR (x); | |
1209 | { | |
1210 | SCM arg2; | |
1211 | if (scm_is_null (x)) | |
1212 | { | |
1213 | ENTER_APPLY; | |
1214 | evap1: /* inputs: proc, arg1 */ | |
1215 | SCM_ASRTGO (!SCM_IMP (proc), badfun); | |
1216 | switch (SCM_TYP7 (proc)) | |
1217 | { /* have one argument in arg1 */ | |
1218 | case scm_tc7_subr_2o: | |
1219 | RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); | |
1220 | case scm_tc7_subr_1: | |
1221 | case scm_tc7_subr_1o: | |
1222 | RETURN (SCM_SUBRF (proc) (arg1)); | |
1223 | case scm_tc7_dsubr: | |
1224 | if (SCM_I_INUMP (arg1)) | |
1225 | { | |
1226 | RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); | |
1227 | } | |
1228 | else if (SCM_REALP (arg1)) | |
1229 | { | |
1230 | RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); | |
1231 | } | |
1232 | else if (SCM_BIGP (arg1)) | |
1233 | { | |
1234 | RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); | |
1235 | } | |
1236 | else if (SCM_FRACTIONP (arg1)) | |
1237 | { | |
1238 | RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); | |
1239 | } | |
1240 | SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, | |
1241 | SCM_ARG1, | |
1242 | scm_i_symbol_chars (SCM_SNAME (proc))); | |
1243 | case scm_tc7_cxr: | |
1244 | RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); | |
1245 | case scm_tc7_rpsubr: | |
1246 | RETURN (SCM_BOOL_T); | |
1247 | case scm_tc7_asubr: | |
1248 | RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); | |
1249 | case scm_tc7_lsubr: | |
1250 | #ifdef DEVAL | |
1251 | RETURN (SCM_SUBRF (proc) (debug.info->a.args)); | |
1252 | #else | |
1253 | RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); | |
1254 | #endif | |
1255 | case scm_tc7_smob: | |
1256 | if (!SCM_SMOB_APPLICABLE_P (proc)) | |
1257 | goto badfun; | |
1258 | RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); | |
1259 | case scm_tc7_cclo: | |
1260 | arg2 = arg1; | |
1261 | arg1 = proc; | |
1262 | proc = SCM_CCLO_SUBR (proc); | |
1263 | #ifdef DEVAL | |
1264 | debug.info->a.args = scm_cons (arg1, debug.info->a.args); | |
1265 | debug.info->a.proc = proc; | |
1266 | #endif | |
1267 | goto evap2; | |
1268 | case scm_tc7_pws: | |
1269 | proc = SCM_PROCEDURE (proc); | |
1270 | #ifdef DEVAL | |
1271 | debug.info->a.proc = proc; | |
1272 | #endif | |
1273 | if (!SCM_CLOSUREP (proc)) | |
1274 | goto evap1; | |
1275 | /* fallthrough */ | |
1276 | case scm_tcs_closures: | |
1277 | { | |
1278 | /* clos1: */ | |
1279 | const SCM formals = SCM_CLOSURE_FORMALS (proc); | |
1280 | if (scm_is_null (formals) | |
1281 | || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals)))) | |
1282 | goto wrongnumargs; | |
1283 | x = SCM_CLOSURE_BODY (proc); | |
1284 | #ifdef DEVAL | |
1285 | env = SCM_EXTEND_ENV (formals, | |
1286 | debug.info->a.args, | |
1287 | SCM_ENV (proc)); | |
1288 | #else | |
1289 | env = SCM_EXTEND_ENV (formals, | |
1290 | scm_list_1 (arg1), | |
1291 | SCM_ENV (proc)); | |
1292 | #endif | |
1293 | goto nontoplevel_begin; | |
1294 | } | |
1295 | case scm_tcs_struct: | |
1296 | if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) | |
1297 | { | |
1298 | x = SCM_ENTITY_PROCEDURE (proc); | |
1299 | #ifdef DEVAL | |
1300 | arg1 = debug.info->a.args; | |
1301 | #else | |
1302 | arg1 = scm_list_1 (arg1); | |
1303 | #endif | |
1304 | goto type_dispatch; | |
1305 | } | |
1306 | else if (SCM_I_OPERATORP (proc)) | |
1307 | { | |
1308 | arg2 = arg1; | |
1309 | arg1 = proc; | |
1310 | proc = (SCM_I_ENTITYP (proc) | |
1311 | ? SCM_ENTITY_PROCEDURE (proc) | |
1312 | : SCM_OPERATOR_PROCEDURE (proc)); | |
1313 | #ifdef DEVAL | |
1314 | debug.info->a.args = scm_cons (arg1, debug.info->a.args); | |
1315 | debug.info->a.proc = proc; | |
1316 | #endif | |
1317 | goto evap2; | |
1318 | } | |
1319 | else | |
1320 | goto badfun; | |
1321 | case scm_tc7_subr_2: | |
1322 | case scm_tc7_subr_0: | |
1323 | case scm_tc7_subr_3: | |
1324 | case scm_tc7_lsubr_2: | |
1325 | scm_wrong_num_args (proc); | |
1326 | default: | |
1327 | goto badfun; | |
1328 | } | |
1329 | } | |
9cc37597 | 1330 | if (SCM_LIKELY (scm_is_pair (x))) |
0ee05b85 HWN |
1331 | arg2 = EVALCAR (x, env); |
1332 | else | |
1333 | scm_wrong_num_args (proc); | |
1334 | ||
1335 | { /* have two or more arguments */ | |
1336 | #ifdef DEVAL | |
1337 | debug.info->a.args = scm_list_2 (arg1, arg2); | |
1338 | #endif | |
1339 | x = SCM_CDR (x); | |
1340 | if (scm_is_null (x)) { | |
1341 | ENTER_APPLY; | |
1342 | evap2: | |
1343 | SCM_ASRTGO (!SCM_IMP (proc), badfun); | |
1344 | switch (SCM_TYP7 (proc)) | |
1345 | { /* have two arguments */ | |
1346 | case scm_tc7_subr_2: | |
1347 | case scm_tc7_subr_2o: | |
1348 | RETURN (SCM_SUBRF (proc) (arg1, arg2)); | |
1349 | case scm_tc7_lsubr: | |
1350 | #ifdef DEVAL | |
1351 | RETURN (SCM_SUBRF (proc) (debug.info->a.args)); | |
1352 | #else | |
1353 | RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); | |
1354 | #endif | |
1355 | case scm_tc7_lsubr_2: | |
1356 | RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); | |
1357 | case scm_tc7_rpsubr: | |
1358 | case scm_tc7_asubr: | |
1359 | RETURN (SCM_SUBRF (proc) (arg1, arg2)); | |
1360 | case scm_tc7_smob: | |
1361 | if (!SCM_SMOB_APPLICABLE_P (proc)) | |
1362 | goto badfun; | |
1363 | RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); | |
1364 | cclon: | |
1365 | case scm_tc7_cclo: | |
1366 | #ifdef DEVAL | |
1367 | RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), | |
1368 | scm_cons (proc, debug.info->a.args), | |
1369 | SCM_EOL)); | |
1370 | #else | |
1371 | RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), | |
1372 | scm_cons2 (proc, arg1, | |
1373 | scm_cons (arg2, | |
1374 | scm_ceval_args (x, | |
1375 | env, | |
1376 | proc))), | |
1377 | SCM_EOL)); | |
1378 | #endif | |
1379 | case scm_tcs_struct: | |
1380 | if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) | |
1381 | { | |
1382 | x = SCM_ENTITY_PROCEDURE (proc); | |
1383 | #ifdef DEVAL | |
1384 | arg1 = debug.info->a.args; | |
1385 | #else | |
1386 | arg1 = scm_list_2 (arg1, arg2); | |
1387 | #endif | |
1388 | goto type_dispatch; | |
1389 | } | |
1390 | else if (SCM_I_OPERATORP (proc)) | |
1391 | { | |
1392 | operatorn: | |
1393 | #ifdef DEVAL | |
1394 | RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) | |
1395 | ? SCM_ENTITY_PROCEDURE (proc) | |
1396 | : SCM_OPERATOR_PROCEDURE (proc), | |
1397 | scm_cons (proc, debug.info->a.args), | |
1398 | SCM_EOL)); | |
1399 | #else | |
1400 | RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) | |
1401 | ? SCM_ENTITY_PROCEDURE (proc) | |
1402 | : SCM_OPERATOR_PROCEDURE (proc), | |
1403 | scm_cons2 (proc, arg1, | |
1404 | scm_cons (arg2, | |
1405 | scm_ceval_args (x, | |
1406 | env, | |
1407 | proc))), | |
1408 | SCM_EOL)); | |
1409 | #endif | |
1410 | } | |
1411 | else | |
1412 | goto badfun; | |
1413 | case scm_tc7_subr_0: | |
1414 | case scm_tc7_dsubr: | |
1415 | case scm_tc7_cxr: | |
1416 | case scm_tc7_subr_1o: | |
1417 | case scm_tc7_subr_1: | |
1418 | case scm_tc7_subr_3: | |
1419 | scm_wrong_num_args (proc); | |
1420 | default: | |
1421 | goto badfun; | |
1422 | case scm_tc7_pws: | |
1423 | proc = SCM_PROCEDURE (proc); | |
1424 | #ifdef DEVAL | |
1425 | debug.info->a.proc = proc; | |
1426 | #endif | |
1427 | if (!SCM_CLOSUREP (proc)) | |
1428 | goto evap2; | |
1429 | /* fallthrough */ | |
1430 | case scm_tcs_closures: | |
1431 | { | |
1432 | /* clos2: */ | |
1433 | const SCM formals = SCM_CLOSURE_FORMALS (proc); | |
1434 | if (scm_is_null (formals) | |
1435 | || (scm_is_pair (formals) | |
1436 | && (scm_is_null (SCM_CDR (formals)) | |
1437 | || (scm_is_pair (SCM_CDR (formals)) | |
1438 | && scm_is_pair (SCM_CDDR (formals)))))) | |
1439 | goto wrongnumargs; | |
1440 | #ifdef DEVAL | |
1441 | env = SCM_EXTEND_ENV (formals, | |
1442 | debug.info->a.args, | |
1443 | SCM_ENV (proc)); | |
1444 | #else | |
1445 | env = SCM_EXTEND_ENV (formals, | |
1446 | scm_list_2 (arg1, arg2), | |
1447 | SCM_ENV (proc)); | |
1448 | #endif | |
1449 | x = SCM_CLOSURE_BODY (proc); | |
1450 | goto nontoplevel_begin; | |
1451 | } | |
1452 | } | |
1453 | } | |
9cc37597 | 1454 | if (SCM_UNLIKELY (!scm_is_pair (x))) |
0ee05b85 HWN |
1455 | scm_wrong_num_args (proc); |
1456 | #ifdef DEVAL | |
1457 | debug.info->a.args = scm_cons2 (arg1, arg2, | |
1458 | deval_args (x, env, proc, | |
1459 | SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); | |
1460 | #endif | |
1461 | ENTER_APPLY; | |
1462 | evap3: | |
1463 | SCM_ASRTGO (!SCM_IMP (proc), badfun); | |
1464 | switch (SCM_TYP7 (proc)) | |
1465 | { /* have 3 or more arguments */ | |
1466 | #ifdef DEVAL | |
1467 | case scm_tc7_subr_3: | |
1468 | if (!scm_is_null (SCM_CDR (x))) | |
1469 | scm_wrong_num_args (proc); | |
1470 | else | |
1471 | RETURN (SCM_SUBRF (proc) (arg1, arg2, | |
1472 | SCM_CADDR (debug.info->a.args))); | |
1473 | case scm_tc7_asubr: | |
1474 | arg1 = SCM_SUBRF(proc)(arg1, arg2); | |
1475 | arg2 = SCM_CDDR (debug.info->a.args); | |
1476 | do | |
1477 | { | |
1478 | arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); | |
1479 | arg2 = SCM_CDR (arg2); | |
1480 | } | |
1481 | while (SCM_NIMP (arg2)); | |
1482 | RETURN (arg1); | |
1483 | case scm_tc7_rpsubr: | |
1484 | if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) | |
1485 | RETURN (SCM_BOOL_F); | |
1486 | arg1 = SCM_CDDR (debug.info->a.args); | |
1487 | do | |
1488 | { | |
1489 | if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) | |
1490 | RETURN (SCM_BOOL_F); | |
1491 | arg2 = SCM_CAR (arg1); | |
1492 | arg1 = SCM_CDR (arg1); | |
1493 | } | |
1494 | while (SCM_NIMP (arg1)); | |
1495 | RETURN (SCM_BOOL_T); | |
1496 | case scm_tc7_lsubr_2: | |
1497 | RETURN (SCM_SUBRF (proc) (arg1, arg2, | |
1498 | SCM_CDDR (debug.info->a.args))); | |
1499 | case scm_tc7_lsubr: | |
1500 | RETURN (SCM_SUBRF (proc) (debug.info->a.args)); | |
1501 | case scm_tc7_smob: | |
1502 | if (!SCM_SMOB_APPLICABLE_P (proc)) | |
1503 | goto badfun; | |
1504 | RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, | |
1505 | SCM_CDDR (debug.info->a.args))); | |
1506 | case scm_tc7_cclo: | |
1507 | goto cclon; | |
1508 | case scm_tc7_pws: | |
1509 | proc = SCM_PROCEDURE (proc); | |
1510 | debug.info->a.proc = proc; | |
1511 | if (!SCM_CLOSUREP (proc)) | |
1512 | goto evap3; | |
1513 | /* fallthrough */ | |
1514 | case scm_tcs_closures: | |
1515 | { | |
1516 | const SCM formals = SCM_CLOSURE_FORMALS (proc); | |
1517 | if (scm_is_null (formals) | |
1518 | || (scm_is_pair (formals) | |
1519 | && (scm_is_null (SCM_CDR (formals)) | |
1520 | || (scm_is_pair (SCM_CDR (formals)) | |
1521 | && scm_badargsp (SCM_CDDR (formals), x))))) | |
1522 | goto wrongnumargs; | |
1523 | SCM_SET_ARGSREADY (debug); | |
1524 | env = SCM_EXTEND_ENV (formals, | |
1525 | debug.info->a.args, | |
1526 | SCM_ENV (proc)); | |
1527 | x = SCM_CLOSURE_BODY (proc); | |
1528 | goto nontoplevel_begin; | |
1529 | } | |
1530 | #else /* DEVAL */ | |
1531 | case scm_tc7_subr_3: | |
9cc37597 | 1532 | if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x)))) |
0ee05b85 HWN |
1533 | scm_wrong_num_args (proc); |
1534 | else | |
1535 | RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); | |
1536 | case scm_tc7_asubr: | |
1537 | arg1 = SCM_SUBRF (proc) (arg1, arg2); | |
1538 | do | |
1539 | { | |
1540 | arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); | |
1541 | x = SCM_CDR(x); | |
1542 | } | |
1543 | while (!scm_is_null (x)); | |
1544 | RETURN (arg1); | |
1545 | case scm_tc7_rpsubr: | |
1546 | if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2))) | |
1547 | RETURN (SCM_BOOL_F); | |
1548 | do | |
1549 | { | |
1550 | arg1 = EVALCAR (x, env); | |
1551 | if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1))) | |
1552 | RETURN (SCM_BOOL_F); | |
1553 | arg2 = arg1; | |
1554 | x = SCM_CDR (x); | |
1555 | } | |
1556 | while (!scm_is_null (x)); | |
1557 | RETURN (SCM_BOOL_T); | |
1558 | case scm_tc7_lsubr_2: | |
1559 | RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc))); | |
1560 | case scm_tc7_lsubr: | |
1561 | RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, | |
1562 | arg2, | |
1563 | scm_ceval_args (x, env, proc)))); | |
1564 | case scm_tc7_smob: | |
1565 | if (!SCM_SMOB_APPLICABLE_P (proc)) | |
1566 | goto badfun; | |
1567 | RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, | |
1568 | scm_ceval_args (x, env, proc))); | |
1569 | case scm_tc7_cclo: | |
1570 | goto cclon; | |
1571 | case scm_tc7_pws: | |
1572 | proc = SCM_PROCEDURE (proc); | |
1573 | if (!SCM_CLOSUREP (proc)) | |
1574 | goto evap3; | |
1575 | /* fallthrough */ | |
1576 | case scm_tcs_closures: | |
1577 | { | |
1578 | const SCM formals = SCM_CLOSURE_FORMALS (proc); | |
1579 | if (scm_is_null (formals) | |
1580 | || (scm_is_pair (formals) | |
1581 | && (scm_is_null (SCM_CDR (formals)) | |
1582 | || (scm_is_pair (SCM_CDR (formals)) | |
1583 | && scm_badargsp (SCM_CDDR (formals), x))))) | |
1584 | goto wrongnumargs; | |
1585 | env = SCM_EXTEND_ENV (formals, | |
1586 | scm_cons2 (arg1, | |
1587 | arg2, | |
1588 | scm_ceval_args (x, env, proc)), | |
1589 | SCM_ENV (proc)); | |
1590 | x = SCM_CLOSURE_BODY (proc); | |
1591 | goto nontoplevel_begin; | |
1592 | } | |
1593 | #endif /* DEVAL */ | |
1594 | case scm_tcs_struct: | |
1595 | if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) | |
1596 | { | |
1597 | #ifdef DEVAL | |
1598 | arg1 = debug.info->a.args; | |
1599 | #else | |
1600 | arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)); | |
1601 | #endif | |
1602 | x = SCM_ENTITY_PROCEDURE (proc); | |
1603 | goto type_dispatch; | |
1604 | } | |
1605 | else if (SCM_I_OPERATORP (proc)) | |
1606 | goto operatorn; | |
1607 | else | |
1608 | goto badfun; | |
1609 | case scm_tc7_subr_2: | |
1610 | case scm_tc7_subr_1o: | |
1611 | case scm_tc7_subr_2o: | |
1612 | case scm_tc7_subr_0: | |
1613 | case scm_tc7_dsubr: | |
1614 | case scm_tc7_cxr: | |
1615 | case scm_tc7_subr_1: | |
1616 | scm_wrong_num_args (proc); | |
1617 | default: | |
1618 | goto badfun; | |
1619 | } | |
1620 | } | |
1621 | } | |
1622 | #ifdef DEVAL | |
1623 | exit: | |
1624 | if (scm_check_exit_p && SCM_TRAPS_P) | |
1625 | if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) | |
1626 | { | |
1627 | SCM_CLEAR_TRACED_FRAME (debug); | |
1628 | arg1 = scm_make_debugobj (&debug); | |
1629 | SCM_TRAPS_P = 0; | |
1630 | arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); | |
1631 | SCM_TRAPS_P = 1; | |
1632 | if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) | |
1633 | proc = SCM_CDR (arg1); | |
1634 | } | |
1635 | scm_i_set_last_debug_frame (debug.prev); | |
1636 | return proc; | |
1637 | #endif | |
1638 | } | |
1639 | ||
1640 | ||
1641 | ||
1642 | ||
1643 | /* Apply a function to a list of arguments. | |
1644 | ||
1645 | This function is exported to the Scheme level as taking two | |
1646 | required arguments and a tail argument, as if it were: | |
1647 | (lambda (proc arg1 . args) ...) | |
1648 | Thus, if you just have a list of arguments to pass to a procedure, | |
1649 | pass the list as ARG1, and '() for ARGS. If you have some fixed | |
1650 | args, pass the first as ARG1, then cons any remaining fixed args | |
1651 | onto the front of your argument list, and pass that as ARGS. */ | |
1652 | ||
1653 | SCM | |
1654 | SCM_APPLY (SCM proc, SCM arg1, SCM args) | |
1655 | { | |
1656 | #ifdef DEVAL | |
1657 | scm_t_debug_frame debug; | |
1658 | scm_t_debug_info debug_vect_body; | |
1659 | debug.prev = scm_i_last_debug_frame (); | |
1660 | debug.status = SCM_APPLYFRAME; | |
1661 | debug.vect = &debug_vect_body; | |
1662 | debug.vect[0].a.proc = proc; | |
1663 | debug.vect[0].a.args = SCM_EOL; | |
1664 | scm_i_set_last_debug_frame (&debug); | |
1665 | #else | |
1666 | if (scm_debug_mode_p) | |
1667 | return scm_dapply (proc, arg1, args); | |
1668 | #endif | |
1669 | ||
1670 | SCM_ASRTGO (SCM_NIMP (proc), badproc); | |
1671 | ||
1672 | /* If ARGS is the empty list, then we're calling apply with only two | |
1673 | arguments --- ARG1 is the list of arguments for PROC. Whatever | |
1674 | the case, futz with things so that ARG1 is the first argument to | |
1675 | give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the | |
1676 | rest. | |
1677 | ||
1678 | Setting the debug apply frame args this way is pretty messy. | |
1679 | Perhaps we should store arg1 and args directly in the frame as | |
1680 | received, and let scm_frame_arguments unpack them, because that's | |
1681 | a relatively rare operation. This works for now; if the Guile | |
1682 | developer archives are still around, see Mikael's post of | |
1683 | 11-Apr-97. */ | |
1684 | if (scm_is_null (args)) | |
1685 | { | |
1686 | if (scm_is_null (arg1)) | |
1687 | { | |
1688 | arg1 = SCM_UNDEFINED; | |
1689 | #ifdef DEVAL | |
1690 | debug.vect[0].a.args = SCM_EOL; | |
1691 | #endif | |
1692 | } | |
1693 | else | |
1694 | { | |
1695 | #ifdef DEVAL | |
1696 | debug.vect[0].a.args = arg1; | |
1697 | #endif | |
1698 | args = SCM_CDR (arg1); | |
1699 | arg1 = SCM_CAR (arg1); | |
1700 | } | |
1701 | } | |
1702 | else | |
1703 | { | |
1704 | args = scm_nconc2last (args); | |
1705 | #ifdef DEVAL | |
1706 | debug.vect[0].a.args = scm_cons (arg1, args); | |
1707 | #endif | |
1708 | } | |
1709 | #ifdef DEVAL | |
1710 | if (SCM_ENTER_FRAME_P && SCM_TRAPS_P) | |
1711 | { | |
1712 | SCM tmp = scm_make_debugobj (&debug); | |
1713 | SCM_TRAPS_P = 0; | |
1714 | scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp); | |
1715 | SCM_TRAPS_P = 1; | |
1716 | } | |
1717 | ENTER_APPLY; | |
1718 | #endif | |
1719 | tail: | |
1720 | switch (SCM_TYP7 (proc)) | |
1721 | { | |
1722 | case scm_tc7_subr_2o: | |
9cc37597 | 1723 | if (SCM_UNLIKELY (SCM_UNBNDP (arg1))) |
0ee05b85 HWN |
1724 | scm_wrong_num_args (proc); |
1725 | if (scm_is_null (args)) | |
1726 | args = SCM_UNDEFINED; | |
1727 | else | |
1728 | { | |
9cc37597 | 1729 | if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args)))) |
0ee05b85 HWN |
1730 | scm_wrong_num_args (proc); |
1731 | args = SCM_CAR (args); | |
1732 | } | |
1733 | RETURN (SCM_SUBRF (proc) (arg1, args)); | |
1734 | case scm_tc7_subr_2: | |
9cc37597 LC |
1735 | if (SCM_UNLIKELY (scm_is_null (args) || |
1736 | !scm_is_null (SCM_CDR (args)))) | |
0ee05b85 HWN |
1737 | scm_wrong_num_args (proc); |
1738 | args = SCM_CAR (args); | |
1739 | RETURN (SCM_SUBRF (proc) (arg1, args)); | |
1740 | case scm_tc7_subr_0: | |
9cc37597 | 1741 | if (SCM_UNLIKELY (!SCM_UNBNDP (arg1))) |
0ee05b85 HWN |
1742 | scm_wrong_num_args (proc); |
1743 | else | |
1744 | RETURN (SCM_SUBRF (proc) ()); | |
1745 | case scm_tc7_subr_1: | |
9cc37597 | 1746 | if (SCM_UNLIKELY (SCM_UNBNDP (arg1))) |
0ee05b85 HWN |
1747 | scm_wrong_num_args (proc); |
1748 | case scm_tc7_subr_1o: | |
9cc37597 | 1749 | if (SCM_UNLIKELY (!scm_is_null (args))) |
0ee05b85 HWN |
1750 | scm_wrong_num_args (proc); |
1751 | else | |
1752 | RETURN (SCM_SUBRF (proc) (arg1)); | |
1753 | case scm_tc7_dsubr: | |
9cc37597 | 1754 | if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) |
0ee05b85 HWN |
1755 | scm_wrong_num_args (proc); |
1756 | if (SCM_I_INUMP (arg1)) | |
1757 | { | |
1758 | RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)))); | |
1759 | } | |
1760 | else if (SCM_REALP (arg1)) | |
1761 | { | |
1762 | RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); | |
1763 | } | |
1764 | else if (SCM_BIGP (arg1)) | |
1765 | { | |
1766 | RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); | |
1767 | } | |
1768 | else if (SCM_FRACTIONP (arg1)) | |
1769 | { | |
1770 | RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)))); | |
1771 | } | |
1772 | SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, | |
1773 | SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc))); | |
1774 | case scm_tc7_cxr: | |
9cc37597 | 1775 | if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) |
0ee05b85 HWN |
1776 | scm_wrong_num_args (proc); |
1777 | RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); | |
1778 | case scm_tc7_subr_3: | |
9cc37597 LC |
1779 | if (SCM_UNLIKELY (scm_is_null (args) |
1780 | || scm_is_null (SCM_CDR (args)) | |
1781 | || !scm_is_null (SCM_CDDR (args)))) | |
0ee05b85 HWN |
1782 | scm_wrong_num_args (proc); |
1783 | else | |
1784 | RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); | |
1785 | case scm_tc7_lsubr: | |
1786 | #ifdef DEVAL | |
1787 | RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)); | |
1788 | #else | |
1789 | RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); | |
1790 | #endif | |
1791 | case scm_tc7_lsubr_2: | |
9cc37597 | 1792 | if (SCM_UNLIKELY (!scm_is_pair (args))) |
0ee05b85 HWN |
1793 | scm_wrong_num_args (proc); |
1794 | else | |
1795 | RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); | |
1796 | case scm_tc7_asubr: | |
1797 | if (scm_is_null (args)) | |
1798 | RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); | |
1799 | while (SCM_NIMP (args)) | |
1800 | { | |
1801 | SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); | |
1802 | arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args)); | |
1803 | args = SCM_CDR (args); | |
1804 | } | |
1805 | RETURN (arg1); | |
1806 | case scm_tc7_rpsubr: | |
1807 | if (scm_is_null (args)) | |
1808 | RETURN (SCM_BOOL_T); | |
1809 | while (SCM_NIMP (args)) | |
1810 | { | |
1811 | SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply"); | |
1812 | if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args)))) | |
1813 | RETURN (SCM_BOOL_F); | |
1814 | arg1 = SCM_CAR (args); | |
1815 | args = SCM_CDR (args); | |
1816 | } | |
1817 | RETURN (SCM_BOOL_T); | |
1818 | case scm_tcs_closures: | |
1819 | #ifdef DEVAL | |
1820 | arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args); | |
1821 | #else | |
1822 | arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); | |
1823 | #endif | |
9cc37597 | 1824 | if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))) |
0ee05b85 HWN |
1825 | scm_wrong_num_args (proc); |
1826 | ||
1827 | /* Copy argument list */ | |
1828 | if (SCM_IMP (arg1)) | |
1829 | args = arg1; | |
1830 | else | |
1831 | { | |
1832 | SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); | |
1833 | for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1)) | |
1834 | { | |
1835 | SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); | |
1836 | tl = SCM_CDR (tl); | |
1837 | } | |
1838 | SCM_SETCDR (tl, arg1); | |
1839 | } | |
1840 | ||
1841 | args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), | |
1842 | args, | |
1843 | SCM_ENV (proc)); | |
1844 | proc = SCM_CLOSURE_BODY (proc); | |
1845 | again: | |
1846 | arg1 = SCM_CDR (proc); | |
1847 | while (!scm_is_null (arg1)) | |
1848 | { | |
1849 | if (SCM_IMP (SCM_CAR (proc))) | |
1850 | { | |
1851 | if (SCM_ISYMP (SCM_CAR (proc))) | |
1852 | { | |
1853 | scm_dynwind_begin (0); | |
1854 | scm_i_dynwind_pthread_mutex_lock (&source_mutex); | |
1855 | /* check for race condition */ | |
1856 | if (SCM_ISYMP (SCM_CAR (proc))) | |
1857 | m_expand_body (proc, args); | |
1858 | scm_dynwind_end (); | |
1859 | goto again; | |
1860 | } | |
1861 | else | |
1862 | SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc)); | |
1863 | } | |
1864 | else | |
1865 | (void) EVAL (SCM_CAR (proc), args); | |
1866 | proc = arg1; | |
1867 | arg1 = SCM_CDR (proc); | |
1868 | } | |
1869 | RETURN (EVALCAR (proc, args)); | |
1870 | case scm_tc7_smob: | |
1871 | if (!SCM_SMOB_APPLICABLE_P (proc)) | |
1872 | goto badproc; | |
1873 | if (SCM_UNBNDP (arg1)) | |
1874 | RETURN (SCM_SMOB_APPLY_0 (proc)); | |
1875 | else if (scm_is_null (args)) | |
1876 | RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); | |
1877 | else if (scm_is_null (SCM_CDR (args))) | |
1878 | RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))); | |
1879 | else | |
1880 | RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); | |
1881 | case scm_tc7_cclo: | |
1882 | #ifdef DEVAL | |
1883 | args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); | |
1884 | arg1 = proc; | |
1885 | proc = SCM_CCLO_SUBR (proc); | |
1886 | debug.vect[0].a.proc = proc; | |
1887 | debug.vect[0].a.args = scm_cons (arg1, args); | |
1888 | #else | |
1889 | args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); | |
1890 | arg1 = proc; | |
1891 | proc = SCM_CCLO_SUBR (proc); | |
1892 | #endif | |
1893 | goto tail; | |
1894 | case scm_tc7_pws: | |
1895 | proc = SCM_PROCEDURE (proc); | |
1896 | #ifdef DEVAL | |
1897 | debug.vect[0].a.proc = proc; | |
1898 | #endif | |
1899 | goto tail; | |
1900 | case scm_tcs_struct: | |
1901 | if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) | |
1902 | { | |
1903 | #ifdef DEVAL | |
1904 | args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); | |
1905 | #else | |
1906 | args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); | |
1907 | #endif | |
1908 | RETURN (scm_apply_generic (proc, args)); | |
1909 | } | |
1910 | else if (SCM_I_OPERATORP (proc)) | |
1911 | { | |
1912 | /* operator */ | |
1913 | #ifdef DEVAL | |
1914 | args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); | |
1915 | #else | |
1916 | args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); | |
1917 | #endif | |
1918 | arg1 = proc; | |
1919 | proc = (SCM_I_ENTITYP (proc) | |
1920 | ? SCM_ENTITY_PROCEDURE (proc) | |
1921 | : SCM_OPERATOR_PROCEDURE (proc)); | |
1922 | #ifdef DEVAL | |
1923 | debug.vect[0].a.proc = proc; | |
1924 | debug.vect[0].a.args = scm_cons (arg1, args); | |
1925 | #endif | |
1926 | if (SCM_NIMP (proc)) | |
1927 | goto tail; | |
1928 | else | |
1929 | goto badproc; | |
1930 | } | |
1931 | else | |
1932 | goto badproc; | |
1933 | default: | |
1934 | badproc: | |
1935 | scm_wrong_type_arg ("apply", SCM_ARG1, proc); | |
1936 | } | |
1937 | #ifdef DEVAL | |
1938 | exit: | |
1939 | if (scm_check_exit_p && SCM_TRAPS_P) | |
1940 | if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) | |
1941 | { | |
1942 | SCM_CLEAR_TRACED_FRAME (debug); | |
1943 | arg1 = scm_make_debugobj (&debug); | |
1944 | SCM_TRAPS_P = 0; | |
1945 | arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc); | |
1946 | SCM_TRAPS_P = 1; | |
1947 | if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead)) | |
1948 | proc = SCM_CDR (arg1); | |
1949 | } | |
1950 | scm_i_set_last_debug_frame (debug.prev); | |
1951 | return proc; | |
1952 | #endif | |
1953 | } | |
1954 |