1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This file is read twice in order to produce debugging versions of
21 * scm_ceval and scm_apply. These functions, scm_deval and
22 * scm_dapply, are produced when we define the preprocessor macro
23 * DEVAL. The file is divided into sections which are treated
24 * differently with respect to DEVAL. The heads of these sections are
25 * marked with the string "SECTION:".
28 /* SECTION: This code is compiled once.
35 #include "libguile/__scm.h"
39 /* AIX requires this to be the first thing in the file. The #pragma
40 directive is indented so pre-ANSI compilers will ignore it, rather
49 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/debug.h"
58 #include "libguile/dynwind.h"
59 #include "libguile/alist.h"
60 #include "libguile/eq.h"
61 #include "libguile/continuations.h"
62 #include "libguile/futures.h"
63 #include "libguile/throw.h"
64 #include "libguile/smob.h"
65 #include "libguile/macros.h"
66 #include "libguile/procprop.h"
67 #include "libguile/hashtab.h"
68 #include "libguile/hash.h"
69 #include "libguile/srcprop.h"
70 #include "libguile/stackchk.h"
71 #include "libguile/objects.h"
72 #include "libguile/async.h"
73 #include "libguile/feature.h"
74 #include "libguile/modules.h"
75 #include "libguile/ports.h"
76 #include "libguile/root.h"
77 #include "libguile/vectors.h"
78 #include "libguile/fluids.h"
79 #include "libguile/goops.h"
80 #include "libguile/values.h"
82 #include "libguile/validate.h"
83 #include "libguile/eval.h"
84 #include "libguile/lang.h"
88 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
90 if (SCM_EQ_P ((x), SCM_EOL)) \
91 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
96 /* The evaluator contains a plethora of EVAL symbols.
97 * This is an attempt at explanation.
99 * The following macros should be used in code which is read twice
100 * (where the choice of evaluator is hard soldered):
102 * SCM_CEVAL is the symbol used within one evaluator to call itself.
103 * Originally, it is defined to scm_ceval, but is redefined to
104 * scm_deval during the second pass.
106 * SCM_EVALIM is used when it is known that the expression is an
107 * immediate. (This macro never calls an evaluator.)
109 * EVALCAR evaluates the car of an expression.
111 * The following macros should be used in code which is read once
112 * (where the choice of evaluator is dynamic):
114 * SCM_XEVAL takes care of immediates without calling an evaluator. It
115 * then calls scm_ceval *or* scm_deval, depending on the debugging
118 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
119 * depending on the debugging mode.
121 * The main motivation for keeping this plethora is efficiency
122 * together with maintainability (=> locality of code).
125 #define SCM_CEVAL scm_ceval
127 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
128 ? SCM_EVALIM (SCM_CAR (x), env) \
129 : (SCM_SYMBOLP (SCM_CAR (x)) \
130 ? *scm_lookupcar (x, env, 1) \
131 : SCM_CEVAL (SCM_CAR (x), env)))
133 SCM_REC_MUTEX (source_mutex
);
136 /* Lookup a given local variable in an environment. The local variable is
137 * given as an iloc, that is a triple <frame, binding, last?>, where frame
138 * indicates the relative number of the environment frame (counting upwards
139 * from the innermost environment frame), binding indicates the number of the
140 * binding within the frame, and last? (which is extracted from the iloc using
141 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
142 * very end of the improper list of bindings. */
144 scm_ilookup (SCM iloc
, SCM env
)
146 unsigned int frame_nr
= SCM_IFRAME (iloc
);
147 unsigned int binding_nr
= SCM_IDIST (iloc
);
151 for (; 0 != frame_nr
; --frame_nr
)
152 frames
= SCM_CDR (frames
);
154 bindings
= SCM_CAR (frames
);
155 for (; 0 != binding_nr
; --binding_nr
)
156 bindings
= SCM_CDR (bindings
);
158 if (SCM_ICDRP (iloc
))
159 return SCM_CDRLOC (bindings
);
160 return SCM_CARLOC (SCM_CDR (bindings
));
164 /* The Lookup Car Race
167 Memoization of variables and special forms is done while executing
168 the code for the first time. As long as there is only one thread
169 everything is fine, but as soon as two threads execute the same
170 code concurrently `for the first time' they can come into conflict.
172 This memoization includes rewriting variable references into more
173 efficient forms and expanding macros. Furthermore, macro expansion
174 includes `compiling' special forms like `let', `cond', etc. into
175 tree-code instructions.
177 There shouldn't normally be a problem with memoizing local and
178 global variable references (into ilocs and variables), because all
179 threads will mutate the code in *exactly* the same way and (if I
180 read the C code correctly) it is not possible to observe a half-way
181 mutated cons cell. The lookup procedure can handle this
182 transparently without any critical sections.
184 It is different with macro expansion, because macro expansion
185 happens outside of the lookup procedure and can't be
186 undone. Therefore the lookup procedure can't cope with it. It has
187 to indicate failure when it detects a lost race and hope that the
188 caller can handle it. Luckily, it turns out that this is the case.
190 An example to illustrate this: Suppose that the following form will
191 be memoized concurrently by two threads
195 Let's first examine the lookup of X in the body. The first thread
196 decides that it has to find the symbol "x" in the environment and
197 starts to scan it. Then the other thread takes over and actually
198 overtakes the first. It looks up "x" and substitutes an
199 appropriate iloc for it. Now the first thread continues and
200 completes its lookup. It comes to exactly the same conclusions as
201 the second one and could - without much ado - just overwrite the
202 iloc with the same iloc.
204 But let's see what will happen when the race occurs while looking
205 up the symbol "let" at the start of the form. It could happen that
206 the second thread interrupts the lookup of the first thread and not
207 only substitutes a variable for it but goes right ahead and
208 replaces it with the compiled form (#@let* (x 12) x). Now, when
209 the first thread completes its lookup, it would replace the #@let*
210 with a variable containing the "let" binding, effectively reverting
211 the form to (let (x 12) x). This is wrong. It has to detect that
212 it has lost the race and the evaluator has to reconsider the
213 changed form completely.
215 This race condition could be resolved with some kind of traffic
216 light (like mutexes) around scm_lookupcar, but I think that it is
217 best to avoid them in this case. They would serialize memoization
218 completely and because lookup involves calling arbitrary Scheme
219 code (via the lookup-thunk), threads could be blocked for an
220 arbitrary amount of time or even deadlock. But with the current
221 solution a lot of unnecessary work is potentially done. */
223 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
224 return NULL to indicate a failed lookup due to some race conditions
225 between threads. This only happens when VLOC is the first cell of
226 a special form that will eventually be memoized (like `let', etc.)
227 In that case the whole lookup is bogus and the caller has to
228 reconsider the complete special form.
230 SCM_LOOKUPCAR is still there, of course. It just calls
231 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
232 should only be called when it is known that VLOC is not the first
233 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
234 for NULL. I think I've found the only places where this
237 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
240 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
243 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
244 register SCM iloc
= SCM_ILOC00
;
245 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
247 if (!SCM_CONSP (SCM_CAR (env
)))
249 al
= SCM_CARLOC (env
);
250 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
254 if (SCM_EQ_P (fl
, var
))
256 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
258 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
259 return SCM_CDRLOC (*al
);
264 al
= SCM_CDRLOC (*al
);
265 if (SCM_EQ_P (SCM_CAR (fl
), var
))
267 if (SCM_UNBNDP (SCM_CAR (*al
)))
272 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
274 SCM_SETCAR (vloc
, iloc
);
275 return SCM_CARLOC (*al
);
277 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
279 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
282 SCM top_thunk
, real_var
;
285 top_thunk
= SCM_CAR (env
); /* env now refers to a
286 top level env thunk */
290 top_thunk
= SCM_BOOL_F
;
291 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
292 if (SCM_FALSEP (real_var
))
295 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
301 scm_error (scm_unbound_variable_key
, NULL
,
302 "Unbound variable: ~S",
303 scm_list_1 (var
), SCM_BOOL_F
);
305 scm_misc_error (NULL
, "Damaged environment: ~S",
310 /* A variable could not be found, but we shall
311 not throw an error. */
312 static SCM undef_object
= SCM_UNDEFINED
;
313 return &undef_object
;
317 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
319 /* Some other thread has changed the very cell we are working
320 on. In effect, it must have done our job or messed it up
323 var
= SCM_CAR (vloc
);
324 if (SCM_VARIABLEP (var
))
325 return SCM_VARIABLE_LOC (var
);
326 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
327 return scm_ilookup (var
, genv
);
328 /* We can't cope with anything else than variables and ilocs. When
329 a special form has been memoized (i.e. `let' into `#@let') we
330 return NULL and expect the calling function to do the right
331 thing. For the evaluator, this means going back and redoing
332 the dispatch on the car of the form. */
336 SCM_SETCAR (vloc
, real_var
);
337 return SCM_VARIABLE_LOC (real_var
);
342 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
344 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
350 #define unmemocar scm_unmemocar
352 SCM_SYMBOL (sym_three_question_marks
, "???");
355 scm_unmemocar (SCM form
, SCM env
)
357 if (!SCM_CONSP (form
))
361 SCM c
= SCM_CAR (form
);
362 if (SCM_VARIABLEP (c
))
364 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
365 if (SCM_FALSEP (sym
))
366 sym
= sym_three_question_marks
;
367 SCM_SETCAR (form
, sym
);
369 else if (SCM_ILOCP (c
))
371 unsigned long int ir
;
373 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
375 env
= SCM_CAAR (env
);
376 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
378 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
386 scm_eval_car (SCM pair
, SCM env
)
388 return SCM_XEVALCAR (pair
, env
);
393 * The following rewrite expressions and
394 * some memoized forms have different syntax
397 const char scm_s_expression
[] = "missing or extra expression";
398 const char scm_s_test
[] = "bad test";
399 const char scm_s_body
[] = "bad body";
400 const char scm_s_bindings
[] = "bad bindings";
401 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
402 const char scm_s_variable
[] = "bad variable";
403 const char scm_s_clauses
[] = "bad or missing clauses";
404 const char scm_s_formals
[] = "bad formals";
405 const char scm_s_duplicate_formals
[] = "duplicate formals";
406 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
408 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
409 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
410 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
411 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
412 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
414 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
415 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
416 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
417 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
420 /* Check that the body denoted by XORIG is valid and rewrite it into
421 its internal form. The internal form of a body is just the body
422 itself, but prefixed with an ISYM that denotes to what kind of
423 outer construct this body belongs. A lambda body starts with
424 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
425 etc. The one exception is a body that belongs to a letrec that has
426 been formed by rewriting internal defines: it starts with
429 /* XXX - Besides controlling the rewriting of internal defines, the
430 additional ISYM could be used for improved error messages.
431 This is not done yet. */
434 scm_m_body (SCM op
, SCM xorig
, const char *what
)
436 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
438 /* Don't add another ISYM if one is present already. */
439 if (SCM_ISYMP (SCM_CAR (xorig
)))
442 /* Retain possible doc string. */
443 if (!SCM_CONSP (SCM_CAR (xorig
)))
445 if (!SCM_NULLP (SCM_CDR (xorig
)))
446 return scm_cons (SCM_CAR (xorig
),
447 scm_m_body (op
, SCM_CDR (xorig
), what
));
451 return scm_cons (op
, xorig
);
455 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
456 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
459 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
461 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
462 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
466 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
467 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
470 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
472 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
473 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
477 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
478 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
481 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
483 long len
= scm_ilength (SCM_CDR (xorig
));
484 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
485 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
489 /* Will go into the RnRS module when Guile is factorized.
490 SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */
491 static const char s_set_x
[] = "set!";
492 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
495 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
497 SCM x
= SCM_CDR (xorig
);
498 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, s_set_x
);
499 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, s_set_x
);
500 return scm_cons (SCM_IM_SET_X
, x
);
504 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
505 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
508 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
510 long len
= scm_ilength (SCM_CDR (xorig
));
511 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
513 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
519 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
520 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
523 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
525 long len
= scm_ilength (SCM_CDR (xorig
));
526 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
528 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
534 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
535 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
538 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
541 SCM cdrx
= SCM_CDR (xorig
);
542 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
543 clauses
= SCM_CDR (cdrx
);
544 while (!SCM_NULLP (clauses
))
546 SCM clause
= SCM_CAR (clauses
);
547 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
548 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
549 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
550 && SCM_NULLP (SCM_CDR (clauses
))),
551 scm_s_clauses
, s_case
);
552 clauses
= SCM_CDR (clauses
);
554 return scm_cons (SCM_IM_CASE
, cdrx
);
558 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
559 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
562 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
564 SCM cdrx
= SCM_CDR (xorig
);
566 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
567 while (!SCM_NULLP (clauses
))
569 SCM clause
= SCM_CAR (clauses
);
570 long len
= scm_ilength (clause
);
571 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
572 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
574 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
575 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
577 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
579 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
580 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
582 clauses
= SCM_CDR (clauses
);
584 return scm_cons (SCM_IM_COND
, cdrx
);
588 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
589 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
591 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
592 * cdr of the last cons. (Thus, LIST is not required to be a proper
593 * list and OBJ can also be found in the improper ending.) */
595 scm_c_improper_memq (SCM obj
, SCM list
)
597 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
599 if (SCM_EQ_P (SCM_CAR (list
), obj
))
602 return SCM_EQ_P (list
, obj
);
606 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
609 SCM x
= SCM_CDR (xorig
);
611 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
613 formals
= SCM_CAR (x
);
614 while (SCM_CONSP (formals
))
616 SCM formal
= SCM_CAR (formals
);
617 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
618 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
619 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
620 formals
= SCM_CDR (formals
);
622 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
623 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
625 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
626 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
630 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
631 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
633 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
634 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
636 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
639 SCM x
= SCM_CDR (xorig
);
643 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
645 bindings
= SCM_CAR (x
);
646 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
647 while (!SCM_NULLP (bindings
))
649 SCM binding
= SCM_CAR (bindings
);
650 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
651 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
652 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
653 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
654 bindings
= SCM_CDR (bindings
);
657 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
658 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
662 /* DO gets the most radically altered syntax. The order of the vars is
663 * reversed here. In contrast, the order of the inits and steps is reversed
664 * during the evaluation:
666 (do ((<var1> <init1> <step1>)
674 (#@do (varn ... var2 var1)
675 (<init1> <init2> ... <initn>)
678 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
681 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
682 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
685 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
688 SCM x
= SCM_CDR (xorig
);
691 SCM
*initloc
= &inits
;
693 SCM
*steploc
= &steps
;
694 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
695 bindings
= SCM_CAR (x
);
696 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
697 while (!SCM_NULLP (bindings
))
699 SCM binding
= SCM_CAR (bindings
);
700 long len
= scm_ilength (binding
);
701 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
703 SCM name
= SCM_CAR (binding
);
704 SCM init
= SCM_CADR (binding
);
705 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
706 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
707 vars
= scm_cons (name
, vars
);
708 *initloc
= scm_list_1 (init
);
709 initloc
= SCM_CDRLOC (*initloc
);
710 *steploc
= scm_list_1 (step
);
711 steploc
= SCM_CDRLOC (*steploc
);
712 bindings
= SCM_CDR (bindings
);
716 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
717 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
718 x
= scm_cons2 (vars
, inits
, x
);
719 return scm_cons (SCM_IM_DO
, x
);
723 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
724 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
726 /* Internal function to handle a quasiquotation: 'form' is the parameter in
727 * the call (quasiquotation form), 'env' is the environment where unquoted
728 * expressions will be evaluated, and 'depth' is the current quasiquotation
729 * nesting level and is known to be greater than zero. */
731 iqq (SCM form
, SCM env
, unsigned long int depth
)
733 if (SCM_CONSP (form
))
735 SCM tmp
= SCM_CAR (form
);
736 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
738 SCM args
= SCM_CDR (form
);
739 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
740 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
742 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
744 SCM args
= SCM_CDR (form
);
745 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
747 return scm_eval_car (args
, env
);
749 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
751 else if (SCM_CONSP (tmp
)
752 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
754 SCM args
= SCM_CDR (tmp
);
755 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
758 SCM list
= scm_eval_car (args
, env
);
759 SCM rest
= SCM_CDR (form
);
760 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
761 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
764 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
765 iqq (SCM_CDR (form
), env
, depth
));
768 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
769 iqq (SCM_CDR (form
), env
, depth
));
771 else if (SCM_VECTORP (form
))
773 size_t i
= SCM_VECTOR_LENGTH (form
);
774 SCM
const *const data
= SCM_VELTS (form
);
777 tmp
= scm_cons (data
[--i
], tmp
);
778 scm_remember_upto_here_1 (form
);
779 return scm_vector (iqq (tmp
, env
, depth
));
786 scm_m_quasiquote (SCM xorig
, SCM env
)
788 SCM x
= SCM_CDR (xorig
);
789 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
790 return iqq (SCM_CAR (x
), env
, 1);
794 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
795 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
797 /* Promises are implemented as closures with an empty parameter list. Thus,
798 * (delay <expression>) is transformed into (#@delay '() <expression>), where
799 * the empty list represents the empty parameter list. This representation
800 * allows for easy creation of the closure during evaluation. */
802 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
804 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
805 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
809 SCM_SYNTAX (s_gset_x
, "set!", scm_makmmacro
, scm_m_generalized_set_x
);
810 SCM_SYMBOL (scm_sym_setter
, "setter");
813 scm_m_generalized_set_x (SCM xorig
, SCM env SCM_UNUSED
)
815 SCM x
= SCM_CDR (xorig
);
816 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, s_set_x
);
817 if (SCM_SYMBOLP (SCM_CAR (x
)))
818 return scm_cons (SCM_IM_SET_X
, x
);
819 else if (SCM_CONSP (SCM_CAR (x
)))
820 return scm_cons (scm_list_2 (scm_sym_setter
, SCM_CAAR (x
)),
821 scm_append (scm_list_2 (SCM_CDAR (x
), SCM_CDR (x
))));
823 scm_misc_error (s_set_x
, scm_s_variable
, SCM_EOL
);
827 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
828 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
830 /* Like promises, futures are implemented as closures with an empty
831 * parameter list. Thus, (future <expression>) is transformed into
832 * (#@future '() <expression>), where the empty list represents the
833 * empty parameter list. This representation allows for easy creation
834 * of the closure during evaluation. */
836 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
838 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
839 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
843 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
844 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
846 /* Guile provides an extension to R5RS' define syntax to represent function
847 * currying in a compact way. With this extension, it is allowed to write
848 * (define <nested-variable> <body>), where <nested-variable> has of one of
849 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
850 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
851 * should be either a sequence of zero or more variables, or a sequence of one
852 * or more variables followed by a space-delimited period and another
853 * variable. Each level of argument nesting wraps the <body> within another
854 * lambda expression. For example, the following forms are allowed, each one
855 * followed by an equivalent, more explicit implementation.
857 * (define ((a b . c) . d) <body>) is equivalent to
858 * (define a (lambda (b . c) (lambda d <body>)))
860 * (define (((a) b) c . d) <body>) is equivalent to
861 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
863 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
864 * module that does not implement this extension. */
866 scm_m_define (SCM x
, SCM env
)
870 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
873 while (SCM_CONSP (name
))
875 /* This while loop realizes function currying by variable nesting. */
876 SCM formals
= SCM_CDR (name
);
877 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
878 name
= SCM_CAR (name
);
880 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
881 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
882 if (SCM_TOP_LEVEL (env
))
885 x
= scm_eval_car (x
, env
);
886 if (SCM_REC_PROCNAMES_P
)
889 while (SCM_MACROP (tmp
))
890 tmp
= SCM_MACRO_CODE (tmp
);
891 if (SCM_CLOSUREP (tmp
)
892 /* Only the first definition determines the name. */
893 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
894 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
896 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
897 SCM_VARIABLE_SET (var
, x
);
898 return SCM_UNSPECIFIED
;
901 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
905 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
906 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
907 * reversed here, the list of inits gets reversed during evaluation. */
909 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
915 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
919 SCM binding
= SCM_CAR (bindings
);
920 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
921 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
922 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
923 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
924 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
925 *initloc
= scm_list_1 (SCM_CADR (binding
));
926 initloc
= SCM_CDRLOC (*initloc
);
927 bindings
= SCM_CDR (bindings
);
929 while (!SCM_NULLP (bindings
));
935 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
936 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
939 scm_m_letrec (SCM xorig
, SCM env
)
941 SCM x
= SCM_CDR (xorig
);
942 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
944 if (SCM_NULLP (SCM_CAR (x
)))
946 /* null binding, let* faster */
947 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
948 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
952 SCM rvars
, inits
, body
;
953 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
954 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
955 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
960 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
961 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
964 scm_m_let (SCM xorig
, SCM env
)
966 SCM x
= SCM_CDR (xorig
);
969 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
972 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
974 /* null or single binding, let* is faster */
976 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
977 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
979 else if (SCM_CONSP (temp
))
983 SCM rvars
, inits
, body
;
984 transform_bindings (bindings
, &rvars
, &inits
, "let");
985 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
986 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
990 /* named let: Transform (let name ((var init) ...) body ...) into
991 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
997 SCM
*initloc
= &inits
;
1000 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1002 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1003 bindings
= SCM_CAR (x
);
1004 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1005 while (!SCM_NULLP (bindings
))
1006 { /* vars and inits both in order */
1007 SCM binding
= SCM_CAR (bindings
);
1008 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1009 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1010 *varloc
= scm_list_1 (SCM_CAR (binding
));
1011 varloc
= SCM_CDRLOC (*varloc
);
1012 *initloc
= scm_list_1 (SCM_CADR (binding
));
1013 initloc
= SCM_CDRLOC (*initloc
);
1014 bindings
= SCM_CDR (bindings
);
1018 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1019 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1020 SCM rvar
= scm_list_1 (name
);
1021 SCM init
= scm_list_1 (lambda_form
);
1022 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1023 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1024 return scm_cons (letrec
, inits
);
1030 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1031 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1032 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1035 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1037 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1038 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1042 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1043 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1047 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1049 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1050 scm_s_expression
, s_atcall_cc
);
1051 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1054 #if SCM_ENABLE_ELISP
1056 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1059 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1061 long len
= scm_ilength (SCM_CDR (xorig
));
1062 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1063 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1066 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1069 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1071 SCM x
= SCM_CDR (xorig
), var
;
1072 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1073 var
= scm_symbol_fref (SCM_CAR (x
));
1074 /* Passing the symbol name as the `subr' arg here isn't really
1075 right, but without it it can be very difficult to work out from
1076 the error message which function definition was missing. In any
1077 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1078 something equivalent to (signal void-function (list SYM)) in
1080 SCM_ASSYNT (SCM_VARIABLEP (var
),
1081 "Symbol's function definition is void",
1082 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1083 /* Support `defalias'. */
1084 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1086 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1087 SCM_ASSYNT (SCM_VARIABLEP (var
),
1088 "Symbol's function definition is void",
1089 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1091 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1092 former allows for automatically picking up redefinitions of the
1093 corresponding symbol. */
1094 SCM_SETCAR (x
, var
);
1095 /* If the variable contains a procedure, leave the
1096 `transformer-macro' in place so that the procedure's arguments
1097 get properly transformed, and change the initial @fop to
1099 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1101 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1104 /* Otherwise (the variable contains a macro), the arguments should
1105 not be transformed, so cut the `transformer-macro' out and return
1106 the resulting expression starting with the variable. */
1107 SCM_SETCDR (x
, SCM_CDADR (x
));
1111 #endif /* SCM_ENABLE_ELISP */
1113 /* (@bind ((var exp) ...) body ...)
1115 This will assign the values of the `exp's to the global variables
1116 named by `var's (symbols, not evaluated), creating them if they
1117 don't exist, executes body, and then restores the previous values of
1118 the `var's. Additionally, whenever control leaves body, the values
1119 of the `var's are saved and restored when control returns. It is an
1120 error when a symbol appears more than once among the `var's.
1121 All `exp's are evaluated before any `var' is set.
1123 Think of this as `let' for dynamic scope.
1125 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1127 XXX - also implement `@bind*'.
1130 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1133 scm_m_atbind (SCM xorig
, SCM env
)
1135 SCM x
= SCM_CDR (xorig
);
1136 SCM top_level
= scm_env_top_level (env
);
1137 SCM vars
= SCM_EOL
, var
;
1140 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1143 while (SCM_NIMP (x
))
1146 SCM sym_exp
= SCM_CAR (x
);
1147 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1148 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1150 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1151 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1152 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1153 /* The first call to scm_sym2var will look beyond the current
1154 module, while the second call wont. */
1155 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1156 if (SCM_FALSEP (var
))
1157 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1158 vars
= scm_cons (var
, vars
);
1159 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1161 return scm_cons (SCM_IM_BIND
,
1162 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1166 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1169 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1170 #define FUNC_NAME s_atslot_ref
1172 SCM x
= SCM_CDR (xorig
);
1173 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1174 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1175 return scm_cons (SCM_IM_SLOT_REF
, x
);
1180 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1183 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1184 #define FUNC_NAME s_atslot_set_x
1186 SCM x
= SCM_CDR (xorig
);
1187 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1188 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1189 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1194 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1196 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1199 scm_m_atdispatch (SCM xorig
, SCM env
)
1200 #define FUNC_NAME s_atdispatch
1202 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1203 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
1205 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
1206 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
1208 n
= SCM_XEVALCAR (x
, env
);
1209 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
1210 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1212 v
= SCM_XEVALCAR (x
, env
);
1213 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
1215 gf
= SCM_XEVALCAR (x
, env
);
1216 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
1217 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1222 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1223 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1226 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1228 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1229 scm_s_expression
, s_at_call_with_values
);
1230 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1234 scm_m_expand_body (SCM xorig
, SCM env
)
1236 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1237 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1239 while (SCM_NIMP (x
))
1241 SCM form
= SCM_CAR (x
);
1242 if (!SCM_CONSP (form
))
1244 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1247 form
= scm_macroexp (scm_cons_source (form
,
1252 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1254 defs
= scm_cons (SCM_CDR (form
), defs
);
1257 else if (!SCM_IMP (defs
))
1261 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1263 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1267 x
= scm_cons (form
, SCM_CDR (x
));
1272 if (!SCM_NULLP (defs
))
1274 SCM rvars
, inits
, body
, letrec
;
1275 transform_bindings (defs
, &rvars
, &inits
, what
);
1276 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1277 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1278 SCM_SETCAR (xorig
, letrec
);
1279 SCM_SETCDR (xorig
, SCM_EOL
);
1283 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1284 SCM_SETCAR (xorig
, SCM_CAR (x
));
1285 SCM_SETCDR (xorig
, SCM_CDR (x
));
1292 scm_macroexp (SCM x
, SCM env
)
1294 SCM res
, proc
, orig_sym
;
1296 /* Don't bother to produce error messages here. We get them when we
1297 eventually execute the code for real. */
1300 orig_sym
= SCM_CAR (x
);
1301 if (!SCM_SYMBOLP (orig_sym
))
1305 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1306 if (proc_ptr
== NULL
)
1308 /* We have lost the race. */
1314 /* Only handle memoizing macros. `Acros' and `macros' are really
1315 special forms and should not be evaluated here. */
1317 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1320 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1321 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1323 if (scm_ilength (res
) <= 0)
1324 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1327 SCM_SETCAR (x
, SCM_CAR (res
));
1328 SCM_SETCDR (x
, SCM_CDR (res
));
1334 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1336 /* A function object to implement "apply" for non-closure functions. */
1338 /* An endless list consisting of #<undefined> objects: */
1339 static SCM undefineds
;
1341 /* scm_unmemocopy takes a memoized expression together with its
1342 * environment and rewrites it to its original form. Thus, it is the
1343 * inversion of the rewrite rules above. The procedure is not
1344 * optimized for speed. It's used in scm_iprin1 when printing the
1345 * code of a closure, in scm_procedure_source, in display_frame when
1346 * generating the source for a stackframe in a backtrace, and in
1347 * display_expression.
1349 * Unmemoizing is not a reliable process. You cannot in general
1350 * expect to get the original source back.
1352 * However, GOOPS currently relies on this for method compilation.
1353 * This ought to change.
1357 build_binding_list (SCM names
, SCM inits
)
1359 SCM bindings
= SCM_EOL
;
1360 while (!SCM_NULLP (names
))
1362 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1363 bindings
= scm_cons (binding
, bindings
);
1364 names
= SCM_CDR (names
);
1365 inits
= SCM_CDR (inits
);
1371 unmemocopy (SCM x
, SCM env
)
1377 p
= scm_whash_lookup (scm_source_whash
, x
);
1378 switch (SCM_ITAG7 (SCM_CAR (x
)))
1380 case SCM_BIT7 (SCM_IM_AND
):
1381 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1383 case SCM_BIT7 (SCM_IM_BEGIN
):
1384 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1386 case SCM_BIT7 (SCM_IM_CASE
):
1387 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1389 case SCM_BIT7 (SCM_IM_COND
):
1390 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1392 case SCM_BIT7 (SCM_IM_DO
):
1394 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1395 * where nx is the name of a local variable, ix is an initializer for
1396 * the local variable, test is the test clause of the do loop, body is
1397 * the body of the do loop and sx are the step clauses for the local
1399 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1402 names
= SCM_CAR (x
);
1404 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1405 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1407 test
= unmemocopy (SCM_CAR (x
), env
);
1409 memoized_body
= SCM_CAR (x
);
1411 steps
= scm_reverse (unmemocopy (x
, env
));
1413 /* build transformed binding list */
1415 while (!SCM_NULLP (names
))
1417 SCM name
= SCM_CAR (names
);
1418 SCM init
= SCM_CAR (inits
);
1419 SCM step
= SCM_CAR (steps
);
1420 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1422 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1424 names
= SCM_CDR (names
);
1425 inits
= SCM_CDR (inits
);
1426 steps
= SCM_CDR (steps
);
1428 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1429 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1431 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1434 case SCM_BIT7 (SCM_IM_IF
):
1435 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1437 case SCM_BIT7 (SCM_IM_LET
):
1439 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1440 * where nx is the name of a local variable, ix is an initializer for
1441 * the local variable and by are the body clauses. */
1442 SCM names
, inits
, bindings
;
1445 names
= SCM_CAR (x
);
1447 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1448 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1450 bindings
= build_binding_list (names
, inits
);
1451 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1452 ls
= scm_cons (scm_sym_let
, z
);
1455 case SCM_BIT7 (SCM_IM_LETREC
):
1457 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1458 * where nx is the name of a local variable, ix is an initializer for
1459 * the local variable and by are the body clauses. */
1460 SCM names
, inits
, bindings
;
1463 names
= SCM_CAR (x
);
1464 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1466 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1468 bindings
= build_binding_list (names
, inits
);
1469 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1470 ls
= scm_cons (scm_sym_letrec
, z
);
1473 case SCM_BIT7 (SCM_IM_LETSTAR
):
1481 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1484 y
= z
= scm_acons (SCM_CAR (b
),
1486 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1488 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1492 SCM_SETCDR (y
, SCM_EOL
);
1493 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1494 ls
= scm_cons (scm_sym_let
, z
);
1499 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1501 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1504 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1507 while (SCM_NIMP (b
));
1508 SCM_SETCDR (z
, SCM_EOL
);
1510 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1511 ls
= scm_cons (scm_sym_letstar
, z
);
1514 case SCM_BIT7 (SCM_IM_OR
):
1515 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1517 case SCM_BIT7 (SCM_IM_LAMBDA
):
1519 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1520 ls
= scm_cons (scm_sym_lambda
, z
);
1521 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1523 case SCM_BIT7 (SCM_IM_QUOTE
):
1524 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1526 case SCM_BIT7 (SCM_IM_SET_X
):
1527 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1529 case SCM_BIT7 (SCM_IM_DEFINE
):
1534 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1535 ls
= scm_cons (scm_sym_define
, z
);
1536 if (!SCM_NULLP (env
))
1537 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1542 case SCM_BIT7 (SCM_MAKISYM (0)):
1546 switch (SCM_ISYMNUM (z
))
1548 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1549 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1551 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1552 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1554 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1555 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1558 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1559 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1562 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1563 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1566 /* appease the Sun compiler god: */ ;
1570 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1576 while (SCM_CONSP (x
))
1578 SCM form
= SCM_CAR (x
);
1579 if (!SCM_ISYMP (form
))
1581 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1582 SCM_SETCDR (z
, unmemocar (copy
, env
));
1588 if (!SCM_FALSEP (p
))
1589 scm_whash_insert (scm_source_whash
, ls
, p
);
1595 scm_unmemocopy (SCM x
, SCM env
)
1597 if (!SCM_NULLP (env
))
1598 /* Make a copy of the lowest frame to protect it from
1599 modifications by SCM_IM_DEFINE */
1600 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1602 return unmemocopy (x
, env
);
1607 scm_badargsp (SCM formals
, SCM args
)
1609 while (!SCM_NULLP (formals
))
1611 if (!SCM_CONSP (formals
))
1613 if (SCM_NULLP (args
))
1615 formals
= SCM_CDR (formals
);
1616 args
= SCM_CDR (args
);
1618 return !SCM_NULLP (args
) ? 1 : 0;
1623 scm_badformalsp (SCM closure
, int n
)
1625 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1626 while (!SCM_NULLP (formals
))
1628 if (!SCM_CONSP (formals
))
1633 formals
= SCM_CDR (formals
);
1640 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1642 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1643 while (SCM_CONSP (l
))
1645 res
= EVALCAR (l
, env
);
1647 *lloc
= scm_list_1 (res
);
1648 lloc
= SCM_CDRLOC (*lloc
);
1652 scm_wrong_num_args (proc
);
1658 scm_eval_body (SCM code
, SCM env
)
1662 next
= SCM_CDR (code
);
1663 while (!SCM_NULLP (next
))
1665 if (SCM_IMP (SCM_CAR (code
)))
1667 if (SCM_ISYMP (SCM_CAR (code
)))
1669 scm_rec_mutex_lock (&source_mutex
);
1670 /* check for race condition */
1671 if (SCM_ISYMP (SCM_CAR (code
)))
1672 code
= scm_m_expand_body (code
, env
);
1673 scm_rec_mutex_unlock (&source_mutex
);
1678 SCM_XEVAL (SCM_CAR (code
), env
);
1680 next
= SCM_CDR (code
);
1682 return SCM_XEVALCAR (code
, env
);
1688 /* SECTION: This code is specific for the debugging support. One
1689 * branch is read when DEVAL isn't defined, the other when DEVAL is
1695 #define SCM_APPLY scm_apply
1696 #define PREP_APPLY(proc, args)
1698 #define RETURN(x) do { return x; } while (0)
1699 #ifdef STACK_CHECKING
1700 #ifndef NO_CEVAL_STACK_CHECKING
1701 #define EVAL_STACK_CHECKING
1708 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1710 #define SCM_APPLY scm_dapply
1712 #define PREP_APPLY(p, l) \
1713 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1715 #define ENTER_APPLY \
1717 SCM_SET_ARGSREADY (debug);\
1718 if (scm_check_apply_p && SCM_TRAPS_P)\
1719 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1721 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1722 SCM_SET_TRACED_FRAME (debug); \
1724 if (SCM_CHEAPTRAPS_P)\
1726 tmp = scm_make_debugobj (&debug);\
1727 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1732 tmp = scm_make_continuation (&first);\
1734 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1740 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1741 #ifdef STACK_CHECKING
1742 #ifndef EVAL_STACK_CHECKING
1743 #define EVAL_STACK_CHECKING
1747 /* scm_ceval_ptr points to the currently selected evaluator.
1748 * *fixme*: Although efficiency is important here, this state variable
1749 * should probably not be a global. It should be related to the
1754 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1756 /* scm_last_debug_frame contains a pointer to the last debugging
1757 * information stack frame. It is accessed very often from the
1758 * debugging evaluator, so it should probably not be indirectly
1759 * addressed. Better to save and restore it from the current root at
1763 /* scm_debug_eframe_size is the number of slots available for pseudo
1764 * stack frames at each real stack frame.
1767 long scm_debug_eframe_size
;
1769 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1771 long scm_eval_stack
;
1773 scm_t_option scm_eval_opts
[] = {
1774 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1777 scm_t_option scm_debug_opts
[] = {
1778 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1779 "*Flyweight representation of the stack at traps." },
1780 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1781 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1782 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1783 "Record procedure names at definition." },
1784 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1785 "Display backtrace in anti-chronological order." },
1786 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1787 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1788 { SCM_OPTION_INTEGER
, "frames", 3,
1789 "Maximum number of tail-recursive frames in backtrace." },
1790 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1791 "Maximal number of stored backtrace frames." },
1792 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1793 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1794 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1795 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1796 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
1799 scm_t_option scm_evaluator_trap_table
[] = {
1800 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1801 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1802 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1803 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1804 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1805 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1806 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1809 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1811 "Option interface for the evaluation options. Instead of using\n"
1812 "this procedure directly, use the procedures @code{eval-enable},\n"
1813 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1814 #define FUNC_NAME s_scm_eval_options_interface
1818 ans
= scm_options (setting
,
1822 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1829 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1831 "Option interface for the evaluator trap options.")
1832 #define FUNC_NAME s_scm_evaluator_traps
1836 ans
= scm_options (setting
,
1837 scm_evaluator_trap_table
,
1838 SCM_N_EVALUATOR_TRAPS
,
1840 SCM_RESET_DEBUG_MODE
;
1848 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1850 SCM
*results
= lloc
, res
;
1851 while (SCM_CONSP (l
))
1853 res
= EVALCAR (l
, env
);
1855 *lloc
= scm_list_1 (res
);
1856 lloc
= SCM_CDRLOC (*lloc
);
1860 scm_wrong_num_args (proc
);
1867 /* SECTION: This code is compiled twice.
1871 /* Update the toplevel environment frame ENV so that it refers to the
1872 * current module. */
1873 #define UPDATE_TOPLEVEL_ENV(env) \
1875 SCM p = scm_current_module_lookup_closure (); \
1876 if (p != SCM_CAR (env)) \
1877 env = scm_top_level_env (p); \
1881 /* This is the evaluator. Like any real monster, it has three heads:
1883 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1884 * version. Both are implemented using a common code base, using the
1885 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1886 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1887 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1888 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1889 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1890 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1891 * are enclosed within #ifdef DEVAL ... #endif.
1893 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1894 * take two input parameters, x and env: x is a single expression to be
1895 * evalutated. env is the environment in which bindings are searched.
1897 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1898 * is a single expression, it is necessarily in a tail position. If x is just
1899 * a call to another function like in the expression (foo exp1 exp2 ...), the
1900 * realization of that call therefore _must_not_ increase stack usage (the
1901 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1902 * making extensive use of 'goto' statements within the evaluator: The gotos
1903 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1904 * that SCM_CEVAL was already using. If, however, x represents some form that
1905 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1906 * then recursive calls to SCM_CEVAL are performed for all but the last
1907 * expression of that sequence. */
1911 scm_ceval (SCM x
, SCM env
)
1917 scm_deval (SCM x
, SCM env
)
1922 SCM_CEVAL (SCM x
, SCM env
)
1926 scm_t_debug_frame debug
;
1927 scm_t_debug_info
*debug_info_end
;
1928 debug
.prev
= scm_last_debug_frame
;
1931 * The debug.vect contains twice as much scm_t_debug_info frames as the
1932 * user has specified with (debug-set! frames <n>).
1934 * Even frames are eval frames, odd frames are apply frames.
1936 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1937 * sizeof (scm_t_debug_info
));
1938 debug
.info
= debug
.vect
;
1939 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1940 scm_last_debug_frame
= &debug
;
1942 #ifdef EVAL_STACK_CHECKING
1943 if (scm_stack_checking_enabled_p
1944 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1947 debug
.info
->e
.exp
= x
;
1948 debug
.info
->e
.env
= env
;
1950 scm_report_stack_overflow ();
1960 SCM_CLEAR_ARGSREADY (debug
);
1961 if (SCM_OVERFLOWP (debug
))
1964 * In theory, this should be the only place where it is necessary to
1965 * check for space in debug.vect since both eval frames and
1966 * available space are even.
1968 * For this to be the case, however, it is necessary that primitive
1969 * special forms which jump back to `loop', `begin' or some similar
1970 * label call PREP_APPLY.
1972 else if (++debug
.info
>= debug_info_end
)
1974 SCM_SET_OVERFLOW (debug
);
1979 debug
.info
->e
.exp
= x
;
1980 debug
.info
->e
.env
= env
;
1981 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1983 if (SCM_ENTER_FRAME_P
1984 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1987 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1988 SCM_SET_TAILREC (debug
);
1989 if (SCM_CHEAPTRAPS_P
)
1990 stackrep
= scm_make_debugobj (&debug
);
1994 SCM val
= scm_make_continuation (&first
);
2004 /* This gives the possibility for the debugger to
2005 modify the source expression before evaluation. */
2010 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2011 scm_sym_enter_frame
,
2014 scm_unmemocopy (x
, env
));
2021 switch (SCM_TYP7 (x
))
2023 case scm_tc7_symbol
:
2024 /* Only happens when called at top level. */
2025 x
= scm_cons (x
, SCM_UNDEFINED
);
2026 RETURN (*scm_lookupcar (x
, env
, 1));
2028 case SCM_BIT7 (SCM_IM_AND
):
2030 while (!SCM_NULLP (SCM_CDR (x
)))
2032 SCM test_result
= EVALCAR (x
, env
);
2033 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2034 RETURN (SCM_BOOL_F
);
2038 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2041 case SCM_BIT7 (SCM_IM_BEGIN
):
2044 RETURN (SCM_UNSPECIFIED
);
2046 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2049 /* If we are on toplevel with a lookup closure, we need to sync
2050 with the current module. */
2051 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2053 UPDATE_TOPLEVEL_ENV (env
);
2054 while (!SCM_NULLP (SCM_CDR (x
)))
2057 UPDATE_TOPLEVEL_ENV (env
);
2063 goto nontoplevel_begin
;
2066 while (!SCM_NULLP (SCM_CDR (x
)))
2068 SCM form
= SCM_CAR (x
);
2071 if (SCM_ISYMP (form
))
2073 scm_rec_mutex_lock (&source_mutex
);
2074 /* check for race condition */
2075 if (SCM_ISYMP (SCM_CAR (x
)))
2076 x
= scm_m_expand_body (x
, env
);
2077 scm_rec_mutex_unlock (&source_mutex
);
2078 goto nontoplevel_begin
;
2081 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2084 SCM_CEVAL (form
, env
);
2090 /* scm_eval last form in list */
2091 SCM last_form
= SCM_CAR (x
);
2093 if (SCM_CONSP (last_form
))
2095 /* This is by far the most frequent case. */
2097 goto loop
; /* tail recurse */
2099 else if (SCM_IMP (last_form
))
2100 RETURN (SCM_EVALIM (last_form
, env
));
2101 else if (SCM_VARIABLEP (last_form
))
2102 RETURN (SCM_VARIABLE_REF (last_form
));
2103 else if (SCM_SYMBOLP (last_form
))
2104 RETURN (*scm_lookupcar (x
, env
, 1));
2110 case SCM_BIT7 (SCM_IM_CASE
):
2113 SCM key
= EVALCAR (x
, env
);
2115 while (!SCM_NULLP (x
))
2117 SCM clause
= SCM_CAR (x
);
2118 SCM labels
= SCM_CAR (clause
);
2119 if (SCM_EQ_P (labels
, scm_sym_else
))
2121 x
= SCM_CDR (clause
);
2122 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2125 while (!SCM_NULLP (labels
))
2127 SCM label
= SCM_CAR (labels
);
2128 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2130 x
= SCM_CDR (clause
);
2131 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2134 labels
= SCM_CDR (labels
);
2139 RETURN (SCM_UNSPECIFIED
);
2142 case SCM_BIT7 (SCM_IM_COND
):
2144 while (!SCM_NULLP (x
))
2146 SCM clause
= SCM_CAR (x
);
2147 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2149 x
= SCM_CDR (clause
);
2150 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2155 arg1
= EVALCAR (clause
, env
);
2156 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2158 x
= SCM_CDR (clause
);
2161 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2163 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2169 proc
= EVALCAR (proc
, env
);
2170 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2171 PREP_APPLY (proc
, scm_list_1 (arg1
));
2173 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2174 goto umwrongnumargs
;
2182 RETURN (SCM_UNSPECIFIED
);
2185 case SCM_BIT7 (SCM_IM_DO
):
2188 /* Compute the initialization values and the initial environment. */
2189 SCM init_forms
= SCM_CADR (x
);
2190 SCM init_values
= SCM_EOL
;
2191 while (!SCM_NULLP (init_forms
))
2193 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2194 init_forms
= SCM_CDR (init_forms
);
2196 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2200 SCM test_form
= SCM_CAR (x
);
2201 SCM body_forms
= SCM_CADR (x
);
2202 SCM step_forms
= SCM_CDDR (x
);
2204 SCM test_result
= EVALCAR (test_form
, env
);
2206 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2209 /* Evaluate body forms. */
2211 for (temp_forms
= body_forms
;
2212 !SCM_NULLP (temp_forms
);
2213 temp_forms
= SCM_CDR (temp_forms
))
2215 SCM form
= SCM_CAR (temp_forms
);
2216 /* Dirk:FIXME: We only need to eval forms, that may have a
2217 * side effect here. This is only true for forms that start
2218 * with a pair. All others are just constants. However,
2219 * since in the common case there is no constant expression
2220 * in a body of a do form, we just check for immediates here
2221 * and have SCM_CEVAL take care of other cases. In the long
2222 * run it would make sense to get rid of this test and have
2223 * the macro transformer of 'do' eliminate all forms that
2224 * have no sideeffect. */
2225 if (!SCM_IMP (form
))
2226 SCM_CEVAL (form
, env
);
2231 /* Evaluate the step expressions. */
2233 SCM step_values
= SCM_EOL
;
2234 for (temp_forms
= step_forms
;
2235 !SCM_NULLP (temp_forms
);
2236 temp_forms
= SCM_CDR (temp_forms
))
2238 SCM value
= EVALCAR (temp_forms
, env
);
2239 step_values
= scm_cons (value
, step_values
);
2241 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2246 test_result
= EVALCAR (test_form
, env
);
2251 RETURN (SCM_UNSPECIFIED
);
2252 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2253 goto nontoplevel_begin
;
2256 case SCM_BIT7 (SCM_IM_IF
):
2259 SCM test_result
= EVALCAR (x
, env
);
2260 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2266 RETURN (SCM_UNSPECIFIED
);
2269 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2273 case SCM_BIT7 (SCM_IM_LET
):
2276 SCM init_forms
= SCM_CADR (x
);
2277 SCM init_values
= SCM_EOL
;
2280 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2281 init_forms
= SCM_CDR (init_forms
);
2283 while (!SCM_NULLP (init_forms
));
2284 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2287 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2288 goto nontoplevel_begin
;
2291 case SCM_BIT7 (SCM_IM_LETREC
):
2293 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2296 SCM init_forms
= SCM_CAR (x
);
2297 SCM init_values
= SCM_EOL
;
2300 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2301 init_forms
= SCM_CDR (init_forms
);
2303 while (!SCM_NULLP (init_forms
));
2304 SCM_SETCDR (SCM_CAR (env
), init_values
);
2307 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2308 goto nontoplevel_begin
;
2311 case SCM_BIT7 (SCM_IM_LETSTAR
):
2314 SCM bindings
= SCM_CAR (x
);
2315 if (SCM_NULLP (bindings
))
2316 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2321 SCM name
= SCM_CAR (bindings
);
2322 SCM init
= SCM_CDR (bindings
);
2323 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2324 bindings
= SCM_CDR (init
);
2326 while (!SCM_NULLP (bindings
));
2330 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2331 goto nontoplevel_begin
;
2334 case SCM_BIT7 (SCM_IM_OR
):
2336 while (!SCM_NULLP (SCM_CDR (x
)))
2338 SCM val
= EVALCAR (x
, env
);
2339 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2344 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2348 case SCM_BIT7 (SCM_IM_LAMBDA
):
2349 RETURN (scm_closure (SCM_CDR (x
), env
));
2352 case SCM_BIT7 (SCM_IM_QUOTE
):
2353 RETURN (SCM_CADR (x
));
2356 case SCM_BIT7 (SCM_IM_SET_X
):
2360 SCM variable
= SCM_CAR (x
);
2361 if (SCM_ILOCP (variable
))
2362 location
= scm_ilookup (variable
, env
);
2363 else if (SCM_VARIABLEP (variable
))
2364 location
= SCM_VARIABLE_LOC (variable
);
2365 else /* (SCM_SYMBOLP (variable)) is known to be true */
2366 location
= scm_lookupcar (x
, env
, 1);
2368 *location
= EVALCAR (x
, env
);
2370 RETURN (SCM_UNSPECIFIED
);
2373 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2374 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2377 /* new syntactic forms go here. */
2378 case SCM_BIT7 (SCM_MAKISYM (0)):
2380 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2381 switch (SCM_ISYMNUM (proc
))
2385 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2387 proc
= EVALCAR (proc
, env
);
2388 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2389 if (SCM_CLOSUREP (proc
))
2391 PREP_APPLY (proc
, SCM_EOL
);
2392 arg1
= SCM_CDDR (x
);
2393 arg1
= EVALCAR (arg1
, env
);
2395 /* Go here to tail-call a closure. PROC is the closure
2396 and ARG1 is the list of arguments. Do not forget to
2399 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2401 debug
.info
->a
.args
= arg1
;
2403 if (scm_badargsp (formals
, arg1
))
2404 scm_wrong_num_args (proc
);
2406 /* Copy argument list */
2407 if (SCM_NULL_OR_NIL_P (arg1
))
2408 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2411 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2413 arg1
= SCM_CDR (arg1
);
2414 while (!SCM_NULL_OR_NIL_P (arg1
))
2416 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2417 SCM_SETCDR (tail
, new_tail
);
2419 arg1
= SCM_CDR (arg1
);
2421 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2424 x
= SCM_CLOSURE_BODY (proc
);
2425 goto nontoplevel_begin
;
2435 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2438 SCM val
= scm_make_continuation (&first
);
2446 proc
= scm_eval_car (proc
, env
);
2447 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2448 PREP_APPLY (proc
, scm_list_1 (arg1
));
2450 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2451 goto umwrongnumargs
;
2457 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2458 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2461 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2462 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2465 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2467 /* If not done yet, evaluate the operand forms. The result is a
2468 * list of arguments stored in arg1, which is used to perform the
2469 * function dispatch. */
2470 SCM operand_forms
= SCM_CADR (x
);
2471 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2472 if (SCM_ILOCP (operand_forms
))
2473 arg1
= *scm_ilookup (operand_forms
, env
);
2474 else if (SCM_VARIABLEP (operand_forms
))
2475 arg1
= SCM_VARIABLE_REF (operand_forms
);
2476 else if (!SCM_CONSP (operand_forms
))
2477 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2480 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2481 operand_forms
= SCM_CDR (operand_forms
);
2482 while (!SCM_NULLP (operand_forms
))
2484 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2485 SCM_SETCDR (tail
, new_tail
);
2487 operand_forms
= SCM_CDR (operand_forms
);
2492 /* The type dispatch code is duplicated below
2493 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2494 * cuts down execution time for type dispatch to 50%. */
2495 type_dispatch
: /* inputs: x, arg1 */
2496 /* Type dispatch means to determine from the types of the function
2497 * arguments (i. e. the 'signature' of the call), which method from
2498 * a generic function is to be called. This process of selecting
2499 * the right method takes some time. To speed it up, guile uses
2500 * caching: Together with the macro call to dispatch the signatures
2501 * of some previous calls to that generic function from the same
2502 * place are stored (in the code!) in a cache that we call the
2503 * 'method cache'. This is done since it is likely, that
2504 * consecutive calls to dispatch from that position in the code will
2505 * have the same signature. Thus, the type dispatch works as
2506 * follows: First, determine a hash value from the signature of the
2507 * actual arguments. Second, use this hash value as an index to
2508 * find that same signature in the method cache stored at this
2509 * position in the code. If found, you have also found the
2510 * corresponding method that belongs to that signature. If the
2511 * signature is not found in the method cache, you have to perform a
2512 * full search over all signatures stored with the generic
2515 unsigned long int specializers
;
2516 unsigned long int hash_value
;
2517 unsigned long int cache_end_pos
;
2518 unsigned long int mask
;
2522 SCM z
= SCM_CDDR (x
);
2523 SCM tmp
= SCM_CADR (z
);
2524 specializers
= SCM_INUM (SCM_CAR (z
));
2526 /* Compute a hash value for searching the method cache. There
2527 * are two variants for computing the hash value, a (rather)
2528 * complicated one, and a simple one. For the complicated one
2529 * explained below, tmp holds a number that is used in the
2531 if (SCM_INUMP (tmp
))
2533 /* Use the signature of the actual arguments to determine
2534 * the hash value. This is done as follows: Each class has
2535 * an array of random numbers, that are determined when the
2536 * class is created. The integer 'hashset' is an index into
2537 * that array of random numbers. Now, from all classes that
2538 * are part of the signature of the actual arguments, the
2539 * random numbers at index 'hashset' are taken and summed
2540 * up, giving the hash value. The value of 'hashset' is
2541 * stored at the call to dispatch. This allows to have
2542 * different 'formulas' for calculating the hash value at
2543 * different places where dispatch is called. This allows
2544 * to optimize the hash formula at every individual place
2545 * where dispatch is called, such that hopefully the hash
2546 * value that is computed will directly point to the right
2547 * method in the method cache. */
2548 unsigned long int hashset
= SCM_INUM (tmp
);
2549 unsigned long int counter
= specializers
+ 1;
2552 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2554 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2555 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2556 tmp_arg
= SCM_CDR (tmp_arg
);
2560 method_cache
= SCM_CADR (z
);
2561 mask
= SCM_INUM (SCM_CAR (z
));
2563 cache_end_pos
= hash_value
;
2567 /* This method of determining the hash value is much
2568 * simpler: Set the hash value to zero and just perform a
2569 * linear search through the method cache. */
2571 mask
= (unsigned long int) ((long) -1);
2573 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2578 /* Search the method cache for a method with a matching
2579 * signature. Start the search at position 'hash_value'. The
2580 * hashing implementation uses linear probing for conflict
2581 * resolution, that is, if the signature in question is not
2582 * found at the starting index in the hash table, the next table
2583 * entry is tried, and so on, until in the worst case the whole
2584 * cache has been searched, but still the signature has not been
2589 SCM args
= arg1
; /* list of arguments */
2590 z
= SCM_VELTS (method_cache
)[hash_value
];
2591 while (!SCM_NULLP (args
))
2593 /* More arguments than specifiers => CLASS != ENV */
2594 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2595 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2597 args
= SCM_CDR (args
);
2600 /* Fewer arguments than specifiers => CAR != ENV */
2601 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2604 hash_value
= (hash_value
+ 1) & mask
;
2605 } while (hash_value
!= cache_end_pos
);
2607 /* No appropriate method was found in the cache. */
2608 z
= scm_memoize_method (x
, arg1
);
2610 apply_cmethod
: /* inputs: z, arg1 */
2612 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2613 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2614 x
= SCM_CMETHOD_BODY (z
);
2615 goto nontoplevel_begin
;
2621 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2624 SCM instance
= EVALCAR (x
, env
);
2625 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2626 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2630 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2633 SCM instance
= EVALCAR (x
, env
);
2634 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2635 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2636 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2637 RETURN (SCM_UNSPECIFIED
);
2641 #if SCM_ENABLE_ELISP
2643 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2645 SCM test_form
= SCM_CDR (x
);
2646 x
= SCM_CDR (test_form
);
2647 while (!SCM_NULL_OR_NIL_P (x
))
2649 SCM test_result
= EVALCAR (test_form
, env
);
2650 if (!(SCM_FALSEP (test_result
)
2651 || SCM_NULL_OR_NIL_P (test_result
)))
2653 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2654 RETURN (test_result
);
2655 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2660 test_form
= SCM_CDR (x
);
2661 x
= SCM_CDR (test_form
);
2665 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2669 #endif /* SCM_ENABLE_ELISP */
2671 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2673 SCM vars
, exps
, vals
;
2676 vars
= SCM_CAAR (x
);
2677 exps
= SCM_CDAR (x
);
2681 while (SCM_NIMP (exps
))
2683 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2684 exps
= SCM_CDR (exps
);
2687 scm_swap_bindings (vars
, vals
);
2688 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2690 /* Ignore all but the last evaluation result. */
2691 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2693 if (SCM_CONSP (SCM_CAR (x
)))
2694 SCM_CEVAL (SCM_CAR (x
), env
);
2696 proc
= EVALCAR (x
, env
);
2698 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2699 scm_swap_bindings (vars
, vals
);
2705 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2708 x
= EVALCAR (proc
, env
);
2709 proc
= SCM_CDR (proc
);
2710 proc
= EVALCAR (proc
, env
);
2711 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2712 if (SCM_VALUESP (arg1
))
2713 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2715 arg1
= scm_list_1 (arg1
);
2716 if (SCM_CLOSUREP (proc
))
2718 PREP_APPLY (proc
, arg1
);
2721 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2732 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2733 case scm_tc7_vector
:
2737 case scm_tc7_byvect
:
2744 #if SCM_SIZEOF_LONG_LONG != 0
2745 case scm_tc7_llvect
:
2748 case scm_tc7_string
:
2750 case scm_tcs_closures
:
2754 case scm_tcs_struct
:
2757 case scm_tc7_variable
:
2758 RETURN (SCM_VARIABLE_REF(x
));
2760 case SCM_BIT7 (SCM_ILOC00
):
2761 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2762 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2765 case scm_tcs_cons_nimcar
:
2766 if (SCM_SYMBOLP (SCM_CAR (x
)))
2768 SCM orig_sym
= SCM_CAR (x
);
2770 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2771 if (location
== NULL
)
2773 /* we have lost the race, start again. */
2781 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2785 if (SCM_MACROP (proc
))
2787 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2789 handle_a_macro
: /* inputs: x, env, proc */
2791 /* Set a flag during macro expansion so that macro
2792 application frames can be deleted from the backtrace. */
2793 SCM_SET_MACROEXP (debug
);
2795 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2796 scm_cons (env
, scm_listofnull
));
2799 SCM_CLEAR_MACROEXP (debug
);
2801 switch (SCM_MACRO_TYPE (proc
))
2804 if (scm_ilength (arg1
) <= 0)
2805 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2807 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2810 SCM_SETCAR (x
, SCM_CAR (arg1
));
2811 SCM_SETCDR (x
, SCM_CDR (arg1
));
2815 /* Prevent memoizing of debug info expression. */
2816 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2821 SCM_SETCAR (x
, SCM_CAR (arg1
));
2822 SCM_SETCDR (x
, SCM_CDR (arg1
));
2824 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2826 #if SCM_ENABLE_DEPRECATED == 1
2831 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2843 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2844 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2847 if (SCM_CLOSUREP (proc
))
2849 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2850 SCM args
= SCM_CDR (x
);
2851 while (!SCM_NULLP (formals
))
2853 if (!SCM_CONSP (formals
))
2856 goto umwrongnumargs
;
2857 formals
= SCM_CDR (formals
);
2858 args
= SCM_CDR (args
);
2860 if (!SCM_NULLP (args
))
2861 goto umwrongnumargs
;
2863 else if (SCM_MACROP (proc
))
2864 goto handle_a_macro
;
2868 evapply
: /* inputs: x, proc */
2869 PREP_APPLY (proc
, SCM_EOL
);
2870 if (SCM_NULLP (SCM_CDR (x
))) {
2873 switch (SCM_TYP7 (proc
))
2874 { /* no arguments given */
2875 case scm_tc7_subr_0
:
2876 RETURN (SCM_SUBRF (proc
) ());
2877 case scm_tc7_subr_1o
:
2878 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2880 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2881 case scm_tc7_rpsubr
:
2882 RETURN (SCM_BOOL_T
);
2884 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2886 if (!SCM_SMOB_APPLICABLE_P (proc
))
2888 RETURN (SCM_SMOB_APPLY_0 (proc
));
2891 proc
= SCM_CCLO_SUBR (proc
);
2893 debug
.info
->a
.proc
= proc
;
2894 debug
.info
->a
.args
= scm_list_1 (arg1
);
2898 proc
= SCM_PROCEDURE (proc
);
2900 debug
.info
->a
.proc
= proc
;
2902 if (!SCM_CLOSUREP (proc
))
2904 if (scm_badformalsp (proc
, 0))
2905 goto umwrongnumargs
;
2906 case scm_tcs_closures
:
2907 x
= SCM_CLOSURE_BODY (proc
);
2908 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2911 goto nontoplevel_begin
;
2912 case scm_tcs_struct
:
2913 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2915 x
= SCM_ENTITY_PROCEDURE (proc
);
2919 else if (!SCM_I_OPERATORP (proc
))
2924 proc
= (SCM_I_ENTITYP (proc
)
2925 ? SCM_ENTITY_PROCEDURE (proc
)
2926 : SCM_OPERATOR_PROCEDURE (proc
));
2928 debug
.info
->a
.proc
= proc
;
2929 debug
.info
->a
.args
= scm_list_1 (arg1
);
2931 if (SCM_NIMP (proc
))
2936 case scm_tc7_subr_1
:
2937 case scm_tc7_subr_2
:
2938 case scm_tc7_subr_2o
:
2940 case scm_tc7_subr_3
:
2941 case scm_tc7_lsubr_2
:
2944 scm_wrong_num_args (proc
);
2946 /* handle macros here */
2951 /* must handle macros by here */
2954 arg1
= EVALCAR (x
, env
);
2956 scm_wrong_num_args (proc
);
2958 debug
.info
->a
.args
= scm_list_1 (arg1
);
2966 evap1
: /* inputs: proc, arg1 */
2967 switch (SCM_TYP7 (proc
))
2968 { /* have one argument in arg1 */
2969 case scm_tc7_subr_2o
:
2970 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2971 case scm_tc7_subr_1
:
2972 case scm_tc7_subr_1o
:
2973 RETURN (SCM_SUBRF (proc
) (arg1
));
2975 if (SCM_SUBRF (proc
))
2977 if (SCM_INUMP (arg1
))
2979 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2981 else if (SCM_REALP (arg1
))
2983 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2985 else if (SCM_BIGP (arg1
))
2987 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2989 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2990 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2992 proc
= SCM_SNAME (proc
);
2994 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2995 while ('c' != *--chrs
)
2997 SCM_ASSERT (SCM_CONSP (arg1
),
2998 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2999 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3003 case scm_tc7_rpsubr
:
3004 RETURN (SCM_BOOL_T
);
3006 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3009 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3011 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3014 if (!SCM_SMOB_APPLICABLE_P (proc
))
3016 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3020 proc
= SCM_CCLO_SUBR (proc
);
3022 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3023 debug
.info
->a
.proc
= proc
;
3027 proc
= SCM_PROCEDURE (proc
);
3029 debug
.info
->a
.proc
= proc
;
3031 if (!SCM_CLOSUREP (proc
))
3033 if (scm_badformalsp (proc
, 1))
3034 goto umwrongnumargs
;
3035 case scm_tcs_closures
:
3037 x
= SCM_CLOSURE_BODY (proc
);
3039 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3043 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3047 goto nontoplevel_begin
;
3048 case scm_tcs_struct
:
3049 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3051 x
= SCM_ENTITY_PROCEDURE (proc
);
3053 arg1
= debug
.info
->a
.args
;
3055 arg1
= scm_list_1 (arg1
);
3059 else if (!SCM_I_OPERATORP (proc
))
3065 proc
= (SCM_I_ENTITYP (proc
)
3066 ? SCM_ENTITY_PROCEDURE (proc
)
3067 : SCM_OPERATOR_PROCEDURE (proc
));
3069 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3070 debug
.info
->a
.proc
= proc
;
3072 if (SCM_NIMP (proc
))
3077 case scm_tc7_subr_2
:
3078 case scm_tc7_subr_0
:
3079 case scm_tc7_subr_3
:
3080 case scm_tc7_lsubr_2
:
3081 scm_wrong_num_args (proc
);
3087 arg2
= EVALCAR (x
, env
);
3089 scm_wrong_num_args (proc
);
3091 { /* have two or more arguments */
3093 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3096 if (SCM_NULLP (x
)) {
3099 switch (SCM_TYP7 (proc
))
3100 { /* have two arguments */
3101 case scm_tc7_subr_2
:
3102 case scm_tc7_subr_2o
:
3103 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3106 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3108 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3110 case scm_tc7_lsubr_2
:
3111 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3112 case scm_tc7_rpsubr
:
3114 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3116 if (!SCM_SMOB_APPLICABLE_P (proc
))
3118 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3122 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3123 scm_cons (proc
, debug
.info
->a
.args
),
3126 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3127 scm_cons2 (proc
, arg1
,
3134 case scm_tcs_struct
:
3135 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3137 x
= SCM_ENTITY_PROCEDURE (proc
);
3139 arg1
= debug
.info
->a
.args
;
3141 arg1
= scm_list_2 (arg1
, arg2
);
3145 else if (!SCM_I_OPERATORP (proc
))
3151 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3152 ? SCM_ENTITY_PROCEDURE (proc
)
3153 : SCM_OPERATOR_PROCEDURE (proc
),
3154 scm_cons (proc
, debug
.info
->a
.args
),
3157 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3158 ? SCM_ENTITY_PROCEDURE (proc
)
3159 : SCM_OPERATOR_PROCEDURE (proc
),
3160 scm_cons2 (proc
, arg1
,
3168 case scm_tc7_subr_0
:
3170 case scm_tc7_subr_1o
:
3171 case scm_tc7_subr_1
:
3172 case scm_tc7_subr_3
:
3173 scm_wrong_num_args (proc
);
3177 proc
= SCM_PROCEDURE (proc
);
3179 debug
.info
->a
.proc
= proc
;
3181 if (!SCM_CLOSUREP (proc
))
3183 if (scm_badformalsp (proc
, 2))
3184 goto umwrongnumargs
;
3185 case scm_tcs_closures
:
3188 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3192 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3193 scm_list_2 (arg1
, arg2
),
3196 x
= SCM_CLOSURE_BODY (proc
);
3197 goto nontoplevel_begin
;
3201 scm_wrong_num_args (proc
);
3203 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3204 deval_args (x
, env
, proc
,
3205 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3209 switch (SCM_TYP7 (proc
))
3210 { /* have 3 or more arguments */
3212 case scm_tc7_subr_3
:
3213 if (!SCM_NULLP (SCM_CDR (x
)))
3214 scm_wrong_num_args (proc
);
3216 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3217 SCM_CADDR (debug
.info
->a
.args
)));
3219 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3220 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3223 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3224 arg2
= SCM_CDR (arg2
);
3226 while (SCM_NIMP (arg2
));
3228 case scm_tc7_rpsubr
:
3229 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3230 RETURN (SCM_BOOL_F
);
3231 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3234 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3235 RETURN (SCM_BOOL_F
);
3236 arg2
= SCM_CAR (arg1
);
3237 arg1
= SCM_CDR (arg1
);
3239 while (SCM_NIMP (arg1
));
3240 RETURN (SCM_BOOL_T
);
3241 case scm_tc7_lsubr_2
:
3242 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3243 SCM_CDDR (debug
.info
->a
.args
)));
3245 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3247 if (!SCM_SMOB_APPLICABLE_P (proc
))
3249 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3250 SCM_CDDR (debug
.info
->a
.args
)));
3254 proc
= SCM_PROCEDURE (proc
);
3255 debug
.info
->a
.proc
= proc
;
3256 if (!SCM_CLOSUREP (proc
))
3258 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3259 goto umwrongnumargs
;
3260 case scm_tcs_closures
:
3261 SCM_SET_ARGSREADY (debug
);
3262 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3265 x
= SCM_CLOSURE_BODY (proc
);
3266 goto nontoplevel_begin
;
3268 case scm_tc7_subr_3
:
3269 if (!SCM_NULLP (SCM_CDR (x
)))
3270 scm_wrong_num_args (proc
);
3272 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3274 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3277 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3280 while (SCM_NIMP (x
));
3282 case scm_tc7_rpsubr
:
3283 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3284 RETURN (SCM_BOOL_F
);
3287 arg1
= EVALCAR (x
, env
);
3288 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3289 RETURN (SCM_BOOL_F
);
3293 while (SCM_NIMP (x
));
3294 RETURN (SCM_BOOL_T
);
3295 case scm_tc7_lsubr_2
:
3296 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3298 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3300 scm_eval_args (x
, env
, proc
))));
3302 if (!SCM_SMOB_APPLICABLE_P (proc
))
3304 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3305 scm_eval_args (x
, env
, proc
)));
3309 proc
= SCM_PROCEDURE (proc
);
3310 if (!SCM_CLOSUREP (proc
))
3313 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3314 if (SCM_NULLP (formals
)
3315 || (SCM_CONSP (formals
)
3316 && (SCM_NULLP (SCM_CDR (formals
))
3317 || (SCM_CONSP (SCM_CDR (formals
))
3318 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3319 goto umwrongnumargs
;
3321 case scm_tcs_closures
:
3323 SCM_SET_ARGSREADY (debug
);
3325 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3328 scm_eval_args (x
, env
, proc
)),
3330 x
= SCM_CLOSURE_BODY (proc
);
3331 goto nontoplevel_begin
;
3333 case scm_tcs_struct
:
3334 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3337 arg1
= debug
.info
->a
.args
;
3339 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3341 x
= SCM_ENTITY_PROCEDURE (proc
);
3344 else if (!SCM_I_OPERATORP (proc
))
3348 case scm_tc7_subr_2
:
3349 case scm_tc7_subr_1o
:
3350 case scm_tc7_subr_2o
:
3351 case scm_tc7_subr_0
:
3353 case scm_tc7_subr_1
:
3354 scm_wrong_num_args (proc
);
3362 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3363 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3365 SCM_CLEAR_TRACED_FRAME (debug
);
3366 if (SCM_CHEAPTRAPS_P
)
3367 arg1
= scm_make_debugobj (&debug
);
3371 SCM val
= scm_make_continuation (&first
);
3382 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3386 scm_last_debug_frame
= debug
.prev
;
3392 /* SECTION: This code is compiled once.
3399 /* Simple procedure calls
3403 scm_call_0 (SCM proc
)
3405 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3409 scm_call_1 (SCM proc
, SCM arg1
)
3411 return scm_apply (proc
, arg1
, scm_listofnull
);
3415 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3417 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3421 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3423 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3427 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3429 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3430 scm_cons (arg4
, scm_listofnull
)));
3433 /* Simple procedure applies
3437 scm_apply_0 (SCM proc
, SCM args
)
3439 return scm_apply (proc
, args
, SCM_EOL
);
3443 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3445 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3449 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3451 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3455 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3457 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3461 /* This code processes the arguments to apply:
3463 (apply PROC ARG1 ... ARGS)
3465 Given a list (ARG1 ... ARGS), this function conses the ARG1
3466 ... arguments onto the front of ARGS, and returns the resulting
3467 list. Note that ARGS is a list; thus, the argument to this
3468 function is a list whose last element is a list.
3470 Apply calls this function, and applies PROC to the elements of the
3471 result. apply:nconc2last takes care of building the list of
3472 arguments, given (ARG1 ... ARGS).
3474 Rather than do new consing, apply:nconc2last destroys its argument.
3475 On that topic, this code came into my care with the following
3476 beautifully cryptic comment on that topic: "This will only screw
3477 you if you do (scm_apply scm_apply '( ... ))" If you know what
3478 they're referring to, send me a patch to this comment. */
3480 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3482 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3483 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3484 "@var{args}, and returns the resulting list. Note that\n"
3485 "@var{args} is a list; thus, the argument to this function is\n"
3486 "a list whose last element is a list.\n"
3487 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3488 "destroys its argument, so use with care.")
3489 #define FUNC_NAME s_scm_nconc2last
3492 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3494 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3495 SCM_NULL_OR_NIL_P, but not
3496 needed in 99.99% of cases,
3497 and it could seriously hurt
3498 performance. - Neil */
3499 lloc
= SCM_CDRLOC (*lloc
);
3500 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3501 *lloc
= SCM_CAR (*lloc
);
3509 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3510 * It is compiled twice.
3515 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3521 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3526 /* Apply a function to a list of arguments.
3528 This function is exported to the Scheme level as taking two
3529 required arguments and a tail argument, as if it were:
3530 (lambda (proc arg1 . args) ...)
3531 Thus, if you just have a list of arguments to pass to a procedure,
3532 pass the list as ARG1, and '() for ARGS. If you have some fixed
3533 args, pass the first as ARG1, then cons any remaining fixed args
3534 onto the front of your argument list, and pass that as ARGS. */
3537 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3540 scm_t_debug_frame debug
;
3541 scm_t_debug_info debug_vect_body
;
3542 debug
.prev
= scm_last_debug_frame
;
3543 debug
.status
= SCM_APPLYFRAME
;
3544 debug
.vect
= &debug_vect_body
;
3545 debug
.vect
[0].a
.proc
= proc
;
3546 debug
.vect
[0].a
.args
= SCM_EOL
;
3547 scm_last_debug_frame
= &debug
;
3550 return scm_dapply (proc
, arg1
, args
);
3553 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3555 /* If ARGS is the empty list, then we're calling apply with only two
3556 arguments --- ARG1 is the list of arguments for PROC. Whatever
3557 the case, futz with things so that ARG1 is the first argument to
3558 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3561 Setting the debug apply frame args this way is pretty messy.
3562 Perhaps we should store arg1 and args directly in the frame as
3563 received, and let scm_frame_arguments unpack them, because that's
3564 a relatively rare operation. This works for now; if the Guile
3565 developer archives are still around, see Mikael's post of
3567 if (SCM_NULLP (args
))
3569 if (SCM_NULLP (arg1
))
3571 arg1
= SCM_UNDEFINED
;
3573 debug
.vect
[0].a
.args
= SCM_EOL
;
3579 debug
.vect
[0].a
.args
= arg1
;
3581 args
= SCM_CDR (arg1
);
3582 arg1
= SCM_CAR (arg1
);
3587 args
= scm_nconc2last (args
);
3589 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3593 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3596 if (SCM_CHEAPTRAPS_P
)
3597 tmp
= scm_make_debugobj (&debug
);
3602 tmp
= scm_make_continuation (&first
);
3607 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3614 switch (SCM_TYP7 (proc
))
3616 case scm_tc7_subr_2o
:
3617 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3618 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3619 case scm_tc7_subr_2
:
3620 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3621 scm_wrong_num_args (proc
);
3622 args
= SCM_CAR (args
);
3623 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3624 case scm_tc7_subr_0
:
3625 if (!SCM_UNBNDP (arg1
))
3626 scm_wrong_num_args (proc
);
3628 RETURN (SCM_SUBRF (proc
) ());
3629 case scm_tc7_subr_1
:
3630 if (SCM_UNBNDP (arg1
))
3631 scm_wrong_num_args (proc
);
3632 case scm_tc7_subr_1o
:
3633 if (!SCM_NULLP (args
))
3634 scm_wrong_num_args (proc
);
3636 RETURN (SCM_SUBRF (proc
) (arg1
));
3638 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3639 scm_wrong_num_args (proc
);
3640 if (SCM_SUBRF (proc
))
3642 if (SCM_INUMP (arg1
))
3644 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3646 else if (SCM_REALP (arg1
))
3648 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3650 else if (SCM_BIGP (arg1
))
3651 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3652 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3653 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3655 proc
= SCM_SNAME (proc
);
3657 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3658 while ('c' != *--chrs
)
3660 SCM_ASSERT (SCM_CONSP (arg1
),
3661 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3662 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3666 case scm_tc7_subr_3
:
3667 if (SCM_NULLP (args
)
3668 || SCM_NULLP (SCM_CDR (args
))
3669 || !SCM_NULLP (SCM_CDDR (args
)))
3670 scm_wrong_num_args (proc
);
3672 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3675 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3677 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3679 case scm_tc7_lsubr_2
:
3680 if (!SCM_CONSP (args
))
3681 scm_wrong_num_args (proc
);
3683 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3685 if (SCM_NULLP (args
))
3686 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3687 while (SCM_NIMP (args
))
3689 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3690 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3691 args
= SCM_CDR (args
);
3694 case scm_tc7_rpsubr
:
3695 if (SCM_NULLP (args
))
3696 RETURN (SCM_BOOL_T
);
3697 while (SCM_NIMP (args
))
3699 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3700 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3701 RETURN (SCM_BOOL_F
);
3702 arg1
= SCM_CAR (args
);
3703 args
= SCM_CDR (args
);
3705 RETURN (SCM_BOOL_T
);
3706 case scm_tcs_closures
:
3708 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3710 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3712 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3713 scm_wrong_num_args (proc
);
3715 /* Copy argument list */
3720 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3721 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
3723 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
3726 SCM_SETCDR (tl
, arg1
);
3729 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3732 proc
= SCM_CLOSURE_BODY (proc
);
3734 arg1
= SCM_CDR (proc
);
3735 while (!SCM_NULLP (arg1
))
3737 if (SCM_IMP (SCM_CAR (proc
)))
3739 if (SCM_ISYMP (SCM_CAR (proc
)))
3741 scm_rec_mutex_lock (&source_mutex
);
3742 /* check for race condition */
3743 if (SCM_ISYMP (SCM_CAR (proc
)))
3744 proc
= scm_m_expand_body (proc
, args
);
3745 scm_rec_mutex_unlock (&source_mutex
);
3749 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3752 SCM_CEVAL (SCM_CAR (proc
), args
);
3754 arg1
= SCM_CDR (proc
);
3756 RETURN (EVALCAR (proc
, args
));
3758 if (!SCM_SMOB_APPLICABLE_P (proc
))
3760 if (SCM_UNBNDP (arg1
))
3761 RETURN (SCM_SMOB_APPLY_0 (proc
));
3762 else if (SCM_NULLP (args
))
3763 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3764 else if (SCM_NULLP (SCM_CDR (args
)))
3765 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3767 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3770 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3772 proc
= SCM_CCLO_SUBR (proc
);
3773 debug
.vect
[0].a
.proc
= proc
;
3774 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3776 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3778 proc
= SCM_CCLO_SUBR (proc
);
3782 proc
= SCM_PROCEDURE (proc
);
3784 debug
.vect
[0].a
.proc
= proc
;
3787 case scm_tcs_struct
:
3788 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3791 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3793 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3795 RETURN (scm_apply_generic (proc
, args
));
3797 else if (!SCM_I_OPERATORP (proc
))
3803 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3805 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3808 proc
= (SCM_I_ENTITYP (proc
)
3809 ? SCM_ENTITY_PROCEDURE (proc
)
3810 : SCM_OPERATOR_PROCEDURE (proc
));
3812 debug
.vect
[0].a
.proc
= proc
;
3813 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3815 if (SCM_NIMP (proc
))
3822 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3826 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3827 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3829 SCM_CLEAR_TRACED_FRAME (debug
);
3830 if (SCM_CHEAPTRAPS_P
)
3831 arg1
= scm_make_debugobj (&debug
);
3835 SCM val
= scm_make_continuation (&first
);
3846 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3850 scm_last_debug_frame
= debug
.prev
;
3856 /* SECTION: The rest of this file is only read once.
3863 * Trampolines make it possible to move procedure application dispatch
3864 * outside inner loops. The motivation was clean implementation of
3865 * efficient replacements of R5RS primitives in SRFI-1.
3867 * The semantics is clear: scm_trampoline_N returns an optimized
3868 * version of scm_call_N (or NULL if the procedure isn't applicable
3871 * Applying the optimization to map and for-each increased efficiency
3872 * noticeably. For example, (map abs ls) is now 8 times faster than
3877 call_subr0_0 (SCM proc
)
3879 return SCM_SUBRF (proc
) ();
3883 call_subr1o_0 (SCM proc
)
3885 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3889 call_lsubr_0 (SCM proc
)
3891 return SCM_SUBRF (proc
) (SCM_EOL
);
3895 scm_i_call_closure_0 (SCM proc
)
3897 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3900 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3905 scm_trampoline_0 (SCM proc
)
3911 switch (SCM_TYP7 (proc
))
3913 case scm_tc7_subr_0
:
3914 return call_subr0_0
;
3915 case scm_tc7_subr_1o
:
3916 return call_subr1o_0
;
3918 return call_lsubr_0
;
3919 case scm_tcs_closures
:
3921 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3922 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3923 return scm_i_call_closure_0
;
3927 case scm_tcs_struct
:
3928 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3929 return scm_call_generic_0
;
3930 else if (!SCM_I_OPERATORP (proc
))
3934 if (SCM_SMOB_APPLICABLE_P (proc
))
3935 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3939 case scm_tc7_rpsubr
:
3944 return NULL
; /* not applicable on one arg */
3949 call_subr1_1 (SCM proc
, SCM arg1
)
3951 return SCM_SUBRF (proc
) (arg1
);
3955 call_subr2o_1 (SCM proc
, SCM arg1
)
3957 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3961 call_lsubr_1 (SCM proc
, SCM arg1
)
3963 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3967 call_dsubr_1 (SCM proc
, SCM arg1
)
3969 if (SCM_INUMP (arg1
))
3971 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3973 else if (SCM_REALP (arg1
))
3975 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3977 else if (SCM_BIGP (arg1
))
3978 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3979 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3980 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3984 call_cxr_1 (SCM proc
, SCM arg1
)
3986 proc
= SCM_SNAME (proc
);
3988 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3989 while ('c' != *--chrs
)
3991 SCM_ASSERT (SCM_CONSP (arg1
),
3992 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3993 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4000 call_closure_1 (SCM proc
, SCM arg1
)
4002 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4005 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4010 scm_trampoline_1 (SCM proc
)
4016 switch (SCM_TYP7 (proc
))
4018 case scm_tc7_subr_1
:
4019 case scm_tc7_subr_1o
:
4020 return call_subr1_1
;
4021 case scm_tc7_subr_2o
:
4022 return call_subr2o_1
;
4024 return call_lsubr_1
;
4026 if (SCM_SUBRF (proc
))
4027 return call_dsubr_1
;
4030 case scm_tcs_closures
:
4032 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4033 if (!SCM_NULLP (formals
)
4034 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4035 return call_closure_1
;
4039 case scm_tcs_struct
:
4040 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4041 return scm_call_generic_1
;
4042 else if (!SCM_I_OPERATORP (proc
))
4046 if (SCM_SMOB_APPLICABLE_P (proc
))
4047 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4051 case scm_tc7_rpsubr
:
4056 return NULL
; /* not applicable on one arg */
4061 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4063 return SCM_SUBRF (proc
) (arg1
, arg2
);
4067 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4069 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4073 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4075 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4079 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4081 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4082 scm_list_2 (arg1
, arg2
),
4084 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4089 scm_trampoline_2 (SCM proc
)
4095 switch (SCM_TYP7 (proc
))
4097 case scm_tc7_subr_2
:
4098 case scm_tc7_subr_2o
:
4099 case scm_tc7_rpsubr
:
4101 return call_subr2_2
;
4102 case scm_tc7_lsubr_2
:
4103 return call_lsubr2_2
;
4105 return call_lsubr_2
;
4106 case scm_tcs_closures
:
4108 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4109 if (!SCM_NULLP (formals
)
4110 && (!SCM_CONSP (formals
)
4111 || (!SCM_NULLP (SCM_CDR (formals
))
4112 && (!SCM_CONSP (SCM_CDR (formals
))
4113 || !SCM_CONSP (SCM_CDDR (formals
))))))
4114 return call_closure_2
;
4118 case scm_tcs_struct
:
4119 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4120 return scm_call_generic_2
;
4121 else if (!SCM_I_OPERATORP (proc
))
4125 if (SCM_SMOB_APPLICABLE_P (proc
))
4126 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4133 return NULL
; /* not applicable on two args */
4137 /* Typechecking for multi-argument MAP and FOR-EACH.
4139 Verify that each element of the vector ARGV, except for the first,
4140 is a proper list whose length is LEN. Attribute errors to WHO,
4141 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4143 check_map_args (SCM argv
,
4150 SCM
const *ve
= SCM_VELTS (argv
);
4153 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4155 long elt_len
= scm_ilength (ve
[i
]);
4160 scm_apply_generic (gf
, scm_cons (proc
, args
));
4162 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4166 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4169 scm_remember_upto_here_1 (argv
);
4173 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4175 /* Note: Currently, scm_map applies PROC to the argument list(s)
4176 sequentially, starting with the first element(s). This is used in
4177 evalext.c where the Scheme procedure `map-in-order', which guarantees
4178 sequential behaviour, is implemented using scm_map. If the
4179 behaviour changes, we need to update `map-in-order'.
4183 scm_map (SCM proc
, SCM arg1
, SCM args
)
4184 #define FUNC_NAME s_map
4189 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4191 len
= scm_ilength (arg1
);
4192 SCM_GASSERTn (len
>= 0,
4193 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4194 SCM_VALIDATE_REST_ARGUMENT (args
);
4195 if (SCM_NULLP (args
))
4197 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4198 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4199 while (SCM_NIMP (arg1
))
4201 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4202 pres
= SCM_CDRLOC (*pres
);
4203 arg1
= SCM_CDR (arg1
);
4207 if (SCM_NULLP (SCM_CDR (args
)))
4209 SCM arg2
= SCM_CAR (args
);
4210 int len2
= scm_ilength (arg2
);
4211 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4213 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4214 SCM_GASSERTn (len2
>= 0,
4215 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4217 SCM_OUT_OF_RANGE (3, arg2
);
4218 while (SCM_NIMP (arg1
))
4220 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4221 pres
= SCM_CDRLOC (*pres
);
4222 arg1
= SCM_CDR (arg1
);
4223 arg2
= SCM_CDR (arg2
);
4227 arg1
= scm_cons (arg1
, args
);
4228 args
= scm_vector (arg1
);
4229 ve
= SCM_VELTS (args
);
4230 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4234 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4236 if (SCM_IMP (ve
[i
]))
4238 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4239 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4241 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4242 pres
= SCM_CDRLOC (*pres
);
4248 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4251 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4252 #define FUNC_NAME s_for_each
4254 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4256 len
= scm_ilength (arg1
);
4257 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4258 SCM_ARG2
, s_for_each
);
4259 SCM_VALIDATE_REST_ARGUMENT (args
);
4260 if (SCM_NULLP (args
))
4262 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4263 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4264 while (SCM_NIMP (arg1
))
4266 call (proc
, SCM_CAR (arg1
));
4267 arg1
= SCM_CDR (arg1
);
4269 return SCM_UNSPECIFIED
;
4271 if (SCM_NULLP (SCM_CDR (args
)))
4273 SCM arg2
= SCM_CAR (args
);
4274 int len2
= scm_ilength (arg2
);
4275 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4276 SCM_GASSERTn (call
, g_for_each
,
4277 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4278 SCM_GASSERTn (len2
>= 0, g_for_each
,
4279 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4281 SCM_OUT_OF_RANGE (3, arg2
);
4282 while (SCM_NIMP (arg1
))
4284 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4285 arg1
= SCM_CDR (arg1
);
4286 arg2
= SCM_CDR (arg2
);
4288 return SCM_UNSPECIFIED
;
4290 arg1
= scm_cons (arg1
, args
);
4291 args
= scm_vector (arg1
);
4292 ve
= SCM_VELTS (args
);
4293 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4297 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4299 if (SCM_IMP (ve
[i
]))
4300 return SCM_UNSPECIFIED
;
4301 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4302 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4304 scm_apply (proc
, arg1
, SCM_EOL
);
4311 scm_closure (SCM code
, SCM env
)
4314 SCM closcar
= scm_cons (code
, SCM_EOL
);
4315 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4316 scm_remember_upto_here (closcar
);
4321 scm_t_bits scm_tc16_promise
;
4324 scm_makprom (SCM code
)
4326 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4328 scm_make_rec_mutex ());
4332 promise_free (SCM promise
)
4334 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4339 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4341 int writingp
= SCM_WRITINGP (pstate
);
4342 scm_puts ("#<promise ", port
);
4343 SCM_SET_WRITINGP (pstate
, 1);
4344 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4345 SCM_SET_WRITINGP (pstate
, writingp
);
4346 scm_putc ('>', port
);
4350 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4352 "If the promise @var{x} has not been computed yet, compute and\n"
4353 "return @var{x}, otherwise just return the previously computed\n"
4355 #define FUNC_NAME s_scm_force
4357 SCM_VALIDATE_SMOB (1, promise
, promise
);
4358 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4359 if (!SCM_PROMISE_COMPUTED_P (promise
))
4361 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4362 if (!SCM_PROMISE_COMPUTED_P (promise
))
4364 SCM_SET_PROMISE_DATA (promise
, ans
);
4365 SCM_SET_PROMISE_COMPUTED (promise
);
4368 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4369 return SCM_PROMISE_DATA (promise
);
4374 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4376 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4377 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4378 #define FUNC_NAME s_scm_promise_p
4380 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4385 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4386 (SCM xorig
, SCM x
, SCM y
),
4387 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4388 "Any source properties associated with @var{xorig} are also associated\n"
4389 "with the new pair.")
4390 #define FUNC_NAME s_scm_cons_source
4393 z
= scm_cons (x
, y
);
4394 /* Copy source properties possibly associated with xorig. */
4395 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4397 scm_whash_insert (scm_source_whash
, z
, p
);
4403 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4405 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4406 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4407 "contents of both pairs and vectors (since both cons cells and vector\n"
4408 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4409 "any other object.")
4410 #define FUNC_NAME s_scm_copy_tree
4415 if (SCM_VECTORP (obj
))
4417 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4418 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4420 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4423 if (!SCM_CONSP (obj
))
4425 ans
= tl
= scm_cons_source (obj
,
4426 scm_copy_tree (SCM_CAR (obj
)),
4428 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4430 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4434 SCM_SETCDR (tl
, obj
);
4440 /* We have three levels of EVAL here:
4442 - scm_i_eval (exp, env)
4444 evaluates EXP in environment ENV. ENV is a lexical environment
4445 structure as used by the actual tree code evaluator. When ENV is
4446 a top-level environment, then changes to the current module are
4447 tracked by updating ENV so that it continues to be in sync with
4450 - scm_primitive_eval (exp)
4452 evaluates EXP in the top-level environment as determined by the
4453 current module. This is done by constructing a suitable
4454 environment and calling scm_i_eval. Thus, changes to the
4455 top-level module are tracked normally.
4457 - scm_eval (exp, mod)
4459 evaluates EXP while MOD is the current module. This is done by
4460 setting the current module to MOD, invoking scm_primitive_eval on
4461 EXP, and then restoring the current module to the value it had
4462 previously. That is, while EXP is evaluated, changes to the
4463 current module are tracked, but these changes do not persist when
4466 For each level of evals, there are two variants, distinguished by a
4467 _x suffix: the ordinary variant does not modify EXP while the _x
4468 variant can destructively modify EXP into something completely
4469 unintelligible. A Scheme data structure passed as EXP to one of the
4470 _x variants should not ever be used again for anything. So when in
4471 doubt, use the ordinary variant.
4476 scm_i_eval_x (SCM exp
, SCM env
)
4478 return SCM_XEVAL (exp
, env
);
4482 scm_i_eval (SCM exp
, SCM env
)
4484 exp
= scm_copy_tree (exp
);
4485 return SCM_XEVAL (exp
, env
);
4489 scm_primitive_eval_x (SCM exp
)
4492 SCM transformer
= scm_current_module_transformer ();
4493 if (SCM_NIMP (transformer
))
4494 exp
= scm_call_1 (transformer
, exp
);
4495 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4496 return scm_i_eval_x (exp
, env
);
4499 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4501 "Evaluate @var{exp} in the top-level environment specified by\n"
4502 "the current module.")
4503 #define FUNC_NAME s_scm_primitive_eval
4506 SCM transformer
= scm_current_module_transformer ();
4507 if (SCM_NIMP (transformer
))
4508 exp
= scm_call_1 (transformer
, exp
);
4509 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4510 return scm_i_eval (exp
, env
);
4514 /* Eval does not take the second arg optionally. This is intentional
4515 * in order to be R5RS compatible, and to prepare for the new module
4516 * system, where we would like to make the choice of evaluation
4517 * environment explicit. */
4520 change_environment (void *data
)
4522 SCM pair
= SCM_PACK (data
);
4523 SCM new_module
= SCM_CAR (pair
);
4524 SCM old_module
= scm_current_module ();
4525 SCM_SETCDR (pair
, old_module
);
4526 scm_set_current_module (new_module
);
4531 restore_environment (void *data
)
4533 SCM pair
= SCM_PACK (data
);
4534 SCM old_module
= SCM_CDR (pair
);
4535 SCM new_module
= scm_current_module ();
4536 SCM_SETCAR (pair
, new_module
);
4537 scm_set_current_module (old_module
);
4541 inner_eval_x (void *data
)
4543 return scm_primitive_eval_x (SCM_PACK(data
));
4547 scm_eval_x (SCM exp
, SCM module
)
4548 #define FUNC_NAME "eval!"
4550 SCM_VALIDATE_MODULE (2, module
);
4552 return scm_internal_dynamic_wind
4553 (change_environment
, inner_eval_x
, restore_environment
,
4554 (void *) SCM_UNPACK (exp
),
4555 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4560 inner_eval (void *data
)
4562 return scm_primitive_eval (SCM_PACK(data
));
4565 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4566 (SCM exp
, SCM module
),
4567 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4568 "in the top-level environment specified by @var{module}.\n"
4569 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4570 "@var{module} is made the current module. The current module\n"
4571 "is reset to its previous value when @var{eval} returns.")
4572 #define FUNC_NAME s_scm_eval
4574 SCM_VALIDATE_MODULE (2, module
);
4576 return scm_internal_dynamic_wind
4577 (change_environment
, inner_eval
, restore_environment
,
4578 (void *) SCM_UNPACK (exp
),
4579 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4584 /* At this point, scm_deval and scm_dapply are generated.
4594 scm_init_opts (scm_evaluator_traps
,
4595 scm_evaluator_trap_table
,
4596 SCM_N_EVALUATOR_TRAPS
);
4597 scm_init_opts (scm_eval_options_interface
,
4599 SCM_N_EVAL_OPTIONS
);
4601 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4602 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4603 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4604 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4606 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4607 SCM_SETCDR (undefineds
, undefineds
);
4608 scm_permanent_object (undefineds
);
4610 scm_listofnull
= scm_list_1 (SCM_EOL
);
4612 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4613 scm_permanent_object (f_apply
);
4615 #include "libguile/eval.x"
4617 scm_add_feature ("delay");