HCoop / bpt / guile.git / blob
? search:


407a64281afca0a2310f75e1b4ea8cd4c9e8e268
[bpt/guile.git] / libguile / eval.i.c
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
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
684 if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
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)):
735 RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
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 }
858 /* Fewer arguments than specifiers => CAR != CLASS */
859 if (!SCM_CLASSP (SCM_CAR (z)))
860 goto apply_cmethod;
861 next_method:
862 hash_value = (hash_value + 1) & mask;
863 } while (hash_value != cache_end_pos);
864
865 /* No appropriate method was found in the cache. */
866 z = scm_memoize_method (x, arg1);
867
868 apply_cmethod: /* inputs: z, arg1 */
869 {
870 if (scm_is_pair (z)) {
871 SCM formals = SCM_CMETHOD_FORMALS (z);
872 env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
873 x = SCM_CMETHOD_BODY (z);
874 goto nontoplevel_begin;
875 } else {
876 proc = z;
877 PREP_APPLY (proc, arg1);
878 goto apply_proc;
879 }
880 }
881 }
882 }
883
884
885 case (ISYMNUM (SCM_IM_SLOT_REF)):
886 x = SCM_CDR (x);
887 {
888 SCM instance = EVALCAR (x, env);
889 unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
890 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
891 }
892
893
894 case (ISYMNUM (SCM_IM_SLOT_SET_X)):
895 x = SCM_CDR (x);
896 {
897 SCM instance = EVALCAR (x, env);
898 unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
899 SCM value = EVALCAR (SCM_CDDR (x), env);
900 SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
901 RETURN (SCM_UNSPECIFIED);
902 }
903
904
905 #if SCM_ENABLE_ELISP
906
907 case (ISYMNUM (SCM_IM_NIL_COND)):
908 {
909 SCM test_form = SCM_CDR (x);
910 x = SCM_CDR (test_form);
911 while (!SCM_NULL_OR_NIL_P (x))
912 {
913 SCM test_result = EVALCAR (test_form, env);
914 if (!(scm_is_false (test_result)
915 || SCM_NULL_OR_NIL_P (test_result)))
916 {
917 if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
918 RETURN (test_result);
919 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
920 goto carloop;
921 }
922 else
923 {
924 test_form = SCM_CDR (x);
925 x = SCM_CDR (test_form);
926 }
927 }
928 x = test_form;
929 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
930 goto carloop;
931 }
932
933 #endif /* SCM_ENABLE_ELISP */
934
935 case (ISYMNUM (SCM_IM_BIND)):
936 {
937 SCM vars, exps, vals;
938
939 x = SCM_CDR (x);
940 vars = SCM_CAAR (x);
941 exps = SCM_CDAR (x);
942 vals = SCM_EOL;
943 while (!scm_is_null (exps))
944 {
945 vals = scm_cons (EVALCAR (exps, env), vals);
946 exps = SCM_CDR (exps);
947 }
948
949 scm_swap_bindings (vars, vals);
950 scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
951
952 /* Ignore all but the last evaluation result. */
953 for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
954 {
955 if (scm_is_pair (SCM_CAR (x)))
956 CEVAL (SCM_CAR (x), env);
957 }
958 proc = EVALCAR (x, env);
959
960 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
961 scm_swap_bindings (vars, vals);
962
963 RETURN (proc);
964 }
965
966
967 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
968 {
969 SCM producer;
970
971 x = SCM_CDR (x);
972 producer = EVALCAR (x, env);
973 x = SCM_CDR (x);
974 proc = EVALCAR (x, env); /* proc is the consumer. */
975 arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
976 if (SCM_VALUESP (arg1))
977 {
978 /* The list of arguments is not copied. Rather, it is assumed
979 * that this has been done by the 'values' procedure. */
980 arg1 = scm_struct_ref (arg1, SCM_INUM0);
981 }
982 else
983 {
984 arg1 = scm_list_1 (arg1);
985 }
986 PREP_APPLY (proc, arg1);
987 goto apply_proc;
988 }
989
990
991 default:
992 break;
993 }
994 }
995 else
996 {
997 if (SCM_VARIABLEP (SCM_CAR (x)))
998 proc = SCM_VARIABLE_REF (SCM_CAR (x));
999 else if (SCM_ILOCP (SCM_CAR (x)))
1000 proc = *scm_ilookup (SCM_CAR (x), env);
1001 else if (scm_is_pair (SCM_CAR (x)))
1002 proc = CEVAL (SCM_CAR (x), env);
1003 else if (scm_is_symbol (SCM_CAR (x)))
1004 {
1005 SCM orig_sym = SCM_CAR (x);
1006 {
1007 SCM *location = scm_lookupcar1 (x, env, 1);
1008 if (location == NULL)
1009 {
1010 /* we have lost the race, start again. */
1011 goto dispatch;
1012 }
1013 proc = *location;
1014 #ifdef DEVAL
1015 if (scm_check_memoize_p && SCM_TRAPS_P)
1016 {
1017 SCM_CLEAR_TRACED_FRAME (debug);
1018 SCM arg1 = scm_make_debugobj (&debug);
1019 SCM retval = SCM_BOOL_T;
1020 SCM_TRAPS_P = 0;
1021 retval = scm_call_4 (SCM_MEMOIZE_HDLR,
1022 scm_sym_memoize_symbol,
1023 arg1, x, env);
1024
1025 /*
1026 do something with retval?
1027 */
1028 SCM_TRAPS_P = 1;
1029 }
1030 #endif
1031 }
1032
1033 if (SCM_MACROP (proc))
1034 {
1035 SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
1036 lookupcar */
1037 handle_a_macro: /* inputs: x, env, proc */
1038 #ifdef DEVAL
1039 /* Set a flag during macro expansion so that macro
1040 application frames can be deleted from the backtrace. */
1041 SCM_SET_MACROEXP (debug);
1042 #endif
1043 arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
1044 scm_cons (env, scm_listofnull));
1045 #ifdef DEVAL
1046 SCM_CLEAR_MACROEXP (debug);
1047 #endif
1048 switch (SCM_MACRO_TYPE (proc))
1049 {
1050 case 3:
1051 case 2:
1052 if (!scm_is_pair (arg1))
1053 arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
1054
1055 assert (!scm_is_eq (x, SCM_CAR (arg1))
1056 && !scm_is_eq (x, SCM_CDR (arg1)));
1057
1058 #ifdef DEVAL
1059 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
1060 {
1061 SCM_CRITICAL_SECTION_START;
1062 SCM_SETCAR (x, SCM_CAR (arg1));
1063 SCM_SETCDR (x, SCM_CDR (arg1));
1064 SCM_CRITICAL_SECTION_END;
1065 goto dispatch;
1066 }
1067 /* Prevent memoizing of debug info expression. */
1068 debug.info->e.exp = scm_cons_source (debug.info->e.exp,
1069 SCM_CAR (x),
1070 SCM_CDR (x));
1071 #endif
1072 SCM_CRITICAL_SECTION_START;
1073 SCM_SETCAR (x, SCM_CAR (arg1));
1074 SCM_SETCDR (x, SCM_CDR (arg1));
1075 SCM_CRITICAL_SECTION_END;
1076 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1077 goto loop;
1078 #if SCM_ENABLE_DEPRECATED == 1
1079 case 1:
1080 x = arg1;
1081 if (SCM_NIMP (x))
1082 {
1083 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1084 goto loop;
1085 }
1086 else
1087 RETURN (arg1);
1088 #endif
1089 case 0:
1090 RETURN (arg1);
1091 }
1092 }
1093 }
1094 else
1095 proc = SCM_CAR (x);
1096
1097 if (SCM_MACROP (proc))
1098 goto handle_a_macro;
1099 }
1100
1101
1102 /* When reaching this part of the code, the following is granted: Variable x
1103 * holds the first pair of an expression of the form (<function> arg ...).
1104 * Variable proc holds the object that resulted from the evaluation of
1105 * <function>. In the following, the arguments (if any) will be evaluated,
1106 * and proc will be applied to them. If proc does not really hold a
1107 * function object, this will be signalled as an error on the scheme
1108 * level. If the number of arguments does not match the number of arguments
1109 * that are allowed to be passed to proc, also an error on the scheme level
1110 * will be signalled. */
1111
1112 PREP_APPLY (proc, SCM_EOL);
1113 if (scm_is_null (SCM_CDR (x))) {
1114 ENTER_APPLY;
1115 evap0:
1116 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1117 switch (SCM_TYP7 (proc))
1118 { /* no arguments given */
1119 case scm_tc7_subr_0:
1120 RETURN (SCM_SUBRF (proc) ());
1121 case scm_tc7_subr_1o:
1122 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
1123 case scm_tc7_lsubr:
1124 RETURN (SCM_SUBRF (proc) (SCM_EOL));
1125 case scm_tc7_rpsubr:
1126 RETURN (SCM_BOOL_T);
1127 case scm_tc7_asubr:
1128 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
1129 case scm_tc7_smob:
1130 if (!SCM_SMOB_APPLICABLE_P (proc))
1131 goto badfun;
1132 RETURN (SCM_SMOB_APPLY_0 (proc));
1133 case scm_tc7_cclo:
1134 arg1 = proc;
1135 proc = SCM_CCLO_SUBR (proc);
1136 #ifdef DEVAL
1137 debug.info->a.proc = proc;
1138 debug.info->a.args = scm_list_1 (arg1);
1139 #endif
1140 goto evap1;
1141 case scm_tc7_pws:
1142 proc = SCM_PROCEDURE (proc);
1143 #ifdef DEVAL
1144 debug.info->a.proc = proc;
1145 #endif
1146 if (!SCM_CLOSUREP (proc))
1147 goto evap0;
1148 /* fallthrough */
1149 case scm_tcs_closures:
1150 {
1151 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1152 if (SCM_UNLIKELY (scm_is_pair (formals)))
1153 goto wrongnumargs;
1154 x = SCM_CLOSURE_BODY (proc);
1155 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
1156 goto nontoplevel_begin;
1157 }
1158 case scm_tcs_struct:
1159 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1160 {
1161 x = SCM_ENTITY_PROCEDURE (proc);
1162 arg1 = SCM_EOL;
1163 goto type_dispatch;
1164 }
1165 else if (SCM_I_OPERATORP (proc))
1166 {
1167 arg1 = proc;
1168 proc = (SCM_I_ENTITYP (proc)
1169 ? SCM_ENTITY_PROCEDURE (proc)
1170 : SCM_OPERATOR_PROCEDURE (proc));
1171 #ifdef DEVAL
1172 debug.info->a.proc = proc;
1173 debug.info->a.args = scm_list_1 (arg1);
1174 #endif
1175 goto evap1;
1176 }
1177 else
1178 goto badfun;
1179 case scm_tc7_subr_1:
1180 case scm_tc7_subr_2:
1181 case scm_tc7_subr_2o:
1182 case scm_tc7_dsubr:
1183 case scm_tc7_cxr:
1184 case scm_tc7_subr_3:
1185 case scm_tc7_lsubr_2:
1186 wrongnumargs:
1187 scm_wrong_num_args (proc);
1188 default:
1189 badfun:
1190 scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
1191 }
1192 }
1193
1194 /* must handle macros by here */
1195 x = SCM_CDR (x);
1196 if (SCM_LIKELY (scm_is_pair (x)))
1197 arg1 = EVALCAR (x, env);
1198 else
1199 scm_wrong_num_args (proc);
1200 #ifdef DEVAL
1201 debug.info->a.args = scm_list_1 (arg1);
1202 #endif
1203 x = SCM_CDR (x);
1204 {
1205 SCM arg2;
1206 if (scm_is_null (x))
1207 {
1208 ENTER_APPLY;
1209 evap1: /* inputs: proc, arg1 */
1210 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1211 switch (SCM_TYP7 (proc))
1212 { /* have one argument in arg1 */
1213 case scm_tc7_subr_2o:
1214 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1215 case scm_tc7_subr_1:
1216 case scm_tc7_subr_1o:
1217 RETURN (SCM_SUBRF (proc) (arg1));
1218 case scm_tc7_dsubr:
1219 if (SCM_I_INUMP (arg1))
1220 {
1221 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
1222 }
1223 else if (SCM_REALP (arg1))
1224 {
1225 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
1226 }
1227 else if (SCM_BIGP (arg1))
1228 {
1229 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
1230 }
1231 else if (SCM_FRACTIONP (arg1))
1232 {
1233 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
1234 }
1235 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
1236 SCM_ARG1,
1237 scm_i_symbol_chars (SCM_SNAME (proc)));
1238 case scm_tc7_cxr:
1239 RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
1240 case scm_tc7_rpsubr:
1241 RETURN (SCM_BOOL_T);
1242 case scm_tc7_asubr:
1243 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1244 case scm_tc7_lsubr:
1245 #ifdef DEVAL
1246 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1247 #else
1248 RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
1249 #endif
1250 case scm_tc7_smob:
1251 if (!SCM_SMOB_APPLICABLE_P (proc))
1252 goto badfun;
1253 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
1254 case scm_tc7_cclo:
1255 arg2 = arg1;
1256 arg1 = proc;
1257 proc = SCM_CCLO_SUBR (proc);
1258 #ifdef DEVAL
1259 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
1260 debug.info->a.proc = proc;
1261 #endif
1262 goto evap2;
1263 case scm_tc7_pws:
1264 proc = SCM_PROCEDURE (proc);
1265 #ifdef DEVAL
1266 debug.info->a.proc = proc;
1267 #endif
1268 if (!SCM_CLOSUREP (proc))
1269 goto evap1;
1270 /* fallthrough */
1271 case scm_tcs_closures:
1272 {
1273 /* clos1: */
1274 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1275 if (scm_is_null (formals)
1276 || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
1277 goto wrongnumargs;
1278 x = SCM_CLOSURE_BODY (proc);
1279 #ifdef DEVAL
1280 env = SCM_EXTEND_ENV (formals,
1281 debug.info->a.args,
1282 SCM_ENV (proc));
1283 #else
1284 env = SCM_EXTEND_ENV (formals,
1285 scm_list_1 (arg1),
1286 SCM_ENV (proc));
1287 #endif
1288 goto nontoplevel_begin;
1289 }
1290 case scm_tcs_struct:
1291 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1292 {
1293 x = SCM_ENTITY_PROCEDURE (proc);
1294 #ifdef DEVAL
1295 arg1 = debug.info->a.args;
1296 #else
1297 arg1 = scm_list_1 (arg1);
1298 #endif
1299 goto type_dispatch;
1300 }
1301 else if (SCM_I_OPERATORP (proc))
1302 {
1303 arg2 = arg1;
1304 arg1 = proc;
1305 proc = (SCM_I_ENTITYP (proc)
1306 ? SCM_ENTITY_PROCEDURE (proc)
1307 : SCM_OPERATOR_PROCEDURE (proc));
1308 #ifdef DEVAL
1309 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
1310 debug.info->a.proc = proc;
1311 #endif
1312 goto evap2;
1313 }
1314 else
1315 goto badfun;
1316 case scm_tc7_subr_2:
1317 case scm_tc7_subr_0:
1318 case scm_tc7_subr_3:
1319 case scm_tc7_lsubr_2:
1320 scm_wrong_num_args (proc);
1321 default:
1322 goto badfun;
1323 }
1324 }
1325 if (SCM_LIKELY (scm_is_pair (x)))
1326 arg2 = EVALCAR (x, env);
1327 else
1328 scm_wrong_num_args (proc);
1329
1330 { /* have two or more arguments */
1331 #ifdef DEVAL
1332 debug.info->a.args = scm_list_2 (arg1, arg2);
1333 #endif
1334 x = SCM_CDR (x);
1335 if (scm_is_null (x)) {
1336 ENTER_APPLY;
1337 evap2:
1338 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1339 switch (SCM_TYP7 (proc))
1340 { /* have two arguments */
1341 case scm_tc7_subr_2:
1342 case scm_tc7_subr_2o:
1343 RETURN (SCM_SUBRF (proc) (arg1, arg2));
1344 case scm_tc7_lsubr:
1345 #ifdef DEVAL
1346 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1347 #else
1348 RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
1349 #endif
1350 case scm_tc7_lsubr_2:
1351 RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
1352 case scm_tc7_rpsubr:
1353 case scm_tc7_asubr:
1354 RETURN (SCM_SUBRF (proc) (arg1, arg2));
1355 case scm_tc7_smob:
1356 if (!SCM_SMOB_APPLICABLE_P (proc))
1357 goto badfun;
1358 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
1359 cclon:
1360 case scm_tc7_cclo:
1361 #ifdef DEVAL
1362 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
1363 scm_cons (proc, debug.info->a.args),
1364 SCM_EOL));
1365 #else
1366 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
1367 scm_cons2 (proc, arg1,
1368 scm_cons (arg2,
1369 scm_ceval_args (x,
1370 env,
1371 proc))),
1372 SCM_EOL));
1373 #endif
1374 case scm_tcs_struct:
1375 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1376 {
1377 x = SCM_ENTITY_PROCEDURE (proc);
1378 #ifdef DEVAL
1379 arg1 = debug.info->a.args;
1380 #else
1381 arg1 = scm_list_2 (arg1, arg2);
1382 #endif
1383 goto type_dispatch;
1384 }
1385 else if (SCM_I_OPERATORP (proc))
1386 {
1387 operatorn:
1388 #ifdef DEVAL
1389 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
1390 ? SCM_ENTITY_PROCEDURE (proc)
1391 : SCM_OPERATOR_PROCEDURE (proc),
1392 scm_cons (proc, debug.info->a.args),
1393 SCM_EOL));
1394 #else
1395 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
1396 ? SCM_ENTITY_PROCEDURE (proc)
1397 : SCM_OPERATOR_PROCEDURE (proc),
1398 scm_cons2 (proc, arg1,
1399 scm_cons (arg2,
1400 scm_ceval_args (x,
1401 env,
1402 proc))),
1403 SCM_EOL));
1404 #endif
1405 }
1406 else
1407 goto badfun;
1408 case scm_tc7_subr_0:
1409 case scm_tc7_dsubr:
1410 case scm_tc7_cxr:
1411 case scm_tc7_subr_1o:
1412 case scm_tc7_subr_1:
1413 case scm_tc7_subr_3:
1414 scm_wrong_num_args (proc);
1415 default:
1416 goto badfun;
1417 case scm_tc7_pws:
1418 proc = SCM_PROCEDURE (proc);
1419 #ifdef DEVAL
1420 debug.info->a.proc = proc;
1421 #endif
1422 if (!SCM_CLOSUREP (proc))
1423 goto evap2;
1424 /* fallthrough */
1425 case scm_tcs_closures:
1426 {
1427 /* clos2: */
1428 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1429 if (scm_is_null (formals)
1430 || (scm_is_pair (formals)
1431 && (scm_is_null (SCM_CDR (formals))
1432 || (scm_is_pair (SCM_CDR (formals))
1433 && scm_is_pair (SCM_CDDR (formals))))))
1434 goto wrongnumargs;
1435 #ifdef DEVAL
1436 env = SCM_EXTEND_ENV (formals,
1437 debug.info->a.args,
1438 SCM_ENV (proc));
1439 #else
1440 env = SCM_EXTEND_ENV (formals,
1441 scm_list_2 (arg1, arg2),
1442 SCM_ENV (proc));
1443 #endif
1444 x = SCM_CLOSURE_BODY (proc);
1445 goto nontoplevel_begin;
1446 }
1447 }
1448 }
1449 if (SCM_UNLIKELY (!scm_is_pair (x)))
1450 scm_wrong_num_args (proc);
1451 #ifdef DEVAL
1452 debug.info->a.args = scm_cons2 (arg1, arg2,
1453 deval_args (x, env, proc,
1454 SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
1455 #endif
1456 ENTER_APPLY;
1457 evap3:
1458 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1459 switch (SCM_TYP7 (proc))
1460 { /* have 3 or more arguments */
1461 #ifdef DEVAL
1462 case scm_tc7_subr_3:
1463 if (!scm_is_null (SCM_CDR (x)))
1464 scm_wrong_num_args (proc);
1465 else
1466 RETURN (SCM_SUBRF (proc) (arg1, arg2,
1467 SCM_CADDR (debug.info->a.args)));
1468 case scm_tc7_asubr:
1469 arg1 = SCM_SUBRF(proc)(arg1, arg2);
1470 arg2 = SCM_CDDR (debug.info->a.args);
1471 do
1472 {
1473 arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
1474 arg2 = SCM_CDR (arg2);
1475 }
1476 while (SCM_NIMP (arg2));
1477 RETURN (arg1);
1478 case scm_tc7_rpsubr:
1479 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
1480 RETURN (SCM_BOOL_F);
1481 arg1 = SCM_CDDR (debug.info->a.args);
1482 do
1483 {
1484 if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
1485 RETURN (SCM_BOOL_F);
1486 arg2 = SCM_CAR (arg1);
1487 arg1 = SCM_CDR (arg1);
1488 }
1489 while (SCM_NIMP (arg1));
1490 RETURN (SCM_BOOL_T);
1491 case scm_tc7_lsubr_2:
1492 RETURN (SCM_SUBRF (proc) (arg1, arg2,
1493 SCM_CDDR (debug.info->a.args)));
1494 case scm_tc7_lsubr:
1495 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1496 case scm_tc7_smob:
1497 if (!SCM_SMOB_APPLICABLE_P (proc))
1498 goto badfun;
1499 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
1500 SCM_CDDR (debug.info->a.args)));
1501 case scm_tc7_cclo:
1502 goto cclon;
1503 case scm_tc7_pws:
1504 proc = SCM_PROCEDURE (proc);
1505 debug.info->a.proc = proc;
1506 if (!SCM_CLOSUREP (proc))
1507 goto evap3;
1508 /* fallthrough */
1509 case scm_tcs_closures:
1510 {
1511 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1512 if (scm_is_null (formals)
1513 || (scm_is_pair (formals)
1514 && (scm_is_null (SCM_CDR (formals))
1515 || (scm_is_pair (SCM_CDR (formals))
1516 && scm_badargsp (SCM_CDDR (formals), x)))))
1517 goto wrongnumargs;
1518 SCM_SET_ARGSREADY (debug);
1519 env = SCM_EXTEND_ENV (formals,
1520 debug.info->a.args,
1521 SCM_ENV (proc));
1522 x = SCM_CLOSURE_BODY (proc);
1523 goto nontoplevel_begin;
1524 }
1525 #else /* DEVAL */
1526 case scm_tc7_subr_3:
1527 if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
1528 scm_wrong_num_args (proc);
1529 else
1530 RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
1531 case scm_tc7_asubr:
1532 arg1 = SCM_SUBRF (proc) (arg1, arg2);
1533 do
1534 {
1535 arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
1536 x = SCM_CDR(x);
1537 }
1538 while (!scm_is_null (x));
1539 RETURN (arg1);
1540 case scm_tc7_rpsubr:
1541 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
1542 RETURN (SCM_BOOL_F);
1543 do
1544 {
1545 arg1 = EVALCAR (x, env);
1546 if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
1547 RETURN (SCM_BOOL_F);
1548 arg2 = arg1;
1549 x = SCM_CDR (x);
1550 }
1551 while (!scm_is_null (x));
1552 RETURN (SCM_BOOL_T);
1553 case scm_tc7_lsubr_2:
1554 RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc)));
1555 case scm_tc7_lsubr:
1556 RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
1557 arg2,
1558 scm_ceval_args (x, env, proc))));
1559 case scm_tc7_smob:
1560 if (!SCM_SMOB_APPLICABLE_P (proc))
1561 goto badfun;
1562 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
1563 scm_ceval_args (x, env, proc)));
1564 case scm_tc7_cclo:
1565 goto cclon;
1566 case scm_tc7_pws:
1567 proc = SCM_PROCEDURE (proc);
1568 if (!SCM_CLOSUREP (proc))
1569 goto evap3;
1570 /* fallthrough */
1571 case scm_tcs_closures:
1572 {
1573 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1574 if (scm_is_null (formals)
1575 || (scm_is_pair (formals)
1576 && (scm_is_null (SCM_CDR (formals))
1577 || (scm_is_pair (SCM_CDR (formals))
1578 && scm_badargsp (SCM_CDDR (formals), x)))))
1579 goto wrongnumargs;
1580 env = SCM_EXTEND_ENV (formals,
1581 scm_cons2 (arg1,
1582 arg2,
1583 scm_ceval_args (x, env, proc)),
1584 SCM_ENV (proc));
1585 x = SCM_CLOSURE_BODY (proc);
1586 goto nontoplevel_begin;
1587 }
1588 #endif /* DEVAL */
1589 case scm_tcs_struct:
1590 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1591 {
1592 #ifdef DEVAL
1593 arg1 = debug.info->a.args;
1594 #else
1595 arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
1596 #endif
1597 x = SCM_ENTITY_PROCEDURE (proc);
1598 goto type_dispatch;
1599 }
1600 else if (SCM_I_OPERATORP (proc))
1601 goto operatorn;
1602 else
1603 goto badfun;
1604 case scm_tc7_subr_2:
1605 case scm_tc7_subr_1o:
1606 case scm_tc7_subr_2o:
1607 case scm_tc7_subr_0:
1608 case scm_tc7_dsubr:
1609 case scm_tc7_cxr:
1610 case scm_tc7_subr_1:
1611 scm_wrong_num_args (proc);
1612 default:
1613 goto badfun;
1614 }
1615 }
1616 }
1617 #ifdef DEVAL
1618 exit:
1619 if (scm_check_exit_p && SCM_TRAPS_P)
1620 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
1621 {
1622 SCM_CLEAR_TRACED_FRAME (debug);
1623 arg1 = scm_make_debugobj (&debug);
1624 SCM_TRAPS_P = 0;
1625 arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
1626 SCM_TRAPS_P = 1;
1627 if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
1628 proc = SCM_CDR (arg1);
1629 }
1630 scm_i_set_last_debug_frame (debug.prev);
1631 return proc;
1632 #endif
1633 }
1634
1635
1636
1637
1638 /* Apply a function to a list of arguments.
1639
1640 This function is exported to the Scheme level as taking two
1641 required arguments and a tail argument, as if it were:
1642 (lambda (proc arg1 . args) ...)
1643 Thus, if you just have a list of arguments to pass to a procedure,
1644 pass the list as ARG1, and '() for ARGS. If you have some fixed
1645 args, pass the first as ARG1, then cons any remaining fixed args
1646 onto the front of your argument list, and pass that as ARGS. */
1647
1648 SCM
1649 SCM_APPLY (SCM proc, SCM arg1, SCM args)
1650 {
1651 #ifdef DEVAL
1652 scm_t_debug_frame debug;
1653 scm_t_debug_info debug_vect_body;
1654 debug.prev = scm_i_last_debug_frame ();
1655 debug.status = SCM_APPLYFRAME;
1656 debug.vect = &debug_vect_body;
1657 debug.vect[0].a.proc = proc;
1658 debug.vect[0].a.args = SCM_EOL;
1659 scm_i_set_last_debug_frame (&debug);
1660 #else
1661 if (scm_debug_mode_p)
1662 return scm_dapply (proc, arg1, args);
1663 #endif
1664
1665 SCM_ASRTGO (SCM_NIMP (proc), badproc);
1666
1667 /* If ARGS is the empty list, then we're calling apply with only two
1668 arguments --- ARG1 is the list of arguments for PROC. Whatever
1669 the case, futz with things so that ARG1 is the first argument to
1670 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
1671 rest.
1672
1673 Setting the debug apply frame args this way is pretty messy.
1674 Perhaps we should store arg1 and args directly in the frame as
1675 received, and let scm_frame_arguments unpack them, because that's
1676 a relatively rare operation. This works for now; if the Guile
1677 developer archives are still around, see Mikael's post of
1678 11-Apr-97. */
1679 if (scm_is_null (args))
1680 {
1681 if (scm_is_null (arg1))
1682 {
1683 arg1 = SCM_UNDEFINED;
1684 #ifdef DEVAL
1685 debug.vect[0].a.args = SCM_EOL;
1686 #endif
1687 }
1688 else
1689 {
1690 #ifdef DEVAL
1691 debug.vect[0].a.args = arg1;
1692 #endif
1693 args = SCM_CDR (arg1);
1694 arg1 = SCM_CAR (arg1);
1695 }
1696 }
1697 else
1698 {
1699 args = scm_nconc2last (args);
1700 #ifdef DEVAL
1701 debug.vect[0].a.args = scm_cons (arg1, args);
1702 #endif
1703 }
1704 #ifdef DEVAL
1705 if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
1706 {
1707 SCM tmp = scm_make_debugobj (&debug);
1708 SCM_TRAPS_P = 0;
1709 scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
1710 SCM_TRAPS_P = 1;
1711 }
1712 ENTER_APPLY;
1713 #endif
1714 tail:
1715 switch (SCM_TYP7 (proc))
1716 {
1717 case scm_tc7_subr_2o:
1718 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
1719 scm_wrong_num_args (proc);
1720 if (scm_is_null (args))
1721 args = SCM_UNDEFINED;
1722 else
1723 {
1724 if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args))))
1725 scm_wrong_num_args (proc);
1726 args = SCM_CAR (args);
1727 }
1728 RETURN (SCM_SUBRF (proc) (arg1, args));
1729 case scm_tc7_subr_2:
1730 if (SCM_UNLIKELY (scm_is_null (args) ||
1731 !scm_is_null (SCM_CDR (args))))
1732 scm_wrong_num_args (proc);
1733 args = SCM_CAR (args);
1734 RETURN (SCM_SUBRF (proc) (arg1, args));
1735 case scm_tc7_subr_0:
1736 if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
1737 scm_wrong_num_args (proc);
1738 else
1739 RETURN (SCM_SUBRF (proc) ());
1740 case scm_tc7_subr_1:
1741 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
1742 scm_wrong_num_args (proc);
1743 case scm_tc7_subr_1o:
1744 if (SCM_UNLIKELY (!scm_is_null (args)))
1745 scm_wrong_num_args (proc);
1746 else
1747 RETURN (SCM_SUBRF (proc) (arg1));
1748 case scm_tc7_dsubr:
1749 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
1750 scm_wrong_num_args (proc);
1751 if (SCM_I_INUMP (arg1))
1752 {
1753 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
1754 }
1755 else if (SCM_REALP (arg1))
1756 {
1757 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
1758 }
1759 else if (SCM_BIGP (arg1))
1760 {
1761 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
1762 }
1763 else if (SCM_FRACTIONP (arg1))
1764 {
1765 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
1766 }
1767 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
1768 SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
1769 case scm_tc7_cxr:
1770 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
1771 scm_wrong_num_args (proc);
1772 RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
1773 case scm_tc7_subr_3:
1774 if (SCM_UNLIKELY (scm_is_null (args)
1775 || scm_is_null (SCM_CDR (args))
1776 || !scm_is_null (SCM_CDDR (args))))
1777 scm_wrong_num_args (proc);
1778 else
1779 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
1780 case scm_tc7_lsubr:
1781 #ifdef DEVAL
1782 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
1783 #else
1784 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
1785 #endif
1786 case scm_tc7_lsubr_2:
1787 if (SCM_UNLIKELY (!scm_is_pair (args)))
1788 scm_wrong_num_args (proc);
1789 else
1790 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
1791 case scm_tc7_asubr:
1792 if (scm_is_null (args))
1793 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1794 while (SCM_NIMP (args))
1795 {
1796 SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
1797 arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
1798 args = SCM_CDR (args);
1799 }
1800 RETURN (arg1);
1801 case scm_tc7_rpsubr:
1802 if (scm_is_null (args))
1803 RETURN (SCM_BOOL_T);
1804 while (SCM_NIMP (args))
1805 {
1806 SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
1807 if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
1808 RETURN (SCM_BOOL_F);
1809 arg1 = SCM_CAR (args);
1810 args = SCM_CDR (args);
1811 }
1812 RETURN (SCM_BOOL_T);
1813 case scm_tcs_closures:
1814 #ifdef DEVAL
1815 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
1816 #else
1817 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
1818 #endif
1819 if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
1820 scm_wrong_num_args (proc);
1821
1822 /* Copy argument list */
1823 if (SCM_IMP (arg1))
1824 args = arg1;
1825 else
1826 {
1827 SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
1828 for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
1829 {
1830 SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
1831 tl = SCM_CDR (tl);
1832 }
1833 SCM_SETCDR (tl, arg1);
1834 }
1835
1836 args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
1837 args,
1838 SCM_ENV (proc));
1839 proc = SCM_CLOSURE_BODY (proc);
1840 again:
1841 arg1 = SCM_CDR (proc);
1842 while (!scm_is_null (arg1))
1843 {
1844 if (SCM_IMP (SCM_CAR (proc)))
1845 {
1846 if (SCM_ISYMP (SCM_CAR (proc)))
1847 {
1848 scm_dynwind_begin (0);
1849 scm_i_dynwind_pthread_mutex_lock (&source_mutex);
1850 /* check for race condition */
1851 if (SCM_ISYMP (SCM_CAR (proc)))
1852 m_expand_body (proc, args);
1853 scm_dynwind_end ();
1854 goto again;
1855 }
1856 else
1857 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
1858 }
1859 else
1860 (void) EVAL (SCM_CAR (proc), args);
1861 proc = arg1;
1862 arg1 = SCM_CDR (proc);
1863 }
1864 RETURN (EVALCAR (proc, args));
1865 case scm_tc7_smob:
1866 if (!SCM_SMOB_APPLICABLE_P (proc))
1867 goto badproc;
1868 if (SCM_UNBNDP (arg1))
1869 RETURN (SCM_SMOB_APPLY_0 (proc));
1870 else if (scm_is_null (args))
1871 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
1872 else if (scm_is_null (SCM_CDR (args)))
1873 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
1874 else
1875 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
1876 case scm_tc7_cclo:
1877 #ifdef DEVAL
1878 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1879 arg1 = proc;
1880 proc = SCM_CCLO_SUBR (proc);
1881 debug.vect[0].a.proc = proc;
1882 debug.vect[0].a.args = scm_cons (arg1, args);
1883 #else
1884 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1885 arg1 = proc;
1886 proc = SCM_CCLO_SUBR (proc);
1887 #endif
1888 goto tail;
1889 case scm_tc7_pws:
1890 proc = SCM_PROCEDURE (proc);
1891 #ifdef DEVAL
1892 debug.vect[0].a.proc = proc;
1893 #endif
1894 goto tail;
1895 case scm_tcs_struct:
1896 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1897 {
1898 #ifdef DEVAL
1899 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1900 #else
1901 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1902 #endif
1903 RETURN (scm_apply_generic (proc, args));
1904 }
1905 else if (SCM_I_OPERATORP (proc))
1906 {
1907 /* operator */
1908 #ifdef DEVAL
1909 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1910 #else
1911 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1912 #endif
1913 arg1 = proc;
1914 proc = (SCM_I_ENTITYP (proc)
1915 ? SCM_ENTITY_PROCEDURE (proc)
1916 : SCM_OPERATOR_PROCEDURE (proc));
1917 #ifdef DEVAL
1918 debug.vect[0].a.proc = proc;
1919 debug.vect[0].a.args = scm_cons (arg1, args);
1920 #endif
1921 if (SCM_NIMP (proc))
1922 goto tail;
1923 else
1924 goto badproc;
1925 }
1926 else
1927 goto badproc;
1928 default:
1929 badproc:
1930 scm_wrong_type_arg ("apply", SCM_ARG1, proc);
1931 }
1932 #ifdef DEVAL
1933 exit:
1934 if (scm_check_exit_p && SCM_TRAPS_P)
1935 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
1936 {
1937 SCM_CLEAR_TRACED_FRAME (debug);
1938 arg1 = scm_make_debugobj (&debug);
1939 SCM_TRAPS_P = 0;
1940 arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
1941 SCM_TRAPS_P = 1;
1942 if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
1943 proc = SCM_CDR (arg1);
1944 }
1945 scm_i_set_last_debug_frame (debug.prev);
1946 return proc;
1947 #endif
1948 }
1949
Unnamed repository; edit this file 'description' to name the repository.