HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
fix up some assumptions that cmethods were lists
[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_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;
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
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 }
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);
1157 if (SCM_UNLIKELY (scm_is_pair (formals)))
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);
1201 if (SCM_LIKELY (scm_is_pair (x)))
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 }
1330 if (SCM_LIKELY (scm_is_pair (x)))
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 }
1454 if (SCM_UNLIKELY (!scm_is_pair (x)))
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:
1532 if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
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:
1723 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
1724 scm_wrong_num_args (proc);
1725 if (scm_is_null (args))
1726 args = SCM_UNDEFINED;
1727 else
1728 {
1729 if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args))))
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:
1735 if (SCM_UNLIKELY (scm_is_null (args) ||
1736 !scm_is_null (SCM_CDR (args))))
1737 scm_wrong_num_args (proc);
1738 args = SCM_CAR (args);
1739 RETURN (SCM_SUBRF (proc) (arg1, args));
1740 case scm_tc7_subr_0:
1741 if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
1742 scm_wrong_num_args (proc);
1743 else
1744 RETURN (SCM_SUBRF (proc) ());
1745 case scm_tc7_subr_1:
1746 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
1747 scm_wrong_num_args (proc);
1748 case scm_tc7_subr_1o:
1749 if (SCM_UNLIKELY (!scm_is_null (args)))
1750 scm_wrong_num_args (proc);
1751 else
1752 RETURN (SCM_SUBRF (proc) (arg1));
1753 case scm_tc7_dsubr:
1754 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
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:
1775 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
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:
1779 if (SCM_UNLIKELY (scm_is_null (args)
1780 || scm_is_null (SCM_CDR (args))
1781 || !scm_is_null (SCM_CDDR (args))))
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:
1792 if (SCM_UNLIKELY (!scm_is_pair (args)))
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
1824 if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
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
Unnamed repository; edit this file 'description' to name the repository.