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 #define EXTEND_ENV SCM_EXTEND_ENV
135 SCM_REC_MUTEX (source_mutex
);
138 scm_ilookup (SCM iloc
, SCM env
)
140 register long ir
= SCM_IFRAME (iloc
);
141 register SCM er
= env
;
142 for (; 0 != ir
; --ir
)
145 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
147 if (SCM_ICDRP (iloc
))
148 return SCM_CDRLOC (er
);
149 return SCM_CARLOC (SCM_CDR (er
));
152 /* The Lookup Car Race
155 Memoization of variables and special forms is done while executing
156 the code for the first time. As long as there is only one thread
157 everything is fine, but as soon as two threads execute the same
158 code concurrently `for the first time' they can come into conflict.
160 This memoization includes rewriting variable references into more
161 efficient forms and expanding macros. Furthermore, macro expansion
162 includes `compiling' special forms like `let', `cond', etc. into
163 tree-code instructions.
165 There shouldn't normally be a problem with memoizing local and
166 global variable references (into ilocs and variables), because all
167 threads will mutate the code in *exactly* the same way and (if I
168 read the C code correctly) it is not possible to observe a half-way
169 mutated cons cell. The lookup procedure can handle this
170 transparently without any critical sections.
172 It is different with macro expansion, because macro expansion
173 happens outside of the lookup procedure and can't be
174 undone. Therefore the lookup procedure can't cope with it. It has
175 to indicate failure when it detects a lost race and hope that the
176 caller can handle it. Luckily, it turns out that this is the case.
178 An example to illustrate this: Suppose that the following form will
179 be memoized concurrently by two threads
183 Let's first examine the lookup of X in the body. The first thread
184 decides that it has to find the symbol "x" in the environment and
185 starts to scan it. Then the other thread takes over and actually
186 overtakes the first. It looks up "x" and substitutes an
187 appropriate iloc for it. Now the first thread continues and
188 completes its lookup. It comes to exactly the same conclusions as
189 the second one and could - without much ado - just overwrite the
190 iloc with the same iloc.
192 But let's see what will happen when the race occurs while looking
193 up the symbol "let" at the start of the form. It could happen that
194 the second thread interrupts the lookup of the first thread and not
195 only substitutes a variable for it but goes right ahead and
196 replaces it with the compiled form (#@let* (x 12) x). Now, when
197 the first thread completes its lookup, it would replace the #@let*
198 with a variable containing the "let" binding, effectively reverting
199 the form to (let (x 12) x). This is wrong. It has to detect that
200 it has lost the race and the evaluator has to reconsider the
201 changed form completely.
203 This race condition could be resolved with some kind of traffic
204 light (like mutexes) around scm_lookupcar, but I think that it is
205 best to avoid them in this case. They would serialize memoization
206 completely and because lookup involves calling arbitrary Scheme
207 code (via the lookup-thunk), threads could be blocked for an
208 arbitrary amount of time or even deadlock. But with the current
209 solution a lot of unnecessary work is potentially done. */
211 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
212 return NULL to indicate a failed lookup due to some race conditions
213 between threads. This only happens when VLOC is the first cell of
214 a special form that will eventually be memoized (like `let', etc.)
215 In that case the whole lookup is bogus and the caller has to
216 reconsider the complete special form.
218 SCM_LOOKUPCAR is still there, of course. It just calls
219 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
220 should only be called when it is known that VLOC is not the first
221 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
222 for NULL. I think I've found the only places where this
225 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
228 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
231 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
232 register SCM iloc
= SCM_ILOC00
;
233 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
235 if (!SCM_CONSP (SCM_CAR (env
)))
237 al
= SCM_CARLOC (env
);
238 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
242 if (SCM_EQ_P (fl
, var
))
244 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
246 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
247 return SCM_CDRLOC (*al
);
252 al
= SCM_CDRLOC (*al
);
253 if (SCM_EQ_P (SCM_CAR (fl
), var
))
255 if (SCM_UNBNDP (SCM_CAR (*al
)))
260 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
262 SCM_SETCAR (vloc
, iloc
);
263 return SCM_CARLOC (*al
);
265 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
267 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
270 SCM top_thunk
, real_var
;
273 top_thunk
= SCM_CAR (env
); /* env now refers to a
274 top level env thunk */
278 top_thunk
= SCM_BOOL_F
;
279 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
280 if (SCM_FALSEP (real_var
))
283 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
289 scm_error (scm_unbound_variable_key
, NULL
,
290 "Unbound variable: ~S",
291 scm_list_1 (var
), SCM_BOOL_F
);
293 scm_misc_error (NULL
, "Damaged environment: ~S",
298 /* A variable could not be found, but we shall
299 not throw an error. */
300 static SCM undef_object
= SCM_UNDEFINED
;
301 return &undef_object
;
305 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
307 /* Some other thread has changed the very cell we are working
308 on. In effect, it must have done our job or messed it up
311 var
= SCM_CAR (vloc
);
312 if (SCM_VARIABLEP (var
))
313 return SCM_VARIABLE_LOC (var
);
314 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
315 return scm_ilookup (var
, genv
);
316 /* We can't cope with anything else than variables and ilocs. When
317 a special form has been memoized (i.e. `let' into `#@let') we
318 return NULL and expect the calling function to do the right
319 thing. For the evaluator, this means going back and redoing
320 the dispatch on the car of the form. */
324 SCM_SETCAR (vloc
, real_var
);
325 return SCM_VARIABLE_LOC (real_var
);
330 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
332 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
338 #define unmemocar scm_unmemocar
340 SCM_SYMBOL (sym_three_question_marks
, "???");
343 scm_unmemocar (SCM form
, SCM env
)
345 if (!SCM_CONSP (form
))
349 SCM c
= SCM_CAR (form
);
350 if (SCM_VARIABLEP (c
))
352 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
353 if (SCM_FALSEP (sym
))
354 sym
= sym_three_question_marks
;
355 SCM_SETCAR (form
, sym
);
357 else if (SCM_ILOCP (c
))
359 unsigned long int ir
;
361 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
363 env
= SCM_CAAR (env
);
364 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
366 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
374 scm_eval_car (SCM pair
, SCM env
)
376 return SCM_XEVALCAR (pair
, env
);
381 * The following rewrite expressions and
382 * some memoized forms have different syntax
385 const char scm_s_expression
[] = "missing or extra expression";
386 const char scm_s_test
[] = "bad test";
387 const char scm_s_body
[] = "bad body";
388 const char scm_s_bindings
[] = "bad bindings";
389 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
390 const char scm_s_variable
[] = "bad variable";
391 const char scm_s_clauses
[] = "bad or missing clauses";
392 const char scm_s_formals
[] = "bad formals";
393 const char scm_s_duplicate_formals
[] = "duplicate formals";
394 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
396 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
397 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
398 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
399 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
400 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
402 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
403 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
404 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
405 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
408 /* Check that the body denoted by XORIG is valid and rewrite it into
409 its internal form. The internal form of a body is just the body
410 itself, but prefixed with an ISYM that denotes to what kind of
411 outer construct this body belongs. A lambda body starts with
412 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
413 etc. The one exception is a body that belongs to a letrec that has
414 been formed by rewriting internal defines: it starts with
417 /* XXX - Besides controlling the rewriting of internal defines, the
418 additional ISYM could be used for improved error messages.
419 This is not done yet. */
422 scm_m_body (SCM op
, SCM xorig
, const char *what
)
424 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
426 /* Don't add another ISYM if one is present already. */
427 if (SCM_ISYMP (SCM_CAR (xorig
)))
430 /* Retain possible doc string. */
431 if (!SCM_CONSP (SCM_CAR (xorig
)))
433 if (!SCM_NULLP (SCM_CDR (xorig
)))
434 return scm_cons (SCM_CAR (xorig
),
435 scm_m_body (op
, SCM_CDR (xorig
), what
));
439 return scm_cons (op
, xorig
);
443 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
444 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
447 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
449 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
450 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
454 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
455 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
458 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
460 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
461 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
465 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
466 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
469 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
471 long len
= scm_ilength (SCM_CDR (xorig
));
472 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
473 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
477 /* Will go into the RnRS module when Guile is factorized.
478 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
479 const char scm_s_set_x
[] = "set!";
480 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
483 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
485 SCM x
= SCM_CDR (xorig
);
486 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
487 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
488 return scm_cons (SCM_IM_SET_X
, x
);
492 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
493 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
496 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
498 long len
= scm_ilength (SCM_CDR (xorig
));
499 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
501 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
507 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
508 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
511 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
513 long len
= scm_ilength (SCM_CDR (xorig
));
514 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
516 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
522 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
523 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
526 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
529 SCM cdrx
= SCM_CDR (xorig
);
530 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
531 clauses
= SCM_CDR (cdrx
);
532 while (!SCM_NULLP (clauses
))
534 SCM clause
= SCM_CAR (clauses
);
535 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
536 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
537 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
538 && SCM_NULLP (SCM_CDR (clauses
))),
539 scm_s_clauses
, s_case
);
540 clauses
= SCM_CDR (clauses
);
542 return scm_cons (SCM_IM_CASE
, cdrx
);
546 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
547 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
550 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
552 SCM cdrx
= SCM_CDR (xorig
);
554 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
555 while (!SCM_NULLP (clauses
))
557 SCM clause
= SCM_CAR (clauses
);
558 long len
= scm_ilength (clause
);
559 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
560 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
562 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
563 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
565 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
567 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
568 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
570 clauses
= SCM_CDR (clauses
);
572 return scm_cons (SCM_IM_COND
, cdrx
);
576 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
577 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
579 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
580 * cdr of the last cons. (Thus, LIST is not required to be a proper
581 * list and OBJ can also be found in the improper ending.) */
583 scm_c_improper_memq (SCM obj
, SCM list
)
585 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
587 if (SCM_EQ_P (SCM_CAR (list
), obj
))
590 return SCM_EQ_P (list
, obj
);
594 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
597 SCM x
= SCM_CDR (xorig
);
599 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
601 formals
= SCM_CAR (x
);
602 while (SCM_CONSP (formals
))
604 SCM formal
= SCM_CAR (formals
);
605 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
606 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
607 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
608 formals
= SCM_CDR (formals
);
610 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
611 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
613 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
614 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
618 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
619 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
621 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
622 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
624 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
627 SCM x
= SCM_CDR (xorig
);
631 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
633 bindings
= SCM_CAR (x
);
634 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
635 while (!SCM_NULLP (bindings
))
637 SCM binding
= SCM_CAR (bindings
);
638 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
639 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
640 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
641 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
642 bindings
= SCM_CDR (bindings
);
645 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
646 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
650 /* DO gets the most radically altered syntax. The order of the vars is
651 * reversed here. In contrast, the order of the inits and steps is reversed
652 * during the evaluation:
654 (do ((<var1> <init1> <step1>)
662 (#@do (varn ... var2 var1)
663 (<init1> <init2> ... <initn>)
666 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
669 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
670 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
673 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
676 SCM x
= SCM_CDR (xorig
);
679 SCM
*initloc
= &inits
;
681 SCM
*steploc
= &steps
;
682 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
683 bindings
= SCM_CAR (x
);
684 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
685 while (!SCM_NULLP (bindings
))
687 SCM binding
= SCM_CAR (bindings
);
688 long len
= scm_ilength (binding
);
689 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
691 SCM name
= SCM_CAR (binding
);
692 SCM init
= SCM_CADR (binding
);
693 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
694 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
695 vars
= scm_cons (name
, vars
);
696 *initloc
= scm_list_1 (init
);
697 initloc
= SCM_CDRLOC (*initloc
);
698 *steploc
= scm_list_1 (step
);
699 steploc
= SCM_CDRLOC (*steploc
);
700 bindings
= SCM_CDR (bindings
);
704 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
705 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
706 x
= scm_cons2 (vars
, inits
, x
);
707 return scm_cons (SCM_IM_DO
, x
);
711 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
712 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
714 /* Internal function to handle a quasiquotation: 'form' is the parameter in
715 * the call (quasiquotation form), 'env' is the environment where unquoted
716 * expressions will be evaluated, and 'depth' is the current quasiquotation
717 * nesting level and is known to be greater than zero. */
719 iqq (SCM form
, SCM env
, unsigned long int depth
)
721 if (SCM_CONSP (form
))
723 SCM tmp
= SCM_CAR (form
);
724 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
726 SCM args
= SCM_CDR (form
);
727 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
728 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
730 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
732 SCM args
= SCM_CDR (form
);
733 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
735 return scm_eval_car (args
, env
);
737 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
739 else if (SCM_CONSP (tmp
)
740 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
742 SCM args
= SCM_CDR (tmp
);
743 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
746 SCM list
= scm_eval_car (args
, env
);
747 SCM rest
= SCM_CDR (form
);
748 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
749 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
752 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
753 iqq (SCM_CDR (form
), env
, depth
));
756 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
757 iqq (SCM_CDR (form
), env
, depth
));
759 else if (SCM_VECTORP (form
))
761 size_t i
= SCM_VECTOR_LENGTH (form
);
762 SCM
const *data
= SCM_VELTS (form
);
765 tmp
= scm_cons (data
[--i
], tmp
);
766 scm_remember_upto_here_1 (form
);
767 return scm_vector (iqq (tmp
, env
, depth
));
774 scm_m_quasiquote (SCM xorig
, SCM env
)
776 SCM x
= SCM_CDR (xorig
);
777 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
778 return iqq (SCM_CAR (x
), env
, 1);
782 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
783 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
785 /* Promises are implemented as closures with an empty parameter list. Thus,
786 * (delay <expression>) is transformed into (#@delay '() <expression>), where
787 * the empty list represents the empty parameter list. This representation
788 * allows for easy creation of the closure during evaluation. */
790 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
792 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
793 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
797 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
798 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
800 /* Like promises, futures are implemented as closures with an empty
801 * parameter list. Thus, (future <expression>) is transformed into
802 * (#@future '() <expression>), where the empty list represents the
803 * empty parameter list. This representation allows for easy creation
804 * of the closure during evaluation. */
806 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
808 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
809 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
813 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
814 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
816 /* Guile provides an extension to R5RS' define syntax to represent function
817 * currying in a compact way. With this extension, it is allowed to write
818 * (define <nested-variable> <body>), where <nested-variable> has of one of
819 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
820 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
821 * should be either a sequence of zero or more variables, or a sequence of one
822 * or more variables followed by a space-delimited period and another
823 * variable. Each level of argument nesting wraps the <body> within another
824 * lambda expression. For example, the following forms are allowed, each one
825 * followed by an equivalent, more explicit implementation.
827 * (define ((a b . c) . d) <body>) is equivalent to
828 * (define a (lambda (b . c) (lambda d <body>)))
830 * (define (((a) b) c . d) <body>) is equivalent to
831 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
833 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
834 * module that does not implement this extension. */
836 scm_m_define (SCM x
, SCM env
)
840 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
843 while (SCM_CONSP (name
))
845 /* This while loop realizes function currying by variable nesting. */
846 SCM formals
= SCM_CDR (name
);
847 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
848 name
= SCM_CAR (name
);
850 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
851 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
852 if (SCM_TOP_LEVEL (env
))
855 x
= scm_eval_car (x
, env
);
856 if (SCM_REC_PROCNAMES_P
)
859 while (SCM_MACROP (tmp
))
860 tmp
= SCM_MACRO_CODE (tmp
);
861 if (SCM_CLOSUREP (tmp
)
862 /* Only the first definition determines the name. */
863 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
864 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
866 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
867 SCM_VARIABLE_SET (var
, x
);
868 return SCM_UNSPECIFIED
;
871 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
875 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
876 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
877 * reversed here, the list of inits gets reversed during evaluation. */
879 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
885 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
889 SCM binding
= SCM_CAR (bindings
);
890 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
891 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
892 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
893 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
894 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
895 *initloc
= scm_list_1 (SCM_CADR (binding
));
896 initloc
= SCM_CDRLOC (*initloc
);
897 bindings
= SCM_CDR (bindings
);
899 while (!SCM_NULLP (bindings
));
905 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
906 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
909 scm_m_letrec (SCM xorig
, SCM env
)
911 SCM x
= SCM_CDR (xorig
);
912 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
914 if (SCM_NULLP (SCM_CAR (x
)))
916 /* null binding, let* faster */
917 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
918 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
922 SCM rvars
, inits
, body
;
923 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
924 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
925 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
930 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
931 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
934 scm_m_let (SCM xorig
, SCM env
)
936 SCM x
= SCM_CDR (xorig
);
939 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
942 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
944 /* null or single binding, let* is faster */
946 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
947 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
949 else if (SCM_CONSP (temp
))
953 SCM rvars
, inits
, body
;
954 transform_bindings (bindings
, &rvars
, &inits
, "let");
955 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
956 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
960 /* named let: Transform (let name ((var init) ...) body ...) into
961 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
967 SCM
*initloc
= &inits
;
970 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
972 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
973 bindings
= SCM_CAR (x
);
974 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
975 while (!SCM_NULLP (bindings
))
976 { /* vars and inits both in order */
977 SCM binding
= SCM_CAR (bindings
);
978 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
979 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
980 *varloc
= scm_list_1 (SCM_CAR (binding
));
981 varloc
= SCM_CDRLOC (*varloc
);
982 *initloc
= scm_list_1 (SCM_CADR (binding
));
983 initloc
= SCM_CDRLOC (*initloc
);
984 bindings
= SCM_CDR (bindings
);
988 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
989 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
990 SCM rvar
= scm_list_1 (name
);
991 SCM init
= scm_list_1 (lambda_form
);
992 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
993 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
994 return scm_cons (letrec
, inits
);
1000 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1001 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1002 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1005 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1007 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1008 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1012 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1013 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1017 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1019 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1020 scm_s_expression
, s_atcall_cc
);
1021 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1024 #if SCM_ENABLE_ELISP
1026 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1029 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1031 long len
= scm_ilength (SCM_CDR (xorig
));
1032 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1033 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1036 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1039 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1041 SCM x
= SCM_CDR (xorig
), var
;
1042 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1043 var
= scm_symbol_fref (SCM_CAR (x
));
1044 /* Passing the symbol name as the `subr' arg here isn't really
1045 right, but without it it can be very difficult to work out from
1046 the error message which function definition was missing. In any
1047 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1048 something equivalent to (signal void-function (list SYM)) in
1050 SCM_ASSYNT (SCM_VARIABLEP (var
),
1051 "Symbol's function definition is void",
1052 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1053 /* Support `defalias'. */
1054 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1056 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1057 SCM_ASSYNT (SCM_VARIABLEP (var
),
1058 "Symbol's function definition is void",
1059 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1061 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1062 former allows for automatically picking up redefinitions of the
1063 corresponding symbol. */
1064 SCM_SETCAR (x
, var
);
1065 /* If the variable contains a procedure, leave the
1066 `transformer-macro' in place so that the procedure's arguments
1067 get properly transformed, and change the initial @fop to
1069 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1071 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1074 /* Otherwise (the variable contains a macro), the arguments should
1075 not be transformed, so cut the `transformer-macro' out and return
1076 the resulting expression starting with the variable. */
1077 SCM_SETCDR (x
, SCM_CDADR (x
));
1081 #endif /* SCM_ENABLE_ELISP */
1083 /* (@bind ((var exp) ...) body ...)
1085 This will assign the values of the `exp's to the global variables
1086 named by `var's (symbols, not evaluated), creating them if they
1087 don't exist, executes body, and then restores the previous values of
1088 the `var's. Additionally, whenever control leaves body, the values
1089 of the `var's are saved and restored when control returns. It is an
1090 error when a symbol appears more than once among the `var's.
1091 All `exp's are evaluated before any `var' is set.
1093 Think of this as `let' for dynamic scope.
1095 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1097 XXX - also implement `@bind*'.
1100 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1103 scm_m_atbind (SCM xorig
, SCM env
)
1105 SCM x
= SCM_CDR (xorig
);
1106 SCM top_level
= scm_env_top_level (env
);
1107 SCM vars
= SCM_EOL
, var
;
1110 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1113 while (SCM_NIMP (x
))
1116 SCM sym_exp
= SCM_CAR (x
);
1117 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1118 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1120 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1121 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1122 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1123 /* The first call to scm_sym2var will look beyond the current
1124 module, while the second call wont. */
1125 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1126 if (SCM_FALSEP (var
))
1127 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1128 vars
= scm_cons (var
, vars
);
1129 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1131 return scm_cons (SCM_IM_BIND
,
1132 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1136 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1137 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1140 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1142 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1143 scm_s_expression
, s_at_call_with_values
);
1144 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1148 scm_m_expand_body (SCM xorig
, SCM env
)
1150 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1151 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1153 while (SCM_NIMP (x
))
1155 SCM form
= SCM_CAR (x
);
1156 if (!SCM_CONSP (form
))
1158 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1161 form
= scm_macroexp (scm_cons_source (form
,
1166 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1168 defs
= scm_cons (SCM_CDR (form
), defs
);
1171 else if (!SCM_IMP (defs
))
1175 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1177 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1181 x
= scm_cons (form
, SCM_CDR (x
));
1186 if (!SCM_NULLP (defs
))
1188 SCM rvars
, inits
, body
, letrec
;
1189 transform_bindings (defs
, &rvars
, &inits
, what
);
1190 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1191 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1192 SCM_SETCAR (xorig
, letrec
);
1193 SCM_SETCDR (xorig
, SCM_EOL
);
1197 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1198 SCM_SETCAR (xorig
, SCM_CAR (x
));
1199 SCM_SETCDR (xorig
, SCM_CDR (x
));
1206 scm_macroexp (SCM x
, SCM env
)
1208 SCM res
, proc
, orig_sym
;
1210 /* Don't bother to produce error messages here. We get them when we
1211 eventually execute the code for real. */
1214 orig_sym
= SCM_CAR (x
);
1215 if (!SCM_SYMBOLP (orig_sym
))
1219 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1220 if (proc_ptr
== NULL
)
1222 /* We have lost the race. */
1228 /* Only handle memoizing macros. `Acros' and `macros' are really
1229 special forms and should not be evaluated here. */
1231 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1234 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1235 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1237 if (scm_ilength (res
) <= 0)
1238 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1241 SCM_SETCAR (x
, SCM_CAR (res
));
1242 SCM_SETCDR (x
, SCM_CDR (res
));
1248 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1250 /* A function object to implement "apply" for non-closure functions. */
1252 /* An endless list consisting of #<undefined> objects: */
1253 static SCM undefineds
;
1255 /* scm_unmemocopy takes a memoized expression together with its
1256 * environment and rewrites it to its original form. Thus, it is the
1257 * inversion of the rewrite rules above. The procedure is not
1258 * optimized for speed. It's used in scm_iprin1 when printing the
1259 * code of a closure, in scm_procedure_source, in display_frame when
1260 * generating the source for a stackframe in a backtrace, and in
1261 * display_expression.
1263 * Unmemoizing is not a reliable process. You cannot in general
1264 * expect to get the original source back.
1266 * However, GOOPS currently relies on this for method compilation.
1267 * This ought to change.
1271 build_binding_list (SCM names
, SCM inits
)
1273 SCM bindings
= SCM_EOL
;
1274 while (!SCM_NULLP (names
))
1276 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1277 bindings
= scm_cons (binding
, bindings
);
1278 names
= SCM_CDR (names
);
1279 inits
= SCM_CDR (inits
);
1285 unmemocopy (SCM x
, SCM env
)
1291 p
= scm_whash_lookup (scm_source_whash
, x
);
1292 switch (SCM_ITAG7 (SCM_CAR (x
)))
1294 case SCM_BIT7 (SCM_IM_AND
):
1295 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1297 case SCM_BIT7 (SCM_IM_BEGIN
):
1298 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1300 case SCM_BIT7 (SCM_IM_CASE
):
1301 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1303 case SCM_BIT7 (SCM_IM_COND
):
1304 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1306 case SCM_BIT7 (SCM_IM_DO
):
1308 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1309 * where nx is the name of a local variable, ix is an initializer for
1310 * the local variable, test is the test clause of the do loop, body is
1311 * the body of the do loop and sx are the step clauses for the local
1313 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1316 names
= SCM_CAR (x
);
1318 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1319 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1321 test
= unmemocopy (SCM_CAR (x
), env
);
1323 memoized_body
= SCM_CAR (x
);
1325 steps
= scm_reverse (unmemocopy (x
, env
));
1327 /* build transformed binding list */
1329 while (!SCM_NULLP (names
))
1331 SCM name
= SCM_CAR (names
);
1332 SCM init
= SCM_CAR (inits
);
1333 SCM step
= SCM_CAR (steps
);
1334 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1336 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1338 names
= SCM_CDR (names
);
1339 inits
= SCM_CDR (inits
);
1340 steps
= SCM_CDR (steps
);
1342 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1343 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1345 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1348 case SCM_BIT7 (SCM_IM_IF
):
1349 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1351 case SCM_BIT7 (SCM_IM_LET
):
1353 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1354 * where nx is the name of a local variable, ix is an initializer for
1355 * the local variable and by are the body clauses. */
1356 SCM names
, inits
, bindings
;
1359 names
= SCM_CAR (x
);
1361 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1362 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1364 bindings
= build_binding_list (names
, inits
);
1365 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1366 ls
= scm_cons (scm_sym_let
, z
);
1369 case SCM_BIT7 (SCM_IM_LETREC
):
1371 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1372 * where nx is the name of a local variable, ix is an initializer for
1373 * the local variable and by are the body clauses. */
1374 SCM names
, inits
, bindings
;
1377 names
= SCM_CAR (x
);
1378 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1380 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1382 bindings
= build_binding_list (names
, inits
);
1383 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1384 ls
= scm_cons (scm_sym_letrec
, z
);
1387 case SCM_BIT7 (SCM_IM_LETSTAR
):
1395 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1398 y
= z
= scm_acons (SCM_CAR (b
),
1400 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1402 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1406 SCM_SETCDR (y
, SCM_EOL
);
1407 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1412 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1414 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1417 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1420 while (SCM_NIMP (b
));
1421 SCM_SETCDR (z
, SCM_EOL
);
1423 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1426 case SCM_BIT7 (SCM_IM_OR
):
1427 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1429 case SCM_BIT7 (SCM_IM_LAMBDA
):
1431 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1432 ls
= scm_cons (scm_sym_lambda
, z
);
1433 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1435 case SCM_BIT7 (SCM_IM_QUOTE
):
1436 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1438 case SCM_BIT7 (SCM_IM_SET_X
):
1439 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1441 case SCM_BIT7 (SCM_IM_DEFINE
):
1446 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1447 ls
= scm_cons (scm_sym_define
, z
);
1448 if (!SCM_NULLP (env
))
1449 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1454 case SCM_BIT7 (SCM_MAKISYM (0)):
1458 switch (SCM_ISYMNUM (z
))
1460 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1461 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1463 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1464 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1466 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1467 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1470 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1471 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1474 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1475 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1478 /* appease the Sun compiler god: */ ;
1482 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1488 while (SCM_CONSP (x
))
1490 SCM form
= SCM_CAR (x
);
1491 if (!SCM_ISYMP (form
))
1493 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1494 SCM_SETCDR (z
, unmemocar (copy
, env
));
1500 if (!SCM_FALSEP (p
))
1501 scm_whash_insert (scm_source_whash
, ls
, p
);
1507 scm_unmemocopy (SCM x
, SCM env
)
1509 if (!SCM_NULLP (env
))
1510 /* Make a copy of the lowest frame to protect it from
1511 modifications by SCM_IM_DEFINE */
1512 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1514 return unmemocopy (x
, env
);
1519 scm_badargsp (SCM formals
, SCM args
)
1521 while (!SCM_NULLP (formals
))
1523 if (!SCM_CONSP (formals
))
1525 if (SCM_NULLP (args
))
1527 formals
= SCM_CDR (formals
);
1528 args
= SCM_CDR (args
);
1530 return !SCM_NULLP (args
) ? 1 : 0;
1535 scm_badformalsp (SCM closure
, int n
)
1537 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1538 while (!SCM_NULLP (formals
))
1540 if (!SCM_CONSP (formals
))
1545 formals
= SCM_CDR (formals
);
1552 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1554 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1555 while (SCM_CONSP (l
))
1557 res
= EVALCAR (l
, env
);
1559 *lloc
= scm_list_1 (res
);
1560 lloc
= SCM_CDRLOC (*lloc
);
1564 scm_wrong_num_args (proc
);
1569 scm_eval_body (SCM code
, SCM env
)
1573 next
= SCM_CDR (code
);
1574 while (!SCM_NULLP (next
))
1576 if (SCM_IMP (SCM_CAR (code
)))
1578 if (SCM_ISYMP (SCM_CAR (code
)))
1580 scm_rec_mutex_lock (&source_mutex
);
1581 /* check for race condition */
1582 if (SCM_ISYMP (SCM_CAR (code
)))
1583 code
= scm_m_expand_body (code
, env
);
1584 scm_rec_mutex_unlock (&source_mutex
);
1589 SCM_XEVAL (SCM_CAR (code
), env
);
1591 next
= SCM_CDR (code
);
1593 return SCM_XEVALCAR (code
, env
);
1600 /* SECTION: This code is specific for the debugging support. One
1601 * branch is read when DEVAL isn't defined, the other when DEVAL is
1607 #define SCM_APPLY scm_apply
1608 #define PREP_APPLY(proc, args)
1610 #define RETURN(x) do { return x; } while (0)
1611 #ifdef STACK_CHECKING
1612 #ifndef NO_CEVAL_STACK_CHECKING
1613 #define EVAL_STACK_CHECKING
1620 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1622 #define SCM_APPLY scm_dapply
1624 #define PREP_APPLY(p, l) \
1625 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1627 #define ENTER_APPLY \
1629 SCM_SET_ARGSREADY (debug);\
1630 if (scm_check_apply_p && SCM_TRAPS_P)\
1631 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1633 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1634 SCM_SET_TRACED_FRAME (debug); \
1636 if (SCM_CHEAPTRAPS_P)\
1638 tmp = scm_make_debugobj (&debug);\
1639 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1644 tmp = scm_make_continuation (&first);\
1646 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1652 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1653 #ifdef STACK_CHECKING
1654 #ifndef EVAL_STACK_CHECKING
1655 #define EVAL_STACK_CHECKING
1659 /* scm_ceval_ptr points to the currently selected evaluator.
1660 * *fixme*: Although efficiency is important here, this state variable
1661 * should probably not be a global. It should be related to the
1666 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1668 /* scm_last_debug_frame contains a pointer to the last debugging
1669 * information stack frame. It is accessed very often from the
1670 * debugging evaluator, so it should probably not be indirectly
1671 * addressed. Better to save and restore it from the current root at
1675 /* scm_debug_eframe_size is the number of slots available for pseudo
1676 * stack frames at each real stack frame.
1679 long scm_debug_eframe_size
;
1681 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1683 long scm_eval_stack
;
1685 scm_t_option scm_eval_opts
[] = {
1686 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1689 scm_t_option scm_debug_opts
[] = {
1690 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1691 "*Flyweight representation of the stack at traps." },
1692 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1693 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1694 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1695 "Record procedure names at definition." },
1696 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1697 "Display backtrace in anti-chronological order." },
1698 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1699 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1700 { SCM_OPTION_INTEGER
, "frames", 3,
1701 "Maximum number of tail-recursive frames in backtrace." },
1702 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1703 "Maximal number of stored backtrace frames." },
1704 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1705 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1706 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1707 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1708 { 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."}
1711 scm_t_option scm_evaluator_trap_table
[] = {
1712 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1713 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1714 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1715 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1716 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1717 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1718 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1721 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1723 "Option interface for the evaluation options. Instead of using\n"
1724 "this procedure directly, use the procedures @code{eval-enable},\n"
1725 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1726 #define FUNC_NAME s_scm_eval_options_interface
1730 ans
= scm_options (setting
,
1734 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1740 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1742 "Option interface for the evaluator trap options.")
1743 #define FUNC_NAME s_scm_evaluator_traps
1747 ans
= scm_options (setting
,
1748 scm_evaluator_trap_table
,
1749 SCM_N_EVALUATOR_TRAPS
,
1751 SCM_RESET_DEBUG_MODE
;
1758 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1760 SCM
*results
= lloc
, res
;
1761 while (SCM_CONSP (l
))
1763 res
= EVALCAR (l
, env
);
1765 *lloc
= scm_list_1 (res
);
1766 lloc
= SCM_CDRLOC (*lloc
);
1770 scm_wrong_num_args (proc
);
1777 /* SECTION: This code is compiled twice.
1781 /* Update the toplevel environment frame ENV so that it refers to the
1782 * current module. */
1783 #define UPDATE_TOPLEVEL_ENV(env) \
1785 SCM p = scm_current_module_lookup_closure (); \
1786 if (p != SCM_CAR(env)) \
1787 env = scm_top_level_env (p); \
1791 /* This is the evaluator. Like any real monster, it has three heads:
1793 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1794 * version. Both are implemented using a common code base, using the
1795 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1796 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1797 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1798 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1799 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1800 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1801 * are enclosed within #ifdef DEVAL ... #endif.
1803 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1804 * take two input parameters, x and env: x is a single expression to be
1805 * evalutated. env is the environment in which bindings are searched.
1807 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1808 * is a single expression, it is necessarily in a tail position. If x is just
1809 * a call to another function like in the expression (foo exp1 exp2 ...), the
1810 * realization of that call therefore _must_not_ increase stack usage (the
1811 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1812 * making extensive use of 'goto' statements within the evaluator: The gotos
1813 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1814 * that SCM_CEVAL was already using. If, however, x represents some form that
1815 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1816 * then recursive calls to SCM_CEVAL are performed for all but the last
1817 * expression of that sequence. */
1821 scm_ceval (SCM x
, SCM env
)
1827 scm_deval (SCM x
, SCM env
)
1832 SCM_CEVAL (SCM x
, SCM env
)
1836 scm_t_debug_frame debug
;
1837 scm_t_debug_info
*debug_info_end
;
1838 debug
.prev
= scm_last_debug_frame
;
1841 * The debug.vect contains twice as much scm_t_debug_info frames as the
1842 * user has specified with (debug-set! frames <n>).
1844 * Even frames are eval frames, odd frames are apply frames.
1846 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1847 * sizeof (scm_t_debug_info
));
1848 debug
.info
= debug
.vect
;
1849 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1850 scm_last_debug_frame
= &debug
;
1852 #ifdef EVAL_STACK_CHECKING
1853 if (scm_stack_checking_enabled_p
1854 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1857 debug
.info
->e
.exp
= x
;
1858 debug
.info
->e
.env
= env
;
1860 scm_report_stack_overflow ();
1870 SCM_CLEAR_ARGSREADY (debug
);
1871 if (SCM_OVERFLOWP (debug
))
1874 * In theory, this should be the only place where it is necessary to
1875 * check for space in debug.vect since both eval frames and
1876 * available space are even.
1878 * For this to be the case, however, it is necessary that primitive
1879 * special forms which jump back to `loop', `begin' or some similar
1880 * label call PREP_APPLY.
1882 else if (++debug
.info
>= debug_info_end
)
1884 SCM_SET_OVERFLOW (debug
);
1889 debug
.info
->e
.exp
= x
;
1890 debug
.info
->e
.env
= env
;
1891 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1893 if (SCM_ENTER_FRAME_P
1894 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1897 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1898 SCM_SET_TAILREC (debug
);
1899 if (SCM_CHEAPTRAPS_P
)
1900 stackrep
= scm_make_debugobj (&debug
);
1904 SCM val
= scm_make_continuation (&first
);
1914 /* This gives the possibility for the debugger to
1915 modify the source expression before evaluation. */
1920 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1921 scm_sym_enter_frame
,
1924 scm_unmemocopy (x
, env
));
1931 switch (SCM_TYP7 (x
))
1933 case scm_tc7_symbol
:
1934 /* Only happens when called at top level. */
1935 x
= scm_cons (x
, SCM_UNDEFINED
);
1936 RETURN (*scm_lookupcar (x
, env
, 1));
1938 case SCM_BIT7 (SCM_IM_AND
):
1940 while (!SCM_NULLP (SCM_CDR (x
)))
1942 SCM test_result
= EVALCAR (x
, env
);
1943 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1944 RETURN (SCM_BOOL_F
);
1948 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1951 case SCM_BIT7 (SCM_IM_BEGIN
):
1954 RETURN (SCM_UNSPECIFIED
);
1956 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1959 /* If we are on toplevel with a lookup closure, we need to sync
1960 with the current module. */
1961 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1963 UPDATE_TOPLEVEL_ENV (env
);
1964 while (!SCM_NULLP (SCM_CDR (x
)))
1967 UPDATE_TOPLEVEL_ENV (env
);
1973 goto nontoplevel_begin
;
1976 while (!SCM_NULLP (SCM_CDR (x
)))
1978 SCM form
= SCM_CAR (x
);
1981 if (SCM_ISYMP (form
))
1983 scm_rec_mutex_lock (&source_mutex
);
1984 /* check for race condition */
1985 if (SCM_ISYMP (SCM_CAR (x
)))
1986 x
= scm_m_expand_body (x
, env
);
1987 scm_rec_mutex_unlock (&source_mutex
);
1988 goto nontoplevel_begin
;
1991 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
1994 SCM_CEVAL (form
, env
);
2000 /* scm_eval last form in list */
2001 SCM last_form
= SCM_CAR (x
);
2003 if (SCM_CONSP (last_form
))
2005 /* This is by far the most frequent case. */
2007 goto loop
; /* tail recurse */
2009 else if (SCM_IMP (last_form
))
2010 RETURN (SCM_EVALIM (last_form
, env
));
2011 else if (SCM_VARIABLEP (last_form
))
2012 RETURN (SCM_VARIABLE_REF (last_form
));
2013 else if (SCM_SYMBOLP (last_form
))
2014 RETURN (*scm_lookupcar (x
, env
, 1));
2020 case SCM_BIT7 (SCM_IM_CASE
):
2023 SCM key
= EVALCAR (x
, env
);
2025 while (!SCM_NULLP (x
))
2027 SCM clause
= SCM_CAR (x
);
2028 SCM labels
= SCM_CAR (clause
);
2029 if (SCM_EQ_P (labels
, scm_sym_else
))
2031 x
= SCM_CDR (clause
);
2032 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2035 while (!SCM_NULLP (labels
))
2037 SCM label
= SCM_CAR (labels
);
2038 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2040 x
= SCM_CDR (clause
);
2041 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2044 labels
= SCM_CDR (labels
);
2049 RETURN (SCM_UNSPECIFIED
);
2052 case SCM_BIT7 (SCM_IM_COND
):
2054 while (!SCM_NULLP (x
))
2056 SCM clause
= SCM_CAR (x
);
2057 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2059 x
= SCM_CDR (clause
);
2060 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2065 arg1
= EVALCAR (clause
, env
);
2066 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2068 x
= SCM_CDR (clause
);
2071 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2073 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2079 proc
= EVALCAR (proc
, env
);
2080 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2081 PREP_APPLY (proc
, scm_list_1 (arg1
));
2083 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2084 goto umwrongnumargs
;
2092 RETURN (SCM_UNSPECIFIED
);
2095 case SCM_BIT7 (SCM_IM_DO
):
2098 /* Compute the initialization values and the initial environment. */
2099 SCM init_forms
= SCM_CADR (x
);
2100 SCM init_values
= SCM_EOL
;
2101 while (!SCM_NULLP (init_forms
))
2103 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2104 init_forms
= SCM_CDR (init_forms
);
2106 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2110 SCM test_form
= SCM_CAR (x
);
2111 SCM body_forms
= SCM_CADR (x
);
2112 SCM step_forms
= SCM_CDDR (x
);
2114 SCM test_result
= EVALCAR (test_form
, env
);
2116 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2119 /* Evaluate body forms. */
2121 for (temp_forms
= body_forms
;
2122 !SCM_NULLP (temp_forms
);
2123 temp_forms
= SCM_CDR (temp_forms
))
2125 SCM form
= SCM_CAR (temp_forms
);
2126 /* Dirk:FIXME: We only need to eval forms, that may have a
2127 * side effect here. This is only true for forms that start
2128 * with a pair. All others are just constants. However,
2129 * since in the common case there is no constant expression
2130 * in a body of a do form, we just check for immediates here
2131 * and have SCM_CEVAL take care of other cases. In the long
2132 * run it would make sense to get rid of this test and have
2133 * the macro transformer of 'do' eliminate all forms that
2134 * have no sideeffect. */
2135 if (!SCM_IMP (form
))
2136 SCM_CEVAL (form
, env
);
2141 /* Evaluate the step expressions. */
2143 SCM step_values
= SCM_EOL
;
2144 for (temp_forms
= step_forms
;
2145 !SCM_NULLP (temp_forms
);
2146 temp_forms
= SCM_CDR (temp_forms
))
2148 SCM value
= EVALCAR (temp_forms
, env
);
2149 step_values
= scm_cons (value
, step_values
);
2151 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2154 test_result
= EVALCAR (test_form
, env
);
2159 RETURN (SCM_UNSPECIFIED
);
2160 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2161 goto nontoplevel_begin
;
2164 case SCM_BIT7 (SCM_IM_IF
):
2167 SCM test_result
= EVALCAR (x
, env
);
2168 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2174 RETURN (SCM_UNSPECIFIED
);
2177 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2181 case SCM_BIT7 (SCM_IM_LET
):
2184 SCM init_forms
= SCM_CADR (x
);
2185 SCM init_values
= SCM_EOL
;
2188 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2189 init_forms
= SCM_CDR (init_forms
);
2191 while (!SCM_NULLP (init_forms
));
2192 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2195 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2196 goto nontoplevel_begin
;
2199 case SCM_BIT7 (SCM_IM_LETREC
):
2201 env
= EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2204 SCM init_forms
= SCM_CAR (x
);
2205 SCM init_values
= SCM_EOL
;
2208 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2209 init_forms
= SCM_CDR (init_forms
);
2211 while (!SCM_NULLP (init_forms
));
2212 SCM_SETCDR (SCM_CAR (env
), init_values
);
2215 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2216 goto nontoplevel_begin
;
2219 case SCM_BIT7 (SCM_IM_LETSTAR
):
2222 SCM bindings
= SCM_CAR (x
);
2223 if (SCM_NULLP (bindings
))
2224 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2229 SCM name
= SCM_CAR (bindings
);
2230 SCM init
= SCM_CDR (bindings
);
2231 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2232 bindings
= SCM_CDR (init
);
2234 while (!SCM_NULLP (bindings
));
2238 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2239 goto nontoplevel_begin
;
2242 case SCM_BIT7 (SCM_IM_OR
):
2244 while (!SCM_NULLP (SCM_CDR (x
)))
2246 SCM val
= EVALCAR (x
, env
);
2247 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2252 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2256 case SCM_BIT7 (SCM_IM_LAMBDA
):
2257 RETURN (scm_closure (SCM_CDR (x
), env
));
2260 case SCM_BIT7 (SCM_IM_QUOTE
):
2261 RETURN (SCM_CADR (x
));
2264 case SCM_BIT7 (SCM_IM_SET_X
):
2268 SCM variable
= SCM_CAR (x
);
2269 if (SCM_ILOCP (variable
))
2270 location
= scm_ilookup (variable
, env
);
2271 else if (SCM_VARIABLEP (variable
))
2272 location
= SCM_VARIABLE_LOC (variable
);
2273 else /* (SCM_SYMBOLP (variable)) is known to be true */
2274 location
= scm_lookupcar (x
, env
, 1);
2276 *location
= EVALCAR (x
, env
);
2278 RETURN (SCM_UNSPECIFIED
);
2281 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2282 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2285 /* new syntactic forms go here. */
2286 case SCM_BIT7 (SCM_MAKISYM (0)):
2288 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2289 switch (SCM_ISYMNUM (proc
))
2293 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2295 proc
= EVALCAR (proc
, env
);
2296 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2297 if (SCM_CLOSUREP (proc
))
2299 PREP_APPLY (proc
, SCM_EOL
);
2300 arg1
= SCM_CDDR (x
);
2301 arg1
= EVALCAR (arg1
, env
);
2303 /* Go here to tail-call a closure. PROC is the closure
2304 and ARG1 is the list of arguments. Do not forget to
2307 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2309 debug
.info
->a
.args
= arg1
;
2311 if (scm_badargsp (formals
, arg1
))
2312 scm_wrong_num_args (proc
);
2314 /* Copy argument list */
2315 if (SCM_NULL_OR_NIL_P (arg1
))
2316 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2319 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2321 arg1
= SCM_CDR (arg1
);
2322 while (!SCM_NULL_OR_NIL_P (arg1
))
2324 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2325 SCM_SETCDR (tail
, new_tail
);
2327 arg1
= SCM_CDR (arg1
);
2329 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2332 x
= SCM_CLOSURE_BODY (proc
);
2333 goto nontoplevel_begin
;
2343 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2346 SCM val
= scm_make_continuation (&first
);
2354 proc
= scm_eval_car (proc
, env
);
2355 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2356 PREP_APPLY (proc
, scm_list_1 (arg1
));
2358 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2359 goto umwrongnumargs
;
2365 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2366 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2369 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2370 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2373 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2375 /* If not done yet, evaluate the operand forms. The result is a
2376 * list of arguments stored in arg1, which is used to perform the
2377 * function dispatch. */
2378 SCM operand_forms
= SCM_CADR (x
);
2379 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2380 if (SCM_ILOCP (operand_forms
))
2381 arg1
= *scm_ilookup (operand_forms
, env
);
2382 else if (SCM_VARIABLEP (operand_forms
))
2383 arg1
= SCM_VARIABLE_REF (operand_forms
);
2384 else if (!SCM_CONSP (operand_forms
))
2385 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2388 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2389 operand_forms
= SCM_CDR (operand_forms
);
2390 while (!SCM_NULLP (operand_forms
))
2392 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2393 SCM_SETCDR (tail
, new_tail
);
2395 operand_forms
= SCM_CDR (operand_forms
);
2400 /* The type dispatch code is duplicated below
2401 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2402 * cuts down execution time for type dispatch to 50%. */
2403 type_dispatch
: /* inputs: x, arg1 */
2404 /* Type dispatch means to determine from the types of the function
2405 * arguments (i. e. the 'signature' of the call), which method from
2406 * a generic function is to be called. This process of selecting
2407 * the right method takes some time. To speed it up, guile uses
2408 * caching: Together with the macro call to dispatch the signatures
2409 * of some previous calls to that generic function from the same
2410 * place are stored (in the code!) in a cache that we call the
2411 * 'method cache'. This is done since it is likely, that
2412 * consecutive calls to dispatch from that position in the code will
2413 * have the same signature. Thus, the type dispatch works as
2414 * follows: First, determine a hash value from the signature of the
2415 * actual arguments. Second, use this hash value as an index to
2416 * find that same signature in the method cache stored at this
2417 * position in the code. If found, you have also found the
2418 * corresponding method that belongs to that signature. If the
2419 * signature is not found in the method cache, you have to perform a
2420 * full search over all signatures stored with the generic
2423 unsigned long int specializers
;
2424 unsigned long int hash_value
;
2425 unsigned long int cache_end_pos
;
2426 unsigned long int mask
;
2430 SCM z
= SCM_CDDR (x
);
2431 SCM tmp
= SCM_CADR (z
);
2432 specializers
= SCM_INUM (SCM_CAR (z
));
2434 /* Compute a hash value for searching the method cache. There
2435 * are two variants for computing the hash value, a (rather)
2436 * complicated one, and a simple one. For the complicated one
2437 * explained below, tmp holds a number that is used in the
2439 if (SCM_INUMP (tmp
))
2441 /* Use the signature of the actual arguments to determine
2442 * the hash value. This is done as follows: Each class has
2443 * an array of random numbers, that are determined when the
2444 * class is created. The integer 'hashset' is an index into
2445 * that array of random numbers. Now, from all classes that
2446 * are part of the signature of the actual arguments, the
2447 * random numbers at index 'hashset' are taken and summed
2448 * up, giving the hash value. The value of 'hashset' is
2449 * stored at the call to dispatch. This allows to have
2450 * different 'formulas' for calculating the hash value at
2451 * different places where dispatch is called. This allows
2452 * to optimize the hash formula at every individual place
2453 * where dispatch is called, such that hopefully the hash
2454 * value that is computed will directly point to the right
2455 * method in the method cache. */
2456 unsigned long int hashset
= SCM_INUM (tmp
);
2457 unsigned long int counter
= specializers
+ 1;
2460 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2462 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2463 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2464 tmp_arg
= SCM_CDR (tmp_arg
);
2468 method_cache
= SCM_CADR (z
);
2469 mask
= SCM_INUM (SCM_CAR (z
));
2471 cache_end_pos
= hash_value
;
2475 /* This method of determining the hash value is much
2476 * simpler: Set the hash value to zero and just perform a
2477 * linear search through the method cache. */
2479 mask
= (unsigned long int) ((long) -1);
2481 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2486 /* Search the method cache for a method with a matching
2487 * signature. Start the search at position 'hash_value'. The
2488 * hashing implementation uses linear probing for conflict
2489 * resolution, that is, if the signature in question is not
2490 * found at the starting index in the hash table, the next table
2491 * entry is tried, and so on, until in the worst case the whole
2492 * cache has been searched, but still the signature has not been
2497 SCM args
= arg1
; /* list of arguments */
2498 z
= SCM_VELTS (method_cache
)[hash_value
];
2499 while (!SCM_NULLP (args
))
2501 /* More arguments than specifiers => CLASS != ENV */
2502 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2503 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2505 args
= SCM_CDR (args
);
2508 /* Fewer arguments than specifiers => CAR != ENV */
2509 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2512 hash_value
= (hash_value
+ 1) & mask
;
2513 } while (hash_value
!= cache_end_pos
);
2515 /* No appropriate method was found in the cache. */
2516 z
= scm_memoize_method (x
, arg1
);
2518 apply_cmethod
: /* inputs: z, arg1 */
2520 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2521 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2522 x
= SCM_CMETHOD_BODY (z
);
2523 goto nontoplevel_begin
;
2529 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2532 SCM instance
= EVALCAR (x
, env
);
2533 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2534 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2538 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2541 SCM instance
= EVALCAR (x
, env
);
2542 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2543 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2544 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2545 RETURN (SCM_UNSPECIFIED
);
2549 #if SCM_ENABLE_ELISP
2551 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2553 SCM test_form
= SCM_CDR (x
);
2554 x
= SCM_CDR (test_form
);
2555 while (!SCM_NULL_OR_NIL_P (x
))
2557 SCM test_result
= EVALCAR (test_form
, env
);
2558 if (!(SCM_FALSEP (test_result
)
2559 || SCM_NULL_OR_NIL_P (test_result
)))
2561 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2562 RETURN (test_result
);
2563 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2568 test_form
= SCM_CDR (x
);
2569 x
= SCM_CDR (test_form
);
2573 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2577 #endif /* SCM_ENABLE_ELISP */
2579 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2581 SCM vars
, exps
, vals
;
2584 vars
= SCM_CAAR (x
);
2585 exps
= SCM_CDAR (x
);
2589 while (SCM_NIMP (exps
))
2591 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2592 exps
= SCM_CDR (exps
);
2595 scm_swap_bindings (vars
, vals
);
2596 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2598 /* Ignore all but the last evaluation result. */
2599 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2601 if (SCM_CONSP (SCM_CAR (x
)))
2602 SCM_CEVAL (SCM_CAR (x
), env
);
2604 proc
= EVALCAR (x
, env
);
2606 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2607 scm_swap_bindings (vars
, vals
);
2613 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2616 x
= EVALCAR (proc
, env
);
2617 proc
= SCM_CDR (proc
);
2618 proc
= EVALCAR (proc
, env
);
2619 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2620 if (SCM_VALUESP (arg1
))
2621 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2623 arg1
= scm_list_1 (arg1
);
2624 if (SCM_CLOSUREP (proc
))
2626 PREP_APPLY (proc
, arg1
);
2629 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2640 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2641 case scm_tc7_vector
:
2645 case scm_tc7_byvect
:
2652 #if SCM_SIZEOF_LONG_LONG != 0
2653 case scm_tc7_llvect
:
2656 case scm_tc7_string
:
2658 case scm_tcs_closures
:
2662 case scm_tcs_struct
:
2665 case scm_tc7_variable
:
2666 RETURN (SCM_VARIABLE_REF(x
));
2668 case SCM_BIT7 (SCM_ILOC00
):
2669 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2670 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2673 case scm_tcs_cons_nimcar
:
2674 if (SCM_SYMBOLP (SCM_CAR (x
)))
2676 SCM orig_sym
= SCM_CAR (x
);
2678 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2679 if (location
== NULL
)
2681 /* we have lost the race, start again. */
2689 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2693 if (SCM_MACROP (proc
))
2695 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2697 handle_a_macro
: /* inputs: x, env, proc */
2699 /* Set a flag during macro expansion so that macro
2700 application frames can be deleted from the backtrace. */
2701 SCM_SET_MACROEXP (debug
);
2703 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2704 scm_cons (env
, scm_listofnull
));
2707 SCM_CLEAR_MACROEXP (debug
);
2709 switch (SCM_MACRO_TYPE (proc
))
2712 if (scm_ilength (arg1
) <= 0)
2713 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2715 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2718 SCM_SETCAR (x
, SCM_CAR (arg1
));
2719 SCM_SETCDR (x
, SCM_CDR (arg1
));
2723 /* Prevent memoizing of debug info expression. */
2724 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2729 SCM_SETCAR (x
, SCM_CAR (arg1
));
2730 SCM_SETCDR (x
, SCM_CDR (arg1
));
2732 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2734 #if SCM_ENABLE_DEPRECATED == 1
2739 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2751 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2752 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2755 if (SCM_CLOSUREP (proc
))
2757 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2758 SCM args
= SCM_CDR (x
);
2759 while (!SCM_NULLP (formals
))
2761 if (!SCM_CONSP (formals
))
2764 goto umwrongnumargs
;
2765 formals
= SCM_CDR (formals
);
2766 args
= SCM_CDR (args
);
2768 if (!SCM_NULLP (args
))
2769 goto umwrongnumargs
;
2771 else if (SCM_MACROP (proc
))
2772 goto handle_a_macro
;
2776 evapply
: /* inputs: x, proc */
2777 PREP_APPLY (proc
, SCM_EOL
);
2778 if (SCM_NULLP (SCM_CDR (x
))) {
2781 switch (SCM_TYP7 (proc
))
2782 { /* no arguments given */
2783 case scm_tc7_subr_0
:
2784 RETURN (SCM_SUBRF (proc
) ());
2785 case scm_tc7_subr_1o
:
2786 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2788 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2789 case scm_tc7_rpsubr
:
2790 RETURN (SCM_BOOL_T
);
2792 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2794 if (!SCM_SMOB_APPLICABLE_P (proc
))
2796 RETURN (SCM_SMOB_APPLY_0 (proc
));
2799 proc
= SCM_CCLO_SUBR (proc
);
2801 debug
.info
->a
.proc
= proc
;
2802 debug
.info
->a
.args
= scm_list_1 (arg1
);
2806 proc
= SCM_PROCEDURE (proc
);
2808 debug
.info
->a
.proc
= proc
;
2810 if (!SCM_CLOSUREP (proc
))
2812 if (scm_badformalsp (proc
, 0))
2813 goto umwrongnumargs
;
2814 case scm_tcs_closures
:
2815 x
= SCM_CLOSURE_BODY (proc
);
2816 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2817 goto nontoplevel_begin
;
2818 case scm_tcs_struct
:
2819 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2821 x
= SCM_ENTITY_PROCEDURE (proc
);
2825 else if (!SCM_I_OPERATORP (proc
))
2830 proc
= (SCM_I_ENTITYP (proc
)
2831 ? SCM_ENTITY_PROCEDURE (proc
)
2832 : SCM_OPERATOR_PROCEDURE (proc
));
2834 debug
.info
->a
.proc
= proc
;
2835 debug
.info
->a
.args
= scm_list_1 (arg1
);
2837 if (SCM_NIMP (proc
))
2842 case scm_tc7_subr_1
:
2843 case scm_tc7_subr_2
:
2844 case scm_tc7_subr_2o
:
2846 case scm_tc7_subr_3
:
2847 case scm_tc7_lsubr_2
:
2850 scm_wrong_num_args (proc
);
2852 /* handle macros here */
2857 /* must handle macros by here */
2860 arg1
= EVALCAR (x
, env
);
2862 scm_wrong_num_args (proc
);
2864 debug
.info
->a
.args
= scm_list_1 (arg1
);
2872 evap1
: /* inputs: proc, arg1 */
2873 switch (SCM_TYP7 (proc
))
2874 { /* have one argument in arg1 */
2875 case scm_tc7_subr_2o
:
2876 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2877 case scm_tc7_subr_1
:
2878 case scm_tc7_subr_1o
:
2879 RETURN (SCM_SUBRF (proc
) (arg1
));
2881 if (SCM_SUBRF (proc
))
2883 if (SCM_INUMP (arg1
))
2885 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2887 else if (SCM_REALP (arg1
))
2889 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2891 else if (SCM_BIGP (arg1
))
2893 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2895 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2896 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2898 proc
= SCM_SNAME (proc
);
2900 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2901 while ('c' != *--chrs
)
2903 SCM_ASSERT (SCM_CONSP (arg1
),
2904 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2905 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2909 case scm_tc7_rpsubr
:
2910 RETURN (SCM_BOOL_T
);
2912 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2915 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2917 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2920 if (!SCM_SMOB_APPLICABLE_P (proc
))
2922 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2926 proc
= SCM_CCLO_SUBR (proc
);
2928 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2929 debug
.info
->a
.proc
= proc
;
2933 proc
= SCM_PROCEDURE (proc
);
2935 debug
.info
->a
.proc
= proc
;
2937 if (!SCM_CLOSUREP (proc
))
2939 if (scm_badformalsp (proc
, 1))
2940 goto umwrongnumargs
;
2941 case scm_tcs_closures
:
2943 x
= SCM_CLOSURE_BODY (proc
);
2945 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2947 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2949 goto nontoplevel_begin
;
2950 case scm_tcs_struct
:
2951 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2953 x
= SCM_ENTITY_PROCEDURE (proc
);
2955 arg1
= debug
.info
->a
.args
;
2957 arg1
= scm_list_1 (arg1
);
2961 else if (!SCM_I_OPERATORP (proc
))
2967 proc
= (SCM_I_ENTITYP (proc
)
2968 ? SCM_ENTITY_PROCEDURE (proc
)
2969 : SCM_OPERATOR_PROCEDURE (proc
));
2971 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2972 debug
.info
->a
.proc
= proc
;
2974 if (SCM_NIMP (proc
))
2979 case scm_tc7_subr_2
:
2980 case scm_tc7_subr_0
:
2981 case scm_tc7_subr_3
:
2982 case scm_tc7_lsubr_2
:
2983 scm_wrong_num_args (proc
);
2989 arg2
= EVALCAR (x
, env
);
2991 scm_wrong_num_args (proc
);
2993 { /* have two or more arguments */
2995 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
2998 if (SCM_NULLP (x
)) {
3001 switch (SCM_TYP7 (proc
))
3002 { /* have two arguments */
3003 case scm_tc7_subr_2
:
3004 case scm_tc7_subr_2o
:
3005 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3008 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3010 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3012 case scm_tc7_lsubr_2
:
3013 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3014 case scm_tc7_rpsubr
:
3016 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3018 if (!SCM_SMOB_APPLICABLE_P (proc
))
3020 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3024 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3025 scm_cons (proc
, debug
.info
->a
.args
),
3028 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3029 scm_cons2 (proc
, arg1
,
3036 case scm_tcs_struct
:
3037 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3039 x
= SCM_ENTITY_PROCEDURE (proc
);
3041 arg1
= debug
.info
->a
.args
;
3043 arg1
= scm_list_2 (arg1
, arg2
);
3047 else if (!SCM_I_OPERATORP (proc
))
3053 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3054 ? SCM_ENTITY_PROCEDURE (proc
)
3055 : SCM_OPERATOR_PROCEDURE (proc
),
3056 scm_cons (proc
, debug
.info
->a
.args
),
3059 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3060 ? SCM_ENTITY_PROCEDURE (proc
)
3061 : SCM_OPERATOR_PROCEDURE (proc
),
3062 scm_cons2 (proc
, arg1
,
3070 case scm_tc7_subr_0
:
3072 case scm_tc7_subr_1o
:
3073 case scm_tc7_subr_1
:
3074 case scm_tc7_subr_3
:
3075 scm_wrong_num_args (proc
);
3079 proc
= SCM_PROCEDURE (proc
);
3081 debug
.info
->a
.proc
= proc
;
3083 if (!SCM_CLOSUREP (proc
))
3085 if (scm_badformalsp (proc
, 2))
3086 goto umwrongnumargs
;
3087 case scm_tcs_closures
:
3090 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3094 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3095 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3097 x
= SCM_CLOSURE_BODY (proc
);
3098 goto nontoplevel_begin
;
3102 scm_wrong_num_args (proc
);
3104 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3105 deval_args (x
, env
, proc
,
3106 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3110 switch (SCM_TYP7 (proc
))
3111 { /* have 3 or more arguments */
3113 case scm_tc7_subr_3
:
3114 if (!SCM_NULLP (SCM_CDR (x
)))
3115 scm_wrong_num_args (proc
);
3117 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3118 SCM_CADDR (debug
.info
->a
.args
)));
3120 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3121 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3124 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3125 arg2
= SCM_CDR (arg2
);
3127 while (SCM_NIMP (arg2
));
3129 case scm_tc7_rpsubr
:
3130 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3131 RETURN (SCM_BOOL_F
);
3132 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3135 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3136 RETURN (SCM_BOOL_F
);
3137 arg2
= SCM_CAR (arg1
);
3138 arg1
= SCM_CDR (arg1
);
3140 while (SCM_NIMP (arg1
));
3141 RETURN (SCM_BOOL_T
);
3142 case scm_tc7_lsubr_2
:
3143 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3144 SCM_CDDR (debug
.info
->a
.args
)));
3146 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3148 if (!SCM_SMOB_APPLICABLE_P (proc
))
3150 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3151 SCM_CDDR (debug
.info
->a
.args
)));
3155 proc
= SCM_PROCEDURE (proc
);
3156 debug
.info
->a
.proc
= proc
;
3157 if (!SCM_CLOSUREP (proc
))
3159 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3160 goto umwrongnumargs
;
3161 case scm_tcs_closures
:
3162 SCM_SET_ARGSREADY (debug
);
3163 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3166 x
= SCM_CLOSURE_BODY (proc
);
3167 goto nontoplevel_begin
;
3169 case scm_tc7_subr_3
:
3170 if (!SCM_NULLP (SCM_CDR (x
)))
3171 scm_wrong_num_args (proc
);
3173 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3175 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3178 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3181 while (SCM_NIMP (x
));
3183 case scm_tc7_rpsubr
:
3184 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3185 RETURN (SCM_BOOL_F
);
3188 arg1
= EVALCAR (x
, env
);
3189 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3190 RETURN (SCM_BOOL_F
);
3194 while (SCM_NIMP (x
));
3195 RETURN (SCM_BOOL_T
);
3196 case scm_tc7_lsubr_2
:
3197 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3199 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3201 scm_eval_args (x
, env
, proc
))));
3203 if (!SCM_SMOB_APPLICABLE_P (proc
))
3205 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3206 scm_eval_args (x
, env
, proc
)));
3210 proc
= SCM_PROCEDURE (proc
);
3211 if (!SCM_CLOSUREP (proc
))
3214 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3215 if (SCM_NULLP (formals
)
3216 || (SCM_CONSP (formals
)
3217 && (SCM_NULLP (SCM_CDR (formals
))
3218 || (SCM_CONSP (SCM_CDR (formals
))
3219 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3220 goto umwrongnumargs
;
3222 case scm_tcs_closures
:
3224 SCM_SET_ARGSREADY (debug
);
3226 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3229 scm_eval_args (x
, env
, proc
)),
3231 x
= SCM_CLOSURE_BODY (proc
);
3232 goto nontoplevel_begin
;
3234 case scm_tcs_struct
:
3235 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3238 arg1
= debug
.info
->a
.args
;
3240 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3242 x
= SCM_ENTITY_PROCEDURE (proc
);
3245 else if (!SCM_I_OPERATORP (proc
))
3249 case scm_tc7_subr_2
:
3250 case scm_tc7_subr_1o
:
3251 case scm_tc7_subr_2o
:
3252 case scm_tc7_subr_0
:
3254 case scm_tc7_subr_1
:
3255 scm_wrong_num_args (proc
);
3263 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3264 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3266 SCM_CLEAR_TRACED_FRAME (debug
);
3267 if (SCM_CHEAPTRAPS_P
)
3268 arg1
= scm_make_debugobj (&debug
);
3272 SCM val
= scm_make_continuation (&first
);
3283 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3287 scm_last_debug_frame
= debug
.prev
;
3293 /* SECTION: This code is compiled once.
3299 /* Simple procedure calls
3303 scm_call_0 (SCM proc
)
3305 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3309 scm_call_1 (SCM proc
, SCM arg1
)
3311 return scm_apply (proc
, arg1
, scm_listofnull
);
3315 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3317 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3321 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3323 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3327 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3329 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3330 scm_cons (arg4
, scm_listofnull
)));
3333 /* Simple procedure applies
3337 scm_apply_0 (SCM proc
, SCM args
)
3339 return scm_apply (proc
, args
, SCM_EOL
);
3343 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3345 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3349 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3351 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3355 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3357 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3361 /* This code processes the arguments to apply:
3363 (apply PROC ARG1 ... ARGS)
3365 Given a list (ARG1 ... ARGS), this function conses the ARG1
3366 ... arguments onto the front of ARGS, and returns the resulting
3367 list. Note that ARGS is a list; thus, the argument to this
3368 function is a list whose last element is a list.
3370 Apply calls this function, and applies PROC to the elements of the
3371 result. apply:nconc2last takes care of building the list of
3372 arguments, given (ARG1 ... ARGS).
3374 Rather than do new consing, apply:nconc2last destroys its argument.
3375 On that topic, this code came into my care with the following
3376 beautifully cryptic comment on that topic: "This will only screw
3377 you if you do (scm_apply scm_apply '( ... ))" If you know what
3378 they're referring to, send me a patch to this comment. */
3380 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3382 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3383 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3384 "@var{args}, and returns the resulting list. Note that\n"
3385 "@var{args} is a list; thus, the argument to this function is\n"
3386 "a list whose last element is a list.\n"
3387 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3388 "destroys its argument, so use with care.")
3389 #define FUNC_NAME s_scm_nconc2last
3392 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3394 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3395 SCM_NULL_OR_NIL_P, but not
3396 needed in 99.99% of cases,
3397 and it could seriously hurt
3398 performance. - Neil */
3399 lloc
= SCM_CDRLOC (*lloc
);
3400 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3401 *lloc
= SCM_CAR (*lloc
);
3409 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3410 * It is compiled twice.
3415 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3421 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3426 /* Apply a function to a list of arguments.
3428 This function is exported to the Scheme level as taking two
3429 required arguments and a tail argument, as if it were:
3430 (lambda (proc arg1 . args) ...)
3431 Thus, if you just have a list of arguments to pass to a procedure,
3432 pass the list as ARG1, and '() for ARGS. If you have some fixed
3433 args, pass the first as ARG1, then cons any remaining fixed args
3434 onto the front of your argument list, and pass that as ARGS. */
3437 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3440 scm_t_debug_frame debug
;
3441 scm_t_debug_info debug_vect_body
;
3442 debug
.prev
= scm_last_debug_frame
;
3443 debug
.status
= SCM_APPLYFRAME
;
3444 debug
.vect
= &debug_vect_body
;
3445 debug
.vect
[0].a
.proc
= proc
;
3446 debug
.vect
[0].a
.args
= SCM_EOL
;
3447 scm_last_debug_frame
= &debug
;
3450 return scm_dapply (proc
, arg1
, args
);
3453 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3455 /* If ARGS is the empty list, then we're calling apply with only two
3456 arguments --- ARG1 is the list of arguments for PROC. Whatever
3457 the case, futz with things so that ARG1 is the first argument to
3458 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3461 Setting the debug apply frame args this way is pretty messy.
3462 Perhaps we should store arg1 and args directly in the frame as
3463 received, and let scm_frame_arguments unpack them, because that's
3464 a relatively rare operation. This works for now; if the Guile
3465 developer archives are still around, see Mikael's post of
3467 if (SCM_NULLP (args
))
3469 if (SCM_NULLP (arg1
))
3471 arg1
= SCM_UNDEFINED
;
3473 debug
.vect
[0].a
.args
= SCM_EOL
;
3479 debug
.vect
[0].a
.args
= arg1
;
3481 args
= SCM_CDR (arg1
);
3482 arg1
= SCM_CAR (arg1
);
3487 args
= scm_nconc2last (args
);
3489 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3493 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3496 if (SCM_CHEAPTRAPS_P
)
3497 tmp
= scm_make_debugobj (&debug
);
3502 tmp
= scm_make_continuation (&first
);
3507 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3514 switch (SCM_TYP7 (proc
))
3516 case scm_tc7_subr_2o
:
3517 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3518 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3519 case scm_tc7_subr_2
:
3520 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3521 scm_wrong_num_args (proc
);
3522 args
= SCM_CAR (args
);
3523 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3524 case scm_tc7_subr_0
:
3525 if (!SCM_UNBNDP (arg1
))
3526 scm_wrong_num_args (proc
);
3528 RETURN (SCM_SUBRF (proc
) ());
3529 case scm_tc7_subr_1
:
3530 if (SCM_UNBNDP (arg1
))
3531 scm_wrong_num_args (proc
);
3532 case scm_tc7_subr_1o
:
3533 if (!SCM_NULLP (args
))
3534 scm_wrong_num_args (proc
);
3536 RETURN (SCM_SUBRF (proc
) (arg1
));
3538 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3539 scm_wrong_num_args (proc
);
3540 if (SCM_SUBRF (proc
))
3542 if (SCM_INUMP (arg1
))
3544 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3546 else if (SCM_REALP (arg1
))
3548 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3550 else if (SCM_BIGP (arg1
))
3551 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3552 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3553 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3555 proc
= SCM_SNAME (proc
);
3557 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3558 while ('c' != *--chrs
)
3560 SCM_ASSERT (SCM_CONSP (arg1
),
3561 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3562 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3566 case scm_tc7_subr_3
:
3567 if (SCM_NULLP (args
)
3568 || SCM_NULLP (SCM_CDR (args
))
3569 || !SCM_NULLP (SCM_CDDR (args
)))
3570 scm_wrong_num_args (proc
);
3572 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3575 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3577 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3579 case scm_tc7_lsubr_2
:
3580 if (!SCM_CONSP (args
))
3581 scm_wrong_num_args (proc
);
3583 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3585 if (SCM_NULLP (args
))
3586 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3587 while (SCM_NIMP (args
))
3589 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3590 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3591 args
= SCM_CDR (args
);
3594 case scm_tc7_rpsubr
:
3595 if (SCM_NULLP (args
))
3596 RETURN (SCM_BOOL_T
);
3597 while (SCM_NIMP (args
))
3599 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3600 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3601 RETURN (SCM_BOOL_F
);
3602 arg1
= SCM_CAR (args
);
3603 args
= SCM_CDR (args
);
3605 RETURN (SCM_BOOL_T
);
3606 case scm_tcs_closures
:
3608 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3610 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3612 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3613 scm_wrong_num_args (proc
);
3615 /* Copy argument list */
3620 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3621 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3623 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3627 SCM_SETCDR (tl
, arg1
);
3630 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3631 proc
= SCM_CLOSURE_BODY (proc
);
3634 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3636 if (SCM_IMP (SCM_CAR (proc
)))
3638 if (SCM_ISYMP (SCM_CAR (proc
)))
3640 scm_rec_mutex_lock (&source_mutex
);
3641 /* check for race condition */
3642 if (SCM_ISYMP (SCM_CAR (proc
)))
3643 proc
= scm_m_expand_body (proc
, args
);
3644 scm_rec_mutex_unlock (&source_mutex
);
3648 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3651 SCM_CEVAL (SCM_CAR (proc
), args
);
3654 RETURN (EVALCAR (proc
, args
));
3656 if (!SCM_SMOB_APPLICABLE_P (proc
))
3658 if (SCM_UNBNDP (arg1
))
3659 RETURN (SCM_SMOB_APPLY_0 (proc
));
3660 else if (SCM_NULLP (args
))
3661 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3662 else if (SCM_NULLP (SCM_CDR (args
)))
3663 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3665 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3668 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3670 proc
= SCM_CCLO_SUBR (proc
);
3671 debug
.vect
[0].a
.proc
= proc
;
3672 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3674 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3676 proc
= SCM_CCLO_SUBR (proc
);
3680 proc
= SCM_PROCEDURE (proc
);
3682 debug
.vect
[0].a
.proc
= proc
;
3685 case scm_tcs_struct
:
3686 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3689 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3691 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3693 RETURN (scm_apply_generic (proc
, args
));
3695 else if (!SCM_I_OPERATORP (proc
))
3701 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3703 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3706 proc
= (SCM_I_ENTITYP (proc
)
3707 ? SCM_ENTITY_PROCEDURE (proc
)
3708 : SCM_OPERATOR_PROCEDURE (proc
));
3710 debug
.vect
[0].a
.proc
= proc
;
3711 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3713 if (SCM_NIMP (proc
))
3720 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3724 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3725 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3727 SCM_CLEAR_TRACED_FRAME (debug
);
3728 if (SCM_CHEAPTRAPS_P
)
3729 arg1
= scm_make_debugobj (&debug
);
3733 SCM val
= scm_make_continuation (&first
);
3744 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3748 scm_last_debug_frame
= debug
.prev
;
3754 /* SECTION: The rest of this file is only read once.
3761 * Trampolines make it possible to move procedure application dispatch
3762 * outside inner loops. The motivation was clean implementation of
3763 * efficient replacements of R5RS primitives in SRFI-1.
3765 * The semantics is clear: scm_trampoline_N returns an optimized
3766 * version of scm_call_N (or NULL if the procedure isn't applicable
3769 * Applying the optimization to map and for-each increased efficiency
3770 * noticeably. For example, (map abs ls) is now 8 times faster than
3775 call_subr0_0 (SCM proc
)
3777 return SCM_SUBRF (proc
) ();
3781 call_subr1o_0 (SCM proc
)
3783 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3787 call_lsubr_0 (SCM proc
)
3789 return SCM_SUBRF (proc
) (SCM_EOL
);
3793 scm_i_call_closure_0 (SCM proc
)
3795 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3796 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3802 scm_trampoline_0 (SCM proc
)
3808 switch (SCM_TYP7 (proc
))
3810 case scm_tc7_subr_0
:
3811 return call_subr0_0
;
3812 case scm_tc7_subr_1o
:
3813 return call_subr1o_0
;
3815 return call_lsubr_0
;
3816 case scm_tcs_closures
:
3818 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3819 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3820 return scm_i_call_closure_0
;
3824 case scm_tcs_struct
:
3825 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3826 return scm_call_generic_0
;
3827 else if (!SCM_I_OPERATORP (proc
))
3831 if (SCM_SMOB_APPLICABLE_P (proc
))
3832 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3837 case scm_tc7_rpsubr
:
3842 return 0; /* not applicable on one arg */
3847 call_subr1_1 (SCM proc
, SCM arg1
)
3849 return SCM_SUBRF (proc
) (arg1
);
3853 call_subr2o_1 (SCM proc
, SCM arg1
)
3855 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3859 call_lsubr_1 (SCM proc
, SCM arg1
)
3861 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3865 call_dsubr_1 (SCM proc
, SCM arg1
)
3867 if (SCM_INUMP (arg1
))
3869 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3871 else if (SCM_REALP (arg1
))
3873 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3875 else if (SCM_BIGP (arg1
))
3876 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3877 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3878 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3882 call_cxr_1 (SCM proc
, SCM arg1
)
3884 proc
= SCM_SNAME (proc
);
3886 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3887 while ('c' != *--chrs
)
3889 SCM_ASSERT (SCM_CONSP (arg1
),
3890 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3891 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3898 call_closure_1 (SCM proc
, SCM arg1
)
3900 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3901 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3907 scm_trampoline_1 (SCM proc
)
3913 switch (SCM_TYP7 (proc
))
3915 case scm_tc7_subr_1
:
3916 case scm_tc7_subr_1o
:
3917 return call_subr1_1
;
3918 case scm_tc7_subr_2o
:
3919 return call_subr2o_1
;
3921 return call_lsubr_1
;
3923 if (SCM_SUBRF (proc
))
3924 return call_dsubr_1
;
3927 case scm_tcs_closures
:
3929 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3930 if (!SCM_NULLP (formals
)
3931 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
3932 return call_closure_1
;
3936 case scm_tcs_struct
:
3937 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3938 return scm_call_generic_1
;
3939 else if (!SCM_I_OPERATORP (proc
))
3943 if (SCM_SMOB_APPLICABLE_P (proc
))
3944 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3949 case scm_tc7_rpsubr
:
3954 return 0; /* not applicable on one arg */
3959 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3961 return SCM_SUBRF (proc
) (arg1
, arg2
);
3965 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3967 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3971 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3973 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3977 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3979 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3980 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3981 scm_list_2 (arg1
, arg2
),
3986 scm_trampoline_2 (SCM proc
)
3992 switch (SCM_TYP7 (proc
))
3994 case scm_tc7_subr_2
:
3995 case scm_tc7_subr_2o
:
3996 case scm_tc7_rpsubr
:
3998 return call_subr2_2
;
3999 case scm_tc7_lsubr_2
:
4000 return call_lsubr2_2
;
4002 return call_lsubr_2
;
4003 case scm_tcs_closures
:
4005 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4006 if (!SCM_NULLP (formals
)
4007 && (!SCM_CONSP (formals
)
4008 || (!SCM_NULLP (SCM_CDR (formals
))
4009 && (!SCM_CONSP (SCM_CDR (formals
))
4010 || !SCM_CONSP (SCM_CDDR (formals
))))))
4011 return call_closure_2
;
4015 case scm_tcs_struct
:
4016 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4017 return scm_call_generic_2
;
4018 else if (!SCM_I_OPERATORP (proc
))
4022 if (SCM_SMOB_APPLICABLE_P (proc
))
4023 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4031 return 0; /* not applicable on two args */
4035 /* Typechecking for multi-argument MAP and FOR-EACH.
4037 Verify that each element of the vector ARGV, except for the first,
4038 is a proper list whose length is LEN. Attribute errors to WHO,
4039 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4041 check_map_args (SCM argv
,
4048 SCM
const *ve
= SCM_VELTS (argv
);
4051 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4053 long elt_len
= scm_ilength (ve
[i
]);
4058 scm_apply_generic (gf
, scm_cons (proc
, args
));
4060 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4064 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4067 scm_remember_upto_here_1 (argv
);
4071 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4073 /* Note: Currently, scm_map applies PROC to the argument list(s)
4074 sequentially, starting with the first element(s). This is used in
4075 evalext.c where the Scheme procedure `map-in-order', which guarantees
4076 sequential behaviour, is implemented using scm_map. If the
4077 behaviour changes, we need to update `map-in-order'.
4081 scm_map (SCM proc
, SCM arg1
, SCM args
)
4082 #define FUNC_NAME s_map
4087 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4089 len
= scm_ilength (arg1
);
4090 SCM_GASSERTn (len
>= 0,
4091 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4092 SCM_VALIDATE_REST_ARGUMENT (args
);
4093 if (SCM_NULLP (args
))
4095 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4096 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4097 while (SCM_NIMP (arg1
))
4099 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4100 pres
= SCM_CDRLOC (*pres
);
4101 arg1
= SCM_CDR (arg1
);
4105 if (SCM_NULLP (SCM_CDR (args
)))
4107 SCM arg2
= SCM_CAR (args
);
4108 int len2
= scm_ilength (arg2
);
4109 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4111 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4112 SCM_GASSERTn (len2
>= 0,
4113 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4115 SCM_OUT_OF_RANGE (3, arg2
);
4116 while (SCM_NIMP (arg1
))
4118 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4119 pres
= SCM_CDRLOC (*pres
);
4120 arg1
= SCM_CDR (arg1
);
4121 arg2
= SCM_CDR (arg2
);
4125 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4126 ve
= SCM_VELTS (args
);
4127 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4131 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4133 if (SCM_IMP (ve
[i
]))
4135 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4136 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4138 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4139 pres
= SCM_CDRLOC (*pres
);
4145 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4148 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4149 #define FUNC_NAME s_for_each
4151 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4153 len
= scm_ilength (arg1
);
4154 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4155 SCM_ARG2
, s_for_each
);
4156 SCM_VALIDATE_REST_ARGUMENT (args
);
4157 if (SCM_NULLP (args
))
4159 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4160 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4161 while (SCM_NIMP (arg1
))
4163 call (proc
, SCM_CAR (arg1
));
4164 arg1
= SCM_CDR (arg1
);
4166 return SCM_UNSPECIFIED
;
4168 if (SCM_NULLP (SCM_CDR (args
)))
4170 SCM arg2
= SCM_CAR (args
);
4171 int len2
= scm_ilength (arg2
);
4172 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4173 SCM_GASSERTn (call
, g_for_each
,
4174 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4175 SCM_GASSERTn (len2
>= 0, g_for_each
,
4176 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4178 SCM_OUT_OF_RANGE (3, arg2
);
4179 while (SCM_NIMP (arg1
))
4181 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4182 arg1
= SCM_CDR (arg1
);
4183 arg2
= SCM_CDR (arg2
);
4185 return SCM_UNSPECIFIED
;
4187 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4188 ve
= SCM_VELTS (args
);
4189 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4193 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4195 if (SCM_IMP (ve
[i
]))
4196 return SCM_UNSPECIFIED
;
4197 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4198 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4200 scm_apply (proc
, arg1
, SCM_EOL
);
4207 scm_closure (SCM code
, SCM env
)
4210 SCM closcar
= scm_cons (code
, SCM_EOL
);
4211 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4212 scm_remember_upto_here (closcar
);
4217 scm_t_bits scm_tc16_promise
;
4220 scm_makprom (SCM code
)
4222 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4224 scm_make_rec_mutex ());
4228 promise_free (SCM promise
)
4230 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4235 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4237 int writingp
= SCM_WRITINGP (pstate
);
4238 scm_puts ("#<promise ", port
);
4239 SCM_SET_WRITINGP (pstate
, 1);
4240 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4241 SCM_SET_WRITINGP (pstate
, writingp
);
4242 scm_putc ('>', port
);
4246 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4248 "If the promise @var{x} has not been computed yet, compute and\n"
4249 "return @var{x}, otherwise just return the previously computed\n"
4251 #define FUNC_NAME s_scm_force
4253 SCM_VALIDATE_SMOB (1, promise
, promise
);
4254 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4255 if (!SCM_PROMISE_COMPUTED_P (promise
))
4257 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4258 if (!SCM_PROMISE_COMPUTED_P (promise
))
4260 SCM_SET_PROMISE_DATA (promise
, ans
);
4261 SCM_SET_PROMISE_COMPUTED (promise
);
4264 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4265 return SCM_PROMISE_DATA (promise
);
4270 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4272 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4273 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4274 #define FUNC_NAME s_scm_promise_p
4276 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4281 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4282 (SCM xorig
, SCM x
, SCM y
),
4283 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4284 "Any source properties associated with @var{xorig} are also associated\n"
4285 "with the new pair.")
4286 #define FUNC_NAME s_scm_cons_source
4289 z
= scm_cons (x
, y
);
4290 /* Copy source properties possibly associated with xorig. */
4291 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4293 scm_whash_insert (scm_source_whash
, z
, p
);
4299 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4301 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4302 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4303 "contents of both pairs and vectors (since both cons cells and vector\n"
4304 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4305 "any other object.")
4306 #define FUNC_NAME s_scm_copy_tree
4311 if (SCM_VECTORP (obj
))
4313 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4314 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4316 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4319 if (!SCM_CONSP (obj
))
4321 ans
= tl
= scm_cons_source (obj
,
4322 scm_copy_tree (SCM_CAR (obj
)),
4324 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4326 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4330 SCM_SETCDR (tl
, obj
);
4336 /* We have three levels of EVAL here:
4338 - scm_i_eval (exp, env)
4340 evaluates EXP in environment ENV. ENV is a lexical environment
4341 structure as used by the actual tree code evaluator. When ENV is
4342 a top-level environment, then changes to the current module are
4343 tracked by updating ENV so that it continues to be in sync with
4346 - scm_primitive_eval (exp)
4348 evaluates EXP in the top-level environment as determined by the
4349 current module. This is done by constructing a suitable
4350 environment and calling scm_i_eval. Thus, changes to the
4351 top-level module are tracked normally.
4353 - scm_eval (exp, mod)
4355 evaluates EXP while MOD is the current module. This is done by
4356 setting the current module to MOD, invoking scm_primitive_eval on
4357 EXP, and then restoring the current module to the value it had
4358 previously. That is, while EXP is evaluated, changes to the
4359 current module are tracked, but these changes do not persist when
4362 For each level of evals, there are two variants, distinguished by a
4363 _x suffix: the ordinary variant does not modify EXP while the _x
4364 variant can destructively modify EXP into something completely
4365 unintelligible. A Scheme data structure passed as EXP to one of the
4366 _x variants should not ever be used again for anything. So when in
4367 doubt, use the ordinary variant.
4372 scm_i_eval_x (SCM exp
, SCM env
)
4374 return SCM_XEVAL (exp
, env
);
4378 scm_i_eval (SCM exp
, SCM env
)
4380 exp
= scm_copy_tree (exp
);
4381 return SCM_XEVAL (exp
, env
);
4385 scm_primitive_eval_x (SCM exp
)
4388 SCM transformer
= scm_current_module_transformer ();
4389 if (SCM_NIMP (transformer
))
4390 exp
= scm_call_1 (transformer
, exp
);
4391 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4392 return scm_i_eval_x (exp
, env
);
4395 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4397 "Evaluate @var{exp} in the top-level environment specified by\n"
4398 "the current module.")
4399 #define FUNC_NAME s_scm_primitive_eval
4402 SCM transformer
= scm_current_module_transformer ();
4403 if (SCM_NIMP (transformer
))
4404 exp
= scm_call_1 (transformer
, exp
);
4405 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4406 return scm_i_eval (exp
, env
);
4410 /* Eval does not take the second arg optionally. This is intentional
4411 * in order to be R5RS compatible, and to prepare for the new module
4412 * system, where we would like to make the choice of evaluation
4413 * environment explicit. */
4416 change_environment (void *data
)
4418 SCM pair
= SCM_PACK (data
);
4419 SCM new_module
= SCM_CAR (pair
);
4420 SCM old_module
= scm_current_module ();
4421 SCM_SETCDR (pair
, old_module
);
4422 scm_set_current_module (new_module
);
4427 restore_environment (void *data
)
4429 SCM pair
= SCM_PACK (data
);
4430 SCM old_module
= SCM_CDR (pair
);
4431 SCM new_module
= scm_current_module ();
4432 SCM_SETCAR (pair
, new_module
);
4433 scm_set_current_module (old_module
);
4437 inner_eval_x (void *data
)
4439 return scm_primitive_eval_x (SCM_PACK(data
));
4443 scm_eval_x (SCM exp
, SCM module
)
4444 #define FUNC_NAME "eval!"
4446 SCM_VALIDATE_MODULE (2, module
);
4448 return scm_internal_dynamic_wind
4449 (change_environment
, inner_eval_x
, restore_environment
,
4450 (void *) SCM_UNPACK (exp
),
4451 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4456 inner_eval (void *data
)
4458 return scm_primitive_eval (SCM_PACK(data
));
4461 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4462 (SCM exp
, SCM module
),
4463 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4464 "in the top-level environment specified by @var{module}.\n"
4465 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4466 "@var{module} is made the current module. The current module\n"
4467 "is reset to its previous value when @var{eval} returns.")
4468 #define FUNC_NAME s_scm_eval
4470 SCM_VALIDATE_MODULE (2, module
);
4472 return scm_internal_dynamic_wind
4473 (change_environment
, inner_eval
, restore_environment
,
4474 (void *) SCM_UNPACK (exp
),
4475 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4480 /* At this point, scm_deval and scm_dapply are generated.
4490 scm_init_opts (scm_evaluator_traps
,
4491 scm_evaluator_trap_table
,
4492 SCM_N_EVALUATOR_TRAPS
);
4493 scm_init_opts (scm_eval_options_interface
,
4495 SCM_N_EVAL_OPTIONS
);
4497 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4498 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4499 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4500 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4502 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4503 SCM_SETCDR (undefineds
, undefineds
);
4504 scm_permanent_object (undefineds
);
4506 scm_listofnull
= scm_list_1 (SCM_EOL
);
4508 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4509 scm_permanent_object (f_apply
);
4511 #include "libguile/eval.x"
4513 scm_add_feature ("delay");