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