HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Changes from arch/CVS synchronization
[bpt/guile.git] / libguile / eval.i.c
CommitLineData
243ebb61
HWN		 1/*
2 * eval.i.c - actual evaluator code for GUILE
3 *
4 * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc.
5 *
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Lesser General Public
8 * License as published by the Free Software Foundation; either
9 * version 2.1 of the License, or (at your option) any later version.
10 *
11 * This library is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Lesser General Public License for more details.
15 *
16 * You should have received a copy of the GNU Lesser General Public
17 * License along with this library; if not, write to the Free Software
18 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 */
20
0ee05b85
HWN		 21#undef RETURN
22#undef ENTER_APPLY
23#undef PREP_APPLY
24#undef CEVAL
25#undef SCM_APPLY
26#undef EVAL_DEBUGGING_P
27
28
29#ifdef DEVAL
30
31/*
32 This code is specific for the debugging support.
33 */
34
35#define EVAL_DEBUGGING_P 1
36#define CEVAL deval /* Substitute all uses of ceval */
37#define SCM_APPLY scm_dapply
38#define PREP_APPLY(p, l) \
39{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
40
41#define ENTER_APPLY \
42do { \
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
67static SCM
68deval_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
108static void
109ceval_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
132static SCM
133scm_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
150SCM
151scm_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
208static SCM
209CEVAL (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
244loop:
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
264start:
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
295dispatch:
296 SCM_TICK;
297 if (SCM_ISYMP (SCM_CAR (x)))
298 {
299 switch (ISYMNUM (SCM_CAR (x)))
300 {
301 case (ISYMNUM (SCM_IM_AND)):
302 x = SCM_CDR (x);
303 while (!scm_is_null (SCM_CDR (x)))
304 {
305 SCM test_result = EVALCAR (x, env);
306 if (scm_is_false (test_result) || SCM_NILP (test_result))
307 RETURN (SCM_BOOL_F);
308 else
309 x = SCM_CDR (x);
310 }
311 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
312 goto carloop;
313
314 case (ISYMNUM (SCM_IM_BEGIN)):
315 x = SCM_CDR (x);
316 if (scm_is_null (x))
317 RETURN (SCM_UNSPECIFIED);
318
319 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
320
321 begin:
322 /* If we are on toplevel with a lookup closure, we need to sync
323 with the current module. */
324 if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
325 {
326 UPDATE_TOPLEVEL_ENV (env);
327 while (!scm_is_null (SCM_CDR (x)))
328 {
329 EVALCAR (x, env);
330 UPDATE_TOPLEVEL_ENV (env);
331 x = SCM_CDR (x);
332 }
333 goto carloop;
334 }
335 else
336 goto nontoplevel_begin;
337
338 nontoplevel_begin:
339 while (!scm_is_null (SCM_CDR (x)))
340 {
341 const SCM form = SCM_CAR (x);
342 if (SCM_IMP (form))
343 {
344 if (SCM_ISYMP (form))
345 {
346 scm_dynwind_begin (0);
347 scm_i_dynwind_pthread_mutex_lock (&source_mutex);
348 /* check for race condition */
349 if (SCM_ISYMP (SCM_CAR (x)))
350 m_expand_body (x, env);
351 scm_dynwind_end ();
352 goto nontoplevel_begin;
353 }
354 else
355 SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
356 }
357 else
358 (void) EVAL (form, env);
359 x = SCM_CDR (x);
360 }
361
362 carloop:
363 {
364 /* scm_eval last form in list */
365 const SCM last_form = SCM_CAR (x);
366
367 if (scm_is_pair (last_form))
368 {
369 /* This is by far the most frequent case. */
370 x = last_form;
371 goto loop; /* tail recurse */
372 }
373 else if (SCM_IMP (last_form))
374 RETURN (SCM_I_EVALIM (last_form, env));
375 else if (SCM_VARIABLEP (last_form))
376 RETURN (SCM_VARIABLE_REF (last_form));
377 else if (scm_is_symbol (last_form))
378 RETURN (*scm_lookupcar (x, env, 1));
379 else
380 RETURN (last_form);
381 }
382
383
384 case (ISYMNUM (SCM_IM_CASE)):
385 x = SCM_CDR (x);
386 {
387 const SCM key = EVALCAR (x, env);
388 x = SCM_CDR (x);
389 while (!scm_is_null (x))
390 {
391 const SCM clause = SCM_CAR (x);
392 SCM labels = SCM_CAR (clause);
393 if (scm_is_eq (labels, SCM_IM_ELSE))
394 {
395 x = SCM_CDR (clause);
396 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
397 goto begin;
398 }
399 while (!scm_is_null (labels))
400 {
401 const SCM label = SCM_CAR (labels);
402 if (scm_is_eq (label, key)
403 || scm_is_true (scm_eqv_p (label, key)))
404 {
405 x = SCM_CDR (clause);
406 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
407 goto begin;
408 }
409 labels = SCM_CDR (labels);
410 }
411 x = SCM_CDR (x);
412 }
413 }
414 RETURN (SCM_UNSPECIFIED);
415
416
417 case (ISYMNUM (SCM_IM_COND)):
418 x = SCM_CDR (x);
419 while (!scm_is_null (x))
420 {
421 const SCM clause = SCM_CAR (x);
422 if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
423 {
424 x = SCM_CDR (clause);
425 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
426 goto begin;
427 }
428 else
429 {
430 arg1 = EVALCAR (clause, env);
431 /* SRFI 61 extended cond */
432 if (!scm_is_null (SCM_CDR (clause))
433 && !scm_is_null (SCM_CDDR (clause))
434 && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
435 {
436 SCM xx, guard_result;
437 if (SCM_VALUESP (arg1))
438 arg1 = scm_struct_ref (arg1, SCM_INUM0);
439 else
440 arg1 = scm_list_1 (arg1);
441 xx = SCM_CDR (clause);
442 proc = EVALCAR (xx, env);
443 guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
444 if (scm_is_true (guard_result)
445 && !SCM_NILP (guard_result))
446 {
447 proc = SCM_CDDR (xx);
448 proc = EVALCAR (proc, env);
449 PREP_APPLY (proc, arg1);
450 goto apply_proc;
451 }
452 }
453 else if (scm_is_true (arg1) && !SCM_NILP (arg1))
454 {
455 x = SCM_CDR (clause);
456 if (scm_is_null (x))
457 RETURN (arg1);
458 else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
459 {
460 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
461 goto begin;
462 }
463 else
464 {
465 proc = SCM_CDR (x);
466 proc = EVALCAR (proc, env);
467 PREP_APPLY (proc, scm_list_1 (arg1));
468 ENTER_APPLY;
469 goto evap1;
470 }
471 }
472 x = SCM_CDR (x);
473 }
474 }
475 RETURN (SCM_UNSPECIFIED);
476
477
478 case (ISYMNUM (SCM_IM_DO)):
479 x = SCM_CDR (x);
480 {
481 /* Compute the initialization values and the initial environment. */
482 SCM init_forms = SCM_CAR (x);
483 SCM init_values = SCM_EOL;
484 while (!scm_is_null (init_forms))
485 {
486 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
487 init_forms = SCM_CDR (init_forms);
488 }
489 x = SCM_CDR (x);
490 env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
491 }
492 x = SCM_CDR (x);
493 {
494 SCM test_form = SCM_CAR (x);
495 SCM body_forms = SCM_CADR (x);
496 SCM step_forms = SCM_CDDR (x);
497
498 SCM test_result = EVALCAR (test_form, env);
499
500 while (scm_is_false (test_result) || SCM_NILP (test_result))
501 {
502 {
503 /* Evaluate body forms. */
504 SCM temp_forms;
505 for (temp_forms = body_forms;
506 !scm_is_null (temp_forms);
507 temp_forms = SCM_CDR (temp_forms))
508 {
509 SCM form = SCM_CAR (temp_forms);
510 /* Dirk:FIXME: We only need to eval forms that may have
511 * a side effect here. This is only true for forms that
512 * start with a pair. All others are just constants.
513 * Since with the current memoizer 'form' may hold a
514 * constant, we call EVAL here to handle the constant
515 * cases. In the long run it would make sense to have
516 * the macro transformer of 'do' eliminate all forms
517 * that have no sideeffect. Then instead of EVAL we
518 * could call CEVAL directly here. */
519 (void) EVAL (form, env);
520 }
521 }
522
523 {
524 /* Evaluate the step expressions. */
525 SCM temp_forms;
526 SCM step_values = SCM_EOL;
527 for (temp_forms = step_forms;
528 !scm_is_null (temp_forms);
529 temp_forms = SCM_CDR (temp_forms))
530 {
531 const SCM value = EVALCAR (temp_forms, env);
532 step_values = scm_cons (value, step_values);
533 }
534 env = SCM_EXTEND_ENV (SCM_CAAR (env),
535 step_values,
536 SCM_CDR (env));
537 }
538
539 test_result = EVALCAR (test_form, env);
540 }
541 }
542 x = SCM_CDAR (x);
543 if (scm_is_null (x))
544 RETURN (SCM_UNSPECIFIED);
545 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
546 goto nontoplevel_begin;
547
548
549 case (ISYMNUM (SCM_IM_IF)):
550 x = SCM_CDR (x);
551 {
552 SCM test_result = EVALCAR (x, env);
553 x = SCM_CDR (x); /* then expression */
554 if (scm_is_false (test_result) || SCM_NILP (test_result))
555 {
556 x = SCM_CDR (x); /* else expression */
557 if (scm_is_null (x))
558 RETURN (SCM_UNSPECIFIED);
559 }
560 }
561 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
562 goto carloop;
563
564
565 case (ISYMNUM (SCM_IM_LET)):
566 x = SCM_CDR (x);
567 {
568 SCM init_forms = SCM_CADR (x);
569 SCM init_values = SCM_EOL;
570 do
571 {
572 init_values = scm_cons (EVALCAR (init_forms, env), init_values);
573 init_forms = SCM_CDR (init_forms);
574 }
575 while (!scm_is_null (init_forms));
576 env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
577 }
578 x = SCM_CDDR (x);
579 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
580 goto nontoplevel_begin;
581
582
583 case (ISYMNUM (SCM_IM_LETREC)):
584 x = SCM_CDR (x);
585 env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
586 x = SCM_CDR (x);
587 {
588 SCM init_forms = SCM_CAR (x);
589 SCM init_values = scm_list_1 (SCM_BOOL_T);
590 SCM *init_values_eol = SCM_CDRLOC (init_values);
591 ceval_letrec_inits (env, init_forms, &init_values_eol);
592 SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
593 }
594 x = SCM_CDR (x);
595 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
596 goto nontoplevel_begin;
597
598
599 case (ISYMNUM (SCM_IM_LETSTAR)):
600 x = SCM_CDR (x);
601 {
602 SCM bindings = SCM_CAR (x);
603 if (!scm_is_null (bindings))
604 {
605 do
606 {
607 SCM name = SCM_CAR (bindings);
608 SCM init = SCM_CDR (bindings);
609 env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
610 bindings = SCM_CDR (init);
611 }
612 while (!scm_is_null (bindings));
613 }
614 }
615 x = SCM_CDR (x);
616 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
617 goto nontoplevel_begin;
618
619
620 case (ISYMNUM (SCM_IM_OR)):
621 x = SCM_CDR (x);
622 while (!scm_is_null (SCM_CDR (x)))
623 {
624 SCM val = EVALCAR (x, env);
625 if (scm_is_true (val) && !SCM_NILP (val))
626 RETURN (val);
627 else
628 x = SCM_CDR (x);
629 }
630 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
631 goto carloop;
632
633
634 case (ISYMNUM (SCM_IM_LAMBDA)):
635 RETURN (scm_closure (SCM_CDR (x), env));
636
637
638 case (ISYMNUM (SCM_IM_QUOTE)):
639 RETURN (SCM_CDR (x));
640
641
642 case (ISYMNUM (SCM_IM_SET_X)):
643 x = SCM_CDR (x);
644 {
645 SCM *location;
646 SCM variable = SCM_CAR (x);
647 if (SCM_ILOCP (variable))
648 location = scm_ilookup (variable, env);
649 else if (SCM_VARIABLEP (variable))
650 location = SCM_VARIABLE_LOC (variable);
651 else
652 {
653 /* (scm_is_symbol (variable)) is known to be true */
654 variable = lazy_memoize_variable (variable, env);
655 SCM_SETCAR (x, variable);
656 location = SCM_VARIABLE_LOC (variable);
657 }
658 x = SCM_CDR (x);
659 *location = EVALCAR (x, env);
660 }
661 RETURN (SCM_UNSPECIFIED);
662
663
664 case (ISYMNUM (SCM_IM_APPLY)):
665 /* Evaluate the procedure to be applied. */
666 x = SCM_CDR (x);
667 proc = EVALCAR (x, env);
668 PREP_APPLY (proc, SCM_EOL);
669
670 /* Evaluate the argument holding the list of arguments */
671 x = SCM_CDR (x);
672 arg1 = EVALCAR (x, env);
673
674 apply_proc:
675 /* Go here to tail-apply a procedure. PROC is the procedure and
676 * ARG1 is the list of arguments. PREP_APPLY must have been called
677 * before jumping to apply_proc. */
678 if (SCM_CLOSUREP (proc))
679 {
680 SCM formals = SCM_CLOSURE_FORMALS (proc);
681#ifdef DEVAL
682 debug.info->a.args = arg1;
683#endif
9cc37597 684 if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
0ee05b85
HWN		 685 scm_wrong_num_args (proc);
686 ENTER_APPLY;
687 /* Copy argument list */
688 if (SCM_NULL_OR_NIL_P (arg1))
689 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
690 else
691 {
692 SCM args = scm_list_1 (SCM_CAR (arg1));
693 SCM tail = args;
694 arg1 = SCM_CDR (arg1);
695 while (!SCM_NULL_OR_NIL_P (arg1))
696 {
697 SCM new_tail = scm_list_1 (SCM_CAR (arg1));
698 SCM_SETCDR (tail, new_tail);
699 tail = new_tail;
700 arg1 = SCM_CDR (arg1);
701 }
702 env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
703 }
704
705 x = SCM_CLOSURE_BODY (proc);
706 goto nontoplevel_begin;
707 }
708 else
709 {
710 ENTER_APPLY;
711 RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
712 }
713
714
715 case (ISYMNUM (SCM_IM_CONT)):
716 {
717 int first;
718 SCM val = scm_make_continuation (&first);
719
720 if (!first)
721 RETURN (val);
722 else
723 {
724 arg1 = val;
725 proc = SCM_CDR (x);
726 proc = EVALCAR (proc, env);
727 PREP_APPLY (proc, scm_list_1 (arg1));
728 ENTER_APPLY;
729 goto evap1;
730 }
731 }
732
733
734 case (ISYMNUM (SCM_IM_DELAY)):
735 RETURN (scm_makprom (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 != ENV */
859 if (scm_is_null (SCM_CAR (z)) || scm_is_pair (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 SCM formals = SCM_CMETHOD_FORMALS (z);
871 env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
872 x = SCM_CMETHOD_BODY (z);
873 goto nontoplevel_begin;
874 }
875 }
876 }
877
878
879 case (ISYMNUM (SCM_IM_SLOT_REF)):
880 x = SCM_CDR (x);
881 {
882 SCM instance = EVALCAR (x, env);
883 unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
884 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
885 }
886
887
888 case (ISYMNUM (SCM_IM_SLOT_SET_X)):
889 x = SCM_CDR (x);
890 {
891 SCM instance = EVALCAR (x, env);
892 unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
893 SCM value = EVALCAR (SCM_CDDR (x), env);
894 SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
895 RETURN (SCM_UNSPECIFIED);
896 }
897
898
899#if SCM_ENABLE_ELISP
900
901 case (ISYMNUM (SCM_IM_NIL_COND)):
902 {
903 SCM test_form = SCM_CDR (x);
904 x = SCM_CDR (test_form);
905 while (!SCM_NULL_OR_NIL_P (x))
906 {
907 SCM test_result = EVALCAR (test_form, env);
908 if (!(scm_is_false (test_result)
909 || SCM_NULL_OR_NIL_P (test_result)))
910 {
911 if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
912 RETURN (test_result);
913 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
914 goto carloop;
915 }
916 else
917 {
918 test_form = SCM_CDR (x);
919 x = SCM_CDR (test_form);
920 }
921 }
922 x = test_form;
923 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
924 goto carloop;
925 }
926
927#endif /* SCM_ENABLE_ELISP */
928
929 case (ISYMNUM (SCM_IM_BIND)):
930 {
931 SCM vars, exps, vals;
932
933 x = SCM_CDR (x);
934 vars = SCM_CAAR (x);
935 exps = SCM_CDAR (x);
936 vals = SCM_EOL;
937 while (!scm_is_null (exps))
938 {
939 vals = scm_cons (EVALCAR (exps, env), vals);
940 exps = SCM_CDR (exps);
941 }
942
943 scm_swap_bindings (vars, vals);
944 scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
945
946 /* Ignore all but the last evaluation result. */
947 for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
948 {
949 if (scm_is_pair (SCM_CAR (x)))
950 CEVAL (SCM_CAR (x), env);
951 }
952 proc = EVALCAR (x, env);
953
954 scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
955 scm_swap_bindings (vars, vals);
956
957 RETURN (proc);
958 }
959
960
961 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
962 {
963 SCM producer;
964
965 x = SCM_CDR (x);
966 producer = EVALCAR (x, env);
967 x = SCM_CDR (x);
968 proc = EVALCAR (x, env); /* proc is the consumer. */
969 arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
970 if (SCM_VALUESP (arg1))
971 {
972 /* The list of arguments is not copied. Rather, it is assumed
973 * that this has been done by the 'values' procedure. */
974 arg1 = scm_struct_ref (arg1, SCM_INUM0);
975 }
976 else
977 {
978 arg1 = scm_list_1 (arg1);
979 }
980 PREP_APPLY (proc, arg1);
981 goto apply_proc;
982 }
983
984
985 default:
986 break;
987 }
988 }
989 else
990 {
991 if (SCM_VARIABLEP (SCM_CAR (x)))
992 proc = SCM_VARIABLE_REF (SCM_CAR (x));
993 else if (SCM_ILOCP (SCM_CAR (x)))
994 proc = *scm_ilookup (SCM_CAR (x), env);
995 else if (scm_is_pair (SCM_CAR (x)))
996 proc = CEVAL (SCM_CAR (x), env);
997 else if (scm_is_symbol (SCM_CAR (x)))
998 {
999 SCM orig_sym = SCM_CAR (x);
1000 {
1001 SCM *location = scm_lookupcar1 (x, env, 1);
1002 if (location == NULL)
1003 {
1004 /* we have lost the race, start again. */
1005 goto dispatch;
1006 }
1007 proc = *location;
1008#ifdef DEVAL
1009 if (scm_check_memoize_p && SCM_TRAPS_P)
1010 {
1011 SCM_CLEAR_TRACED_FRAME (debug);
1012 SCM arg1 = scm_make_debugobj (&debug);
1013 SCM retval = SCM_BOOL_T;
1014 SCM_TRAPS_P = 0;
1015 retval = scm_call_4 (SCM_MEMOIZE_HDLR,
1016 scm_sym_memoize_symbol,
1017 arg1, x, env);
1018
1019 /*
1020 do something with retval?
1021 */
1022 SCM_TRAPS_P = 1;
1023 }
1024#endif
1025 }
1026
1027 if (SCM_MACROP (proc))
1028 {
1029 SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
1030 lookupcar */
1031 handle_a_macro: /* inputs: x, env, proc */
1032#ifdef DEVAL
1033 /* Set a flag during macro expansion so that macro
1034 application frames can be deleted from the backtrace. */
1035 SCM_SET_MACROEXP (debug);
1036#endif
1037 arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
1038 scm_cons (env, scm_listofnull));
1039#ifdef DEVAL
1040 SCM_CLEAR_MACROEXP (debug);
1041#endif
1042 switch (SCM_MACRO_TYPE (proc))
1043 {
1044 case 3:
1045 case 2:
1046 if (!scm_is_pair (arg1))
1047 arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
1048
1049 assert (!scm_is_eq (x, SCM_CAR (arg1))
1050 && !scm_is_eq (x, SCM_CDR (arg1)));
1051
1052#ifdef DEVAL
1053 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
1054 {
1055 SCM_CRITICAL_SECTION_START;
1056 SCM_SETCAR (x, SCM_CAR (arg1));
1057 SCM_SETCDR (x, SCM_CDR (arg1));
1058 SCM_CRITICAL_SECTION_END;
1059 goto dispatch;
1060 }
1061 /* Prevent memoizing of debug info expression. */
1062 debug.info->e.exp = scm_cons_source (debug.info->e.exp,
1063 SCM_CAR (x),
1064 SCM_CDR (x));
1065#endif
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 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1071 goto loop;
1072#if SCM_ENABLE_DEPRECATED == 1
1073 case 1:
1074 x = arg1;
1075 if (SCM_NIMP (x))
1076 {
1077 PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
1078 goto loop;
1079 }
1080 else
1081 RETURN (arg1);
1082#endif
1083 case 0:
1084 RETURN (arg1);
1085 }
1086 }
1087 }
1088 else
1089 proc = SCM_CAR (x);
1090
1091 if (SCM_MACROP (proc))
1092 goto handle_a_macro;
1093 }
1094
1095
1096 /* When reaching this part of the code, the following is granted: Variable x
1097 * holds the first pair of an expression of the form (<function> arg ...).
1098 * Variable proc holds the object that resulted from the evaluation of
1099 * <function>. In the following, the arguments (if any) will be evaluated,
1100 * and proc will be applied to them. If proc does not really hold a
1101 * function object, this will be signalled as an error on the scheme
1102 * level. If the number of arguments does not match the number of arguments
1103 * that are allowed to be passed to proc, also an error on the scheme level
1104 * will be signalled. */
1105
1106 PREP_APPLY (proc, SCM_EOL);
1107 if (scm_is_null (SCM_CDR (x))) {
1108 ENTER_APPLY;
1109 evap0:
1110 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1111 switch (SCM_TYP7 (proc))
1112 { /* no arguments given */
1113 case scm_tc7_subr_0:
1114 RETURN (SCM_SUBRF (proc) ());
1115 case scm_tc7_subr_1o:
1116 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
1117 case scm_tc7_lsubr:
1118 RETURN (SCM_SUBRF (proc) (SCM_EOL));
1119 case scm_tc7_rpsubr:
1120 RETURN (SCM_BOOL_T);
1121 case scm_tc7_asubr:
1122 RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
1123 case scm_tc7_smob:
1124 if (!SCM_SMOB_APPLICABLE_P (proc))
1125 goto badfun;
1126 RETURN (SCM_SMOB_APPLY_0 (proc));
1127 case scm_tc7_cclo:
1128 arg1 = proc;
1129 proc = SCM_CCLO_SUBR (proc);
1130#ifdef DEVAL
1131 debug.info->a.proc = proc;
1132 debug.info->a.args = scm_list_1 (arg1);
1133#endif
1134 goto evap1;
1135 case scm_tc7_pws:
1136 proc = SCM_PROCEDURE (proc);
1137#ifdef DEVAL
1138 debug.info->a.proc = proc;
1139#endif
1140 if (!SCM_CLOSUREP (proc))
1141 goto evap0;
1142 /* fallthrough */
1143 case scm_tcs_closures:
1144 {
1145 const SCM formals = SCM_CLOSURE_FORMALS (proc);
9cc37597 1146 if (SCM_UNLIKELY (scm_is_pair (formals)))
0ee05b85
HWN		 1147 goto wrongnumargs;
1148 x = SCM_CLOSURE_BODY (proc);
1149 env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
1150 goto nontoplevel_begin;
1151 }
1152 case scm_tcs_struct:
1153 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1154 {
1155 x = SCM_ENTITY_PROCEDURE (proc);
1156 arg1 = SCM_EOL;
1157 goto type_dispatch;
1158 }
1159 else if (SCM_I_OPERATORP (proc))
1160 {
1161 arg1 = proc;
1162 proc = (SCM_I_ENTITYP (proc)
1163 ? SCM_ENTITY_PROCEDURE (proc)
1164 : SCM_OPERATOR_PROCEDURE (proc));
1165#ifdef DEVAL
1166 debug.info->a.proc = proc;
1167 debug.info->a.args = scm_list_1 (arg1);
1168#endif
1169 goto evap1;
1170 }
1171 else
1172 goto badfun;
1173 case scm_tc7_subr_1:
1174 case scm_tc7_subr_2:
1175 case scm_tc7_subr_2o:
1176 case scm_tc7_dsubr:
1177 case scm_tc7_cxr:
1178 case scm_tc7_subr_3:
1179 case scm_tc7_lsubr_2:
1180 wrongnumargs:
1181 scm_wrong_num_args (proc);
1182 default:
1183 badfun:
1184 scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
1185 }
1186 }
1187
1188 /* must handle macros by here */
1189 x = SCM_CDR (x);
9cc37597 1190 if (SCM_LIKELY (scm_is_pair (x)))
0ee05b85
HWN		 1191 arg1 = EVALCAR (x, env);
1192 else
1193 scm_wrong_num_args (proc);
1194#ifdef DEVAL
1195 debug.info->a.args = scm_list_1 (arg1);
1196#endif
1197 x = SCM_CDR (x);
1198 {
1199 SCM arg2;
1200 if (scm_is_null (x))
1201 {
1202 ENTER_APPLY;
1203 evap1: /* inputs: proc, arg1 */
1204 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1205 switch (SCM_TYP7 (proc))
1206 { /* have one argument in arg1 */
1207 case scm_tc7_subr_2o:
1208 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1209 case scm_tc7_subr_1:
1210 case scm_tc7_subr_1o:
1211 RETURN (SCM_SUBRF (proc) (arg1));
1212 case scm_tc7_dsubr:
1213 if (SCM_I_INUMP (arg1))
1214 {
1215 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
1216 }
1217 else if (SCM_REALP (arg1))
1218 {
1219 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
1220 }
1221 else if (SCM_BIGP (arg1))
1222 {
1223 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
1224 }
1225 else if (SCM_FRACTIONP (arg1))
1226 {
1227 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
1228 }
1229 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
1230 SCM_ARG1,
1231 scm_i_symbol_chars (SCM_SNAME (proc)));
1232 case scm_tc7_cxr:
1233 RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
1234 case scm_tc7_rpsubr:
1235 RETURN (SCM_BOOL_T);
1236 case scm_tc7_asubr:
1237 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1238 case scm_tc7_lsubr:
1239#ifdef DEVAL
1240 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1241#else
1242 RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
1243#endif
1244 case scm_tc7_smob:
1245 if (!SCM_SMOB_APPLICABLE_P (proc))
1246 goto badfun;
1247 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
1248 case scm_tc7_cclo:
1249 arg2 = arg1;
1250 arg1 = proc;
1251 proc = SCM_CCLO_SUBR (proc);
1252#ifdef DEVAL
1253 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
1254 debug.info->a.proc = proc;
1255#endif
1256 goto evap2;
1257 case scm_tc7_pws:
1258 proc = SCM_PROCEDURE (proc);
1259#ifdef DEVAL
1260 debug.info->a.proc = proc;
1261#endif
1262 if (!SCM_CLOSUREP (proc))
1263 goto evap1;
1264 /* fallthrough */
1265 case scm_tcs_closures:
1266 {
1267 /* clos1: */
1268 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1269 if (scm_is_null (formals)
1270 || (scm_is_pair (formals) && scm_is_pair (SCM_CDR (formals))))
1271 goto wrongnumargs;
1272 x = SCM_CLOSURE_BODY (proc);
1273#ifdef DEVAL
1274 env = SCM_EXTEND_ENV (formals,
1275 debug.info->a.args,
1276 SCM_ENV (proc));
1277#else
1278 env = SCM_EXTEND_ENV (formals,
1279 scm_list_1 (arg1),
1280 SCM_ENV (proc));
1281#endif
1282 goto nontoplevel_begin;
1283 }
1284 case scm_tcs_struct:
1285 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1286 {
1287 x = SCM_ENTITY_PROCEDURE (proc);
1288#ifdef DEVAL
1289 arg1 = debug.info->a.args;
1290#else
1291 arg1 = scm_list_1 (arg1);
1292#endif
1293 goto type_dispatch;
1294 }
1295 else if (SCM_I_OPERATORP (proc))
1296 {
1297 arg2 = arg1;
1298 arg1 = proc;
1299 proc = (SCM_I_ENTITYP (proc)
1300 ? SCM_ENTITY_PROCEDURE (proc)
1301 : SCM_OPERATOR_PROCEDURE (proc));
1302#ifdef DEVAL
1303 debug.info->a.args = scm_cons (arg1, debug.info->a.args);
1304 debug.info->a.proc = proc;
1305#endif
1306 goto evap2;
1307 }
1308 else
1309 goto badfun;
1310 case scm_tc7_subr_2:
1311 case scm_tc7_subr_0:
1312 case scm_tc7_subr_3:
1313 case scm_tc7_lsubr_2:
1314 scm_wrong_num_args (proc);
1315 default:
1316 goto badfun;
1317 }
1318 }
9cc37597 1319 if (SCM_LIKELY (scm_is_pair (x)))
0ee05b85
HWN		 1320 arg2 = EVALCAR (x, env);
1321 else
1322 scm_wrong_num_args (proc);
1323
1324 { /* have two or more arguments */
1325#ifdef DEVAL
1326 debug.info->a.args = scm_list_2 (arg1, arg2);
1327#endif
1328 x = SCM_CDR (x);
1329 if (scm_is_null (x)) {
1330 ENTER_APPLY;
1331 evap2:
1332 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1333 switch (SCM_TYP7 (proc))
1334 { /* have two arguments */
1335 case scm_tc7_subr_2:
1336 case scm_tc7_subr_2o:
1337 RETURN (SCM_SUBRF (proc) (arg1, arg2));
1338 case scm_tc7_lsubr:
1339#ifdef DEVAL
1340 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1341#else
1342 RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
1343#endif
1344 case scm_tc7_lsubr_2:
1345 RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
1346 case scm_tc7_rpsubr:
1347 case scm_tc7_asubr:
1348 RETURN (SCM_SUBRF (proc) (arg1, arg2));
1349 case scm_tc7_smob:
1350 if (!SCM_SMOB_APPLICABLE_P (proc))
1351 goto badfun;
1352 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
1353 cclon:
1354 case scm_tc7_cclo:
1355#ifdef DEVAL
1356 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
1357 scm_cons (proc, debug.info->a.args),
1358 SCM_EOL));
1359#else
1360 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
1361 scm_cons2 (proc, arg1,
1362 scm_cons (arg2,
1363 scm_ceval_args (x,
1364 env,
1365 proc))),
1366 SCM_EOL));
1367#endif
1368 case scm_tcs_struct:
1369 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1370 {
1371 x = SCM_ENTITY_PROCEDURE (proc);
1372#ifdef DEVAL
1373 arg1 = debug.info->a.args;
1374#else
1375 arg1 = scm_list_2 (arg1, arg2);
1376#endif
1377 goto type_dispatch;
1378 }
1379 else if (SCM_I_OPERATORP (proc))
1380 {
1381 operatorn:
1382#ifdef DEVAL
1383 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
1384 ? SCM_ENTITY_PROCEDURE (proc)
1385 : SCM_OPERATOR_PROCEDURE (proc),
1386 scm_cons (proc, debug.info->a.args),
1387 SCM_EOL));
1388#else
1389 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
1390 ? SCM_ENTITY_PROCEDURE (proc)
1391 : SCM_OPERATOR_PROCEDURE (proc),
1392 scm_cons2 (proc, arg1,
1393 scm_cons (arg2,
1394 scm_ceval_args (x,
1395 env,
1396 proc))),
1397 SCM_EOL));
1398#endif
1399 }
1400 else
1401 goto badfun;
1402 case scm_tc7_subr_0:
1403 case scm_tc7_dsubr:
1404 case scm_tc7_cxr:
1405 case scm_tc7_subr_1o:
1406 case scm_tc7_subr_1:
1407 case scm_tc7_subr_3:
1408 scm_wrong_num_args (proc);
1409 default:
1410 goto badfun;
1411 case scm_tc7_pws:
1412 proc = SCM_PROCEDURE (proc);
1413#ifdef DEVAL
1414 debug.info->a.proc = proc;
1415#endif
1416 if (!SCM_CLOSUREP (proc))
1417 goto evap2;
1418 /* fallthrough */
1419 case scm_tcs_closures:
1420 {
1421 /* clos2: */
1422 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1423 if (scm_is_null (formals)
1424 || (scm_is_pair (formals)
1425 && (scm_is_null (SCM_CDR (formals))
1426 || (scm_is_pair (SCM_CDR (formals))
1427 && scm_is_pair (SCM_CDDR (formals))))))
1428 goto wrongnumargs;
1429#ifdef DEVAL
1430 env = SCM_EXTEND_ENV (formals,
1431 debug.info->a.args,
1432 SCM_ENV (proc));
1433#else
1434 env = SCM_EXTEND_ENV (formals,
1435 scm_list_2 (arg1, arg2),
1436 SCM_ENV (proc));
1437#endif
1438 x = SCM_CLOSURE_BODY (proc);
1439 goto nontoplevel_begin;
1440 }
1441 }
1442 }
9cc37597 1443 if (SCM_UNLIKELY (!scm_is_pair (x)))
0ee05b85
HWN		 1444 scm_wrong_num_args (proc);
1445#ifdef DEVAL
1446 debug.info->a.args = scm_cons2 (arg1, arg2,
1447 deval_args (x, env, proc,
1448 SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
1449#endif
1450 ENTER_APPLY;
1451 evap3:
1452 SCM_ASRTGO (!SCM_IMP (proc), badfun);
1453 switch (SCM_TYP7 (proc))
1454 { /* have 3 or more arguments */
1455#ifdef DEVAL
1456 case scm_tc7_subr_3:
1457 if (!scm_is_null (SCM_CDR (x)))
1458 scm_wrong_num_args (proc);
1459 else
1460 RETURN (SCM_SUBRF (proc) (arg1, arg2,
1461 SCM_CADDR (debug.info->a.args)));
1462 case scm_tc7_asubr:
1463 arg1 = SCM_SUBRF(proc)(arg1, arg2);
1464 arg2 = SCM_CDDR (debug.info->a.args);
1465 do
1466 {
1467 arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
1468 arg2 = SCM_CDR (arg2);
1469 }
1470 while (SCM_NIMP (arg2));
1471 RETURN (arg1);
1472 case scm_tc7_rpsubr:
1473 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
1474 RETURN (SCM_BOOL_F);
1475 arg1 = SCM_CDDR (debug.info->a.args);
1476 do
1477 {
1478 if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
1479 RETURN (SCM_BOOL_F);
1480 arg2 = SCM_CAR (arg1);
1481 arg1 = SCM_CDR (arg1);
1482 }
1483 while (SCM_NIMP (arg1));
1484 RETURN (SCM_BOOL_T);
1485 case scm_tc7_lsubr_2:
1486 RETURN (SCM_SUBRF (proc) (arg1, arg2,
1487 SCM_CDDR (debug.info->a.args)));
1488 case scm_tc7_lsubr:
1489 RETURN (SCM_SUBRF (proc) (debug.info->a.args));
1490 case scm_tc7_smob:
1491 if (!SCM_SMOB_APPLICABLE_P (proc))
1492 goto badfun;
1493 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
1494 SCM_CDDR (debug.info->a.args)));
1495 case scm_tc7_cclo:
1496 goto cclon;
1497 case scm_tc7_pws:
1498 proc = SCM_PROCEDURE (proc);
1499 debug.info->a.proc = proc;
1500 if (!SCM_CLOSUREP (proc))
1501 goto evap3;
1502 /* fallthrough */
1503 case scm_tcs_closures:
1504 {
1505 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1506 if (scm_is_null (formals)
1507 || (scm_is_pair (formals)
1508 && (scm_is_null (SCM_CDR (formals))
1509 || (scm_is_pair (SCM_CDR (formals))
1510 && scm_badargsp (SCM_CDDR (formals), x)))))
1511 goto wrongnumargs;
1512 SCM_SET_ARGSREADY (debug);
1513 env = SCM_EXTEND_ENV (formals,
1514 debug.info->a.args,
1515 SCM_ENV (proc));
1516 x = SCM_CLOSURE_BODY (proc);
1517 goto nontoplevel_begin;
1518 }
1519#else /* DEVAL */
1520 case scm_tc7_subr_3:
9cc37597 1521 if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
0ee05b85
HWN		 1522 scm_wrong_num_args (proc);
1523 else
1524 RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
1525 case scm_tc7_asubr:
1526 arg1 = SCM_SUBRF (proc) (arg1, arg2);
1527 do
1528 {
1529 arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
1530 x = SCM_CDR(x);
1531 }
1532 while (!scm_is_null (x));
1533 RETURN (arg1);
1534 case scm_tc7_rpsubr:
1535 if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
1536 RETURN (SCM_BOOL_F);
1537 do
1538 {
1539 arg1 = EVALCAR (x, env);
1540 if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
1541 RETURN (SCM_BOOL_F);
1542 arg2 = arg1;
1543 x = SCM_CDR (x);
1544 }
1545 while (!scm_is_null (x));
1546 RETURN (SCM_BOOL_T);
1547 case scm_tc7_lsubr_2:
1548 RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_ceval_args (x, env, proc)));
1549 case scm_tc7_lsubr:
1550 RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
1551 arg2,
1552 scm_ceval_args (x, env, proc))));
1553 case scm_tc7_smob:
1554 if (!SCM_SMOB_APPLICABLE_P (proc))
1555 goto badfun;
1556 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
1557 scm_ceval_args (x, env, proc)));
1558 case scm_tc7_cclo:
1559 goto cclon;
1560 case scm_tc7_pws:
1561 proc = SCM_PROCEDURE (proc);
1562 if (!SCM_CLOSUREP (proc))
1563 goto evap3;
1564 /* fallthrough */
1565 case scm_tcs_closures:
1566 {
1567 const SCM formals = SCM_CLOSURE_FORMALS (proc);
1568 if (scm_is_null (formals)
1569 || (scm_is_pair (formals)
1570 && (scm_is_null (SCM_CDR (formals))
1571 || (scm_is_pair (SCM_CDR (formals))
1572 && scm_badargsp (SCM_CDDR (formals), x)))))
1573 goto wrongnumargs;
1574 env = SCM_EXTEND_ENV (formals,
1575 scm_cons2 (arg1,
1576 arg2,
1577 scm_ceval_args (x, env, proc)),
1578 SCM_ENV (proc));
1579 x = SCM_CLOSURE_BODY (proc);
1580 goto nontoplevel_begin;
1581 }
1582#endif /* DEVAL */
1583 case scm_tcs_struct:
1584 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1585 {
1586#ifdef DEVAL
1587 arg1 = debug.info->a.args;
1588#else
1589 arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
1590#endif
1591 x = SCM_ENTITY_PROCEDURE (proc);
1592 goto type_dispatch;
1593 }
1594 else if (SCM_I_OPERATORP (proc))
1595 goto operatorn;
1596 else
1597 goto badfun;
1598 case scm_tc7_subr_2:
1599 case scm_tc7_subr_1o:
1600 case scm_tc7_subr_2o:
1601 case scm_tc7_subr_0:
1602 case scm_tc7_dsubr:
1603 case scm_tc7_cxr:
1604 case scm_tc7_subr_1:
1605 scm_wrong_num_args (proc);
1606 default:
1607 goto badfun;
1608 }
1609 }
1610 }
1611#ifdef DEVAL
1612exit:
1613 if (scm_check_exit_p && SCM_TRAPS_P)
1614 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
1615 {
1616 SCM_CLEAR_TRACED_FRAME (debug);
1617 arg1 = scm_make_debugobj (&debug);
1618 SCM_TRAPS_P = 0;
1619 arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
1620 SCM_TRAPS_P = 1;
1621 if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
1622 proc = SCM_CDR (arg1);
1623 }
1624 scm_i_set_last_debug_frame (debug.prev);
1625 return proc;
1626#endif
1627}
1628
1629
1630
1631
1632/* Apply a function to a list of arguments.
1633
1634 This function is exported to the Scheme level as taking two
1635 required arguments and a tail argument, as if it were:
1636 (lambda (proc arg1 . args) ...)
1637 Thus, if you just have a list of arguments to pass to a procedure,
1638 pass the list as ARG1, and '() for ARGS. If you have some fixed
1639 args, pass the first as ARG1, then cons any remaining fixed args
1640 onto the front of your argument list, and pass that as ARGS. */
1641
1642SCM
1643SCM_APPLY (SCM proc, SCM arg1, SCM args)
1644{
1645#ifdef DEVAL
1646 scm_t_debug_frame debug;
1647 scm_t_debug_info debug_vect_body;
1648 debug.prev = scm_i_last_debug_frame ();
1649 debug.status = SCM_APPLYFRAME;
1650 debug.vect = &debug_vect_body;
1651 debug.vect[0].a.proc = proc;
1652 debug.vect[0].a.args = SCM_EOL;
1653 scm_i_set_last_debug_frame (&debug);
1654#else
1655 if (scm_debug_mode_p)
1656 return scm_dapply (proc, arg1, args);
1657#endif
1658
1659 SCM_ASRTGO (SCM_NIMP (proc), badproc);
1660
1661 /* If ARGS is the empty list, then we're calling apply with only two
1662 arguments --- ARG1 is the list of arguments for PROC. Whatever
1663 the case, futz with things so that ARG1 is the first argument to
1664 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
1665 rest.
1666
1667 Setting the debug apply frame args this way is pretty messy.
1668 Perhaps we should store arg1 and args directly in the frame as
1669 received, and let scm_frame_arguments unpack them, because that's
1670 a relatively rare operation. This works for now; if the Guile
1671 developer archives are still around, see Mikael's post of
1672 11-Apr-97. */
1673 if (scm_is_null (args))
1674 {
1675 if (scm_is_null (arg1))
1676 {
1677 arg1 = SCM_UNDEFINED;
1678#ifdef DEVAL
1679 debug.vect[0].a.args = SCM_EOL;
1680#endif
1681 }
1682 else
1683 {
1684#ifdef DEVAL
1685 debug.vect[0].a.args = arg1;
1686#endif
1687 args = SCM_CDR (arg1);
1688 arg1 = SCM_CAR (arg1);
1689 }
1690 }
1691 else
1692 {
1693 args = scm_nconc2last (args);
1694#ifdef DEVAL
1695 debug.vect[0].a.args = scm_cons (arg1, args);
1696#endif
1697 }
1698#ifdef DEVAL
1699 if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
1700 {
1701 SCM tmp = scm_make_debugobj (&debug);
1702 SCM_TRAPS_P = 0;
1703 scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
1704 SCM_TRAPS_P = 1;
1705 }
1706 ENTER_APPLY;
1707#endif
1708tail:
1709 switch (SCM_TYP7 (proc))
1710 {
1711 case scm_tc7_subr_2o:
9cc37597 1712 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
0ee05b85
HWN		 1713 scm_wrong_num_args (proc);
1714 if (scm_is_null (args))
1715 args = SCM_UNDEFINED;
1716 else
1717 {
9cc37597 1718 if (SCM_UNLIKELY (! scm_is_null (SCM_CDR (args))))
0ee05b85
HWN		 1719 scm_wrong_num_args (proc);
1720 args = SCM_CAR (args);
1721 }
1722 RETURN (SCM_SUBRF (proc) (arg1, args));
1723 case scm_tc7_subr_2:
9cc37597
LC		 1724 if (SCM_UNLIKELY (scm_is_null (args) ||
1725 !scm_is_null (SCM_CDR (args))))
0ee05b85
HWN		 1726 scm_wrong_num_args (proc);
1727 args = SCM_CAR (args);
1728 RETURN (SCM_SUBRF (proc) (arg1, args));
1729 case scm_tc7_subr_0:
9cc37597 1730 if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
0ee05b85
HWN		 1731 scm_wrong_num_args (proc);
1732 else
1733 RETURN (SCM_SUBRF (proc) ());
1734 case scm_tc7_subr_1:
9cc37597 1735 if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
0ee05b85
HWN		 1736 scm_wrong_num_args (proc);
1737 case scm_tc7_subr_1o:
9cc37597 1738 if (SCM_UNLIKELY (!scm_is_null (args)))
0ee05b85
HWN		 1739 scm_wrong_num_args (proc);
1740 else
1741 RETURN (SCM_SUBRF (proc) (arg1));
1742 case scm_tc7_dsubr:
9cc37597 1743 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
0ee05b85
HWN		 1744 scm_wrong_num_args (proc);
1745 if (SCM_I_INUMP (arg1))
1746 {
1747 RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
1748 }
1749 else if (SCM_REALP (arg1))
1750 {
1751 RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
1752 }
1753 else if (SCM_BIGP (arg1))
1754 {
1755 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
1756 }
1757 else if (SCM_FRACTIONP (arg1))
1758 {
1759 RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
1760 }
1761 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
1762 SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
1763 case scm_tc7_cxr:
9cc37597 1764 if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
0ee05b85
HWN		 1765 scm_wrong_num_args (proc);
1766 RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
1767 case scm_tc7_subr_3:
9cc37597
LC		 1768 if (SCM_UNLIKELY (scm_is_null (args)
1769 || scm_is_null (SCM_CDR (args))
1770 || !scm_is_null (SCM_CDDR (args))))
0ee05b85
HWN		 1771 scm_wrong_num_args (proc);
1772 else
1773 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
1774 case scm_tc7_lsubr:
1775#ifdef DEVAL
1776 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
1777#else
1778 RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
1779#endif
1780 case scm_tc7_lsubr_2:
9cc37597 1781 if (SCM_UNLIKELY (!scm_is_pair (args)))
0ee05b85
HWN		 1782 scm_wrong_num_args (proc);
1783 else
1784 RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
1785 case scm_tc7_asubr:
1786 if (scm_is_null (args))
1787 RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
1788 while (SCM_NIMP (args))
1789 {
1790 SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
1791 arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
1792 args = SCM_CDR (args);
1793 }
1794 RETURN (arg1);
1795 case scm_tc7_rpsubr:
1796 if (scm_is_null (args))
1797 RETURN (SCM_BOOL_T);
1798 while (SCM_NIMP (args))
1799 {
1800 SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
1801 if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
1802 RETURN (SCM_BOOL_F);
1803 arg1 = SCM_CAR (args);
1804 args = SCM_CDR (args);
1805 }
1806 RETURN (SCM_BOOL_T);
1807 case scm_tcs_closures:
1808#ifdef DEVAL
1809 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
1810#else
1811 arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
1812#endif
9cc37597 1813 if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
0ee05b85
HWN		 1814 scm_wrong_num_args (proc);
1815
1816 /* Copy argument list */
1817 if (SCM_IMP (arg1))
1818 args = arg1;
1819 else
1820 {
1821 SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
1822 for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
1823 {
1824 SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
1825 tl = SCM_CDR (tl);
1826 }
1827 SCM_SETCDR (tl, arg1);
1828 }
1829
1830 args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
1831 args,
1832 SCM_ENV (proc));
1833 proc = SCM_CLOSURE_BODY (proc);
1834 again:
1835 arg1 = SCM_CDR (proc);
1836 while (!scm_is_null (arg1))
1837 {
1838 if (SCM_IMP (SCM_CAR (proc)))
1839 {
1840 if (SCM_ISYMP (SCM_CAR (proc)))
1841 {
1842 scm_dynwind_begin (0);
1843 scm_i_dynwind_pthread_mutex_lock (&source_mutex);
1844 /* check for race condition */
1845 if (SCM_ISYMP (SCM_CAR (proc)))
1846 m_expand_body (proc, args);
1847 scm_dynwind_end ();
1848 goto again;
1849 }
1850 else
1851 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
1852 }
1853 else
1854 (void) EVAL (SCM_CAR (proc), args);
1855 proc = arg1;
1856 arg1 = SCM_CDR (proc);
1857 }
1858 RETURN (EVALCAR (proc, args));
1859 case scm_tc7_smob:
1860 if (!SCM_SMOB_APPLICABLE_P (proc))
1861 goto badproc;
1862 if (SCM_UNBNDP (arg1))
1863 RETURN (SCM_SMOB_APPLY_0 (proc));
1864 else if (scm_is_null (args))
1865 RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
1866 else if (scm_is_null (SCM_CDR (args)))
1867 RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
1868 else
1869 RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
1870 case scm_tc7_cclo:
1871#ifdef DEVAL
1872 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1873 arg1 = proc;
1874 proc = SCM_CCLO_SUBR (proc);
1875 debug.vect[0].a.proc = proc;
1876 debug.vect[0].a.args = scm_cons (arg1, args);
1877#else
1878 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1879 arg1 = proc;
1880 proc = SCM_CCLO_SUBR (proc);
1881#endif
1882 goto tail;
1883 case scm_tc7_pws:
1884 proc = SCM_PROCEDURE (proc);
1885#ifdef DEVAL
1886 debug.vect[0].a.proc = proc;
1887#endif
1888 goto tail;
1889 case scm_tcs_struct:
1890 if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
1891 {
1892#ifdef DEVAL
1893 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1894#else
1895 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1896#endif
1897 RETURN (scm_apply_generic (proc, args));
1898 }
1899 else if (SCM_I_OPERATORP (proc))
1900 {
1901 /* operator */
1902#ifdef DEVAL
1903 args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
1904#else
1905 args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
1906#endif
1907 arg1 = proc;
1908 proc = (SCM_I_ENTITYP (proc)
1909 ? SCM_ENTITY_PROCEDURE (proc)
1910 : SCM_OPERATOR_PROCEDURE (proc));
1911#ifdef DEVAL
1912 debug.vect[0].a.proc = proc;
1913 debug.vect[0].a.args = scm_cons (arg1, args);
1914#endif
1915 if (SCM_NIMP (proc))
1916 goto tail;
1917 else
1918 goto badproc;
1919 }
1920 else
1921 goto badproc;
1922 default:
1923 badproc:
1924 scm_wrong_type_arg ("apply", SCM_ARG1, proc);
1925 }
1926#ifdef DEVAL
1927exit:
1928 if (scm_check_exit_p && SCM_TRAPS_P)
1929 if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
1930 {
1931 SCM_CLEAR_TRACED_FRAME (debug);
1932 arg1 = scm_make_debugobj (&debug);
1933 SCM_TRAPS_P = 0;
1934 arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
1935 SCM_TRAPS_P = 1;
1936 if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
1937 proc = SCM_CDR (arg1);
1938 }
1939 scm_i_set_last_debug_frame (debug.prev);
1940 return proc;
1941#endif
1942}
1943
Unnamed repository; edit this file 'description' to name the repository.