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");
404 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
405 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
406 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
407 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
410 /* Check that the body denoted by XORIG is valid and rewrite it into
411 its internal form. The internal form of a body is just the body
412 itself, but prefixed with an ISYM that denotes to what kind of
413 outer construct this body belongs. A lambda body starts with
414 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
415 etc. The one exception is a body that belongs to a letrec that has
416 been formed by rewriting internal defines: it starts with
419 /* XXX - Besides controlling the rewriting of internal defines, the
420 additional ISYM could be used for improved error messages.
421 This is not done yet. */
424 scm_m_body (SCM op
, SCM xorig
, const char *what
)
426 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
428 /* Don't add another ISYM if one is present already. */
429 if (SCM_ISYMP (SCM_CAR (xorig
)))
432 /* Retain possible doc string. */
433 if (!SCM_CONSP (SCM_CAR (xorig
)))
435 if (!SCM_NULLP (SCM_CDR (xorig
)))
436 return scm_cons (SCM_CAR (xorig
),
437 scm_m_body (op
, SCM_CDR (xorig
), what
));
441 return scm_cons (op
, xorig
);
445 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
446 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
449 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
451 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
452 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
456 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
457 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
460 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
462 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
463 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
467 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
468 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
471 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
473 long len
= scm_ilength (SCM_CDR (xorig
));
474 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
475 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
479 /* Will go into the RnRS module when Guile is factorized.
480 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
481 const char scm_s_set_x
[] = "set!";
482 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
485 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
487 SCM x
= SCM_CDR (xorig
);
488 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
489 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
490 return scm_cons (SCM_IM_SET_X
, x
);
494 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
495 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
498 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
500 long len
= scm_ilength (SCM_CDR (xorig
));
501 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
503 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
509 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
510 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
513 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
515 long len
= scm_ilength (SCM_CDR (xorig
));
516 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
518 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
524 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
525 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
528 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
531 SCM cdrx
= SCM_CDR (xorig
);
532 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
533 clauses
= SCM_CDR (cdrx
);
534 while (!SCM_NULLP (clauses
))
536 SCM clause
= SCM_CAR (clauses
);
537 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
538 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
539 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
540 && SCM_NULLP (SCM_CDR (clauses
))),
541 scm_s_clauses
, s_case
);
542 clauses
= SCM_CDR (clauses
);
544 return scm_cons (SCM_IM_CASE
, cdrx
);
548 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
549 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
552 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
554 SCM cdrx
= SCM_CDR (xorig
);
556 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
557 while (!SCM_NULLP (clauses
))
559 SCM clause
= SCM_CAR (clauses
);
560 long len
= scm_ilength (clause
);
561 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
562 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
564 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
565 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
567 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
569 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
570 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
572 clauses
= SCM_CDR (clauses
);
574 return scm_cons (SCM_IM_COND
, cdrx
);
578 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
579 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
581 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
582 * cdr of the last cons. (Thus, LIST is not required to be a proper
583 * list and OBJ can also be found in the improper ending.) */
585 scm_c_improper_memq (SCM obj
, SCM list
)
587 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
589 if (SCM_EQ_P (SCM_CAR (list
), obj
))
592 return SCM_EQ_P (list
, obj
);
596 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
599 SCM x
= SCM_CDR (xorig
);
601 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
603 formals
= SCM_CAR (x
);
604 while (SCM_CONSP (formals
))
606 SCM formal
= SCM_CAR (formals
);
607 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
608 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
609 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
610 formals
= SCM_CDR (formals
);
612 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
613 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
615 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
616 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
620 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
621 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
623 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
624 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
626 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
629 SCM x
= SCM_CDR (xorig
);
633 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
635 bindings
= SCM_CAR (x
);
636 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
637 while (!SCM_NULLP (bindings
))
639 SCM binding
= SCM_CAR (bindings
);
640 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
641 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
642 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
643 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
644 bindings
= SCM_CDR (bindings
);
647 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
648 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
652 /* DO gets the most radically altered syntax. The order of the vars is
653 * reversed here. In contrast, the order of the inits and steps is reversed
654 * during the evaluation:
656 (do ((<var1> <init1> <step1>)
664 (#@do (varn ... var2 var1)
665 (<init1> <init2> ... <initn>)
668 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
671 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
672 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
675 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
678 SCM x
= SCM_CDR (xorig
);
681 SCM
*initloc
= &inits
;
683 SCM
*steploc
= &steps
;
684 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
685 bindings
= SCM_CAR (x
);
686 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
687 while (!SCM_NULLP (bindings
))
689 SCM binding
= SCM_CAR (bindings
);
690 long len
= scm_ilength (binding
);
691 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
693 SCM name
= SCM_CAR (binding
);
694 SCM init
= SCM_CADR (binding
);
695 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
696 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
697 vars
= scm_cons (name
, vars
);
698 *initloc
= scm_list_1 (init
);
699 initloc
= SCM_CDRLOC (*initloc
);
700 *steploc
= scm_list_1 (step
);
701 steploc
= SCM_CDRLOC (*steploc
);
702 bindings
= SCM_CDR (bindings
);
706 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
707 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
708 x
= scm_cons2 (vars
, inits
, x
);
709 return scm_cons (SCM_IM_DO
, x
);
713 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
714 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
716 /* Internal function to handle a quasiquotation: 'form' is the parameter in
717 * the call (quasiquotation form), 'env' is the environment where unquoted
718 * expressions will be evaluated, and 'depth' is the current quasiquotation
719 * nesting level and is known to be greater than zero. */
721 iqq (SCM form
, SCM env
, unsigned long int depth
)
723 if (SCM_CONSP (form
))
725 SCM tmp
= SCM_CAR (form
);
726 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
728 SCM args
= SCM_CDR (form
);
729 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
730 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
732 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
734 SCM args
= SCM_CDR (form
);
735 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
737 return scm_eval_car (args
, env
);
739 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
741 else if (SCM_CONSP (tmp
)
742 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
744 SCM args
= SCM_CDR (tmp
);
745 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
748 SCM list
= scm_eval_car (args
, env
);
749 SCM rest
= SCM_CDR (form
);
750 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
751 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
754 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
755 iqq (SCM_CDR (form
), env
, depth
));
758 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
759 iqq (SCM_CDR (form
), env
, depth
));
761 else if (SCM_VECTORP (form
))
763 size_t i
= SCM_VECTOR_LENGTH (form
);
764 SCM
const *data
= SCM_VELTS (form
);
767 tmp
= scm_cons (data
[--i
], tmp
);
768 scm_remember_upto_here_1 (form
);
769 return scm_vector (iqq (tmp
, env
, depth
));
776 scm_m_quasiquote (SCM xorig
, SCM env
)
778 SCM x
= SCM_CDR (xorig
);
779 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
780 return iqq (SCM_CAR (x
), env
, 1);
784 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
785 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
787 /* Promises are implemented as closures with an empty parameter list. Thus,
788 * (delay <expression>) is transformed into (#@delay '() <expression>), where
789 * the empty list represents the empty parameter list. This representation
790 * allows for easy creation of the closure during evaluation. */
792 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
794 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
795 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
799 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
800 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
802 /* Like promises, futures are implemented as closures with an empty
803 * parameter list. Thus, (future <expression>) is transformed into
804 * (#@future '() <expression>), where the empty list represents the
805 * empty parameter list. This representation allows for easy creation
806 * of the closure during evaluation. */
808 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
810 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
811 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
815 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
816 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
818 /* Guile provides an extension to R5RS' define syntax to represent function
819 * currying in a compact way. With this extension, it is allowed to write
820 * (define <nested-variable> <body>), where <nested-variable> has of one of
821 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
822 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
823 * should be either a sequence of zero or more variables, or a sequence of one
824 * or more variables followed by a space-delimited period and another
825 * variable. Each level of argument nesting wraps the <body> within another
826 * lambda expression. For example, the following forms are allowed, each one
827 * followed by an equivalent, more explicit implementation.
829 * (define ((a b . c) . d) <body>) is equivalent to
830 * (define a (lambda (b . c) (lambda d <body>)))
832 * (define (((a) b) c . d) <body>) is equivalent to
833 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
835 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
836 * module that does not implement this extension. */
838 scm_m_define (SCM x
, SCM env
)
842 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
845 while (SCM_CONSP (name
))
847 /* This while loop realizes function currying by variable nesting. */
848 SCM formals
= SCM_CDR (name
);
849 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
850 name
= SCM_CAR (name
);
852 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
853 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
854 if (SCM_TOP_LEVEL (env
))
857 x
= scm_eval_car (x
, env
);
858 if (SCM_REC_PROCNAMES_P
)
861 while (SCM_MACROP (tmp
))
862 tmp
= SCM_MACRO_CODE (tmp
);
863 if (SCM_CLOSUREP (tmp
)
864 /* Only the first definition determines the name. */
865 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
866 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
868 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
869 SCM_VARIABLE_SET (var
, x
);
870 return SCM_UNSPECIFIED
;
873 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
877 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
878 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
879 * reversed here, the list of inits gets reversed during evaluation. */
881 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
887 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
891 SCM binding
= SCM_CAR (bindings
);
892 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
893 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
894 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
895 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
896 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
897 *initloc
= scm_list_1 (SCM_CADR (binding
));
898 initloc
= SCM_CDRLOC (*initloc
);
899 bindings
= SCM_CDR (bindings
);
901 while (!SCM_NULLP (bindings
));
907 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
908 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
911 scm_m_letrec (SCM xorig
, SCM env
)
913 SCM x
= SCM_CDR (xorig
);
914 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
916 if (SCM_NULLP (SCM_CAR (x
)))
918 /* null binding, let* faster */
919 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
920 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
924 SCM rvars
, inits
, body
;
925 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
926 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
927 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
932 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
933 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
936 scm_m_let (SCM xorig
, SCM env
)
938 SCM x
= SCM_CDR (xorig
);
941 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
944 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
946 /* null or single binding, let* is faster */
948 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
949 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
951 else if (SCM_CONSP (temp
))
955 SCM rvars
, inits
, body
;
956 transform_bindings (bindings
, &rvars
, &inits
, "let");
957 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
958 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
962 /* named let: Transform (let name ((var init) ...) body ...) into
963 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
969 SCM
*initloc
= &inits
;
972 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
974 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
975 bindings
= SCM_CAR (x
);
976 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
977 while (!SCM_NULLP (bindings
))
978 { /* vars and inits both in order */
979 SCM binding
= SCM_CAR (bindings
);
980 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
981 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
982 *varloc
= scm_list_1 (SCM_CAR (binding
));
983 varloc
= SCM_CDRLOC (*varloc
);
984 *initloc
= scm_list_1 (SCM_CADR (binding
));
985 initloc
= SCM_CDRLOC (*initloc
);
986 bindings
= SCM_CDR (bindings
);
990 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
991 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
992 SCM rvar
= scm_list_1 (name
);
993 SCM init
= scm_list_1 (lambda_form
);
994 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
995 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
996 return scm_cons (letrec
, inits
);
1002 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1003 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1004 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1007 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1009 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1010 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1014 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1015 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1019 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1021 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1022 scm_s_expression
, s_atcall_cc
);
1023 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1026 #if SCM_ENABLE_ELISP
1028 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1031 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1033 long len
= scm_ilength (SCM_CDR (xorig
));
1034 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1035 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1038 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1041 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1043 SCM x
= SCM_CDR (xorig
), var
;
1044 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1045 var
= scm_symbol_fref (SCM_CAR (x
));
1046 /* Passing the symbol name as the `subr' arg here isn't really
1047 right, but without it it can be very difficult to work out from
1048 the error message which function definition was missing. In any
1049 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1050 something equivalent to (signal void-function (list SYM)) in
1052 SCM_ASSYNT (SCM_VARIABLEP (var
),
1053 "Symbol's function definition is void",
1054 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1055 /* Support `defalias'. */
1056 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1058 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1059 SCM_ASSYNT (SCM_VARIABLEP (var
),
1060 "Symbol's function definition is void",
1061 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1063 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1064 former allows for automatically picking up redefinitions of the
1065 corresponding symbol. */
1066 SCM_SETCAR (x
, var
);
1067 /* If the variable contains a procedure, leave the
1068 `transformer-macro' in place so that the procedure's arguments
1069 get properly transformed, and change the initial @fop to
1071 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1073 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1076 /* Otherwise (the variable contains a macro), the arguments should
1077 not be transformed, so cut the `transformer-macro' out and return
1078 the resulting expression starting with the variable. */
1079 SCM_SETCDR (x
, SCM_CDADR (x
));
1083 #endif /* SCM_ENABLE_ELISP */
1085 /* (@bind ((var exp) ...) body ...)
1087 This will assign the values of the `exp's to the global variables
1088 named by `var's (symbols, not evaluated), creating them if they
1089 don't exist, executes body, and then restores the previous values of
1090 the `var's. Additionally, whenever control leaves body, the values
1091 of the `var's are saved and restored when control returns. It is an
1092 error when a symbol appears more than once among the `var's.
1093 All `exp's are evaluated before any `var' is set.
1095 Think of this as `let' for dynamic scope.
1097 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1099 XXX - also implement `@bind*'.
1102 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1105 scm_m_atbind (SCM xorig
, SCM env
)
1107 SCM x
= SCM_CDR (xorig
);
1108 SCM top_level
= scm_env_top_level (env
);
1109 SCM vars
= SCM_EOL
, var
;
1112 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1115 while (SCM_NIMP (x
))
1118 SCM sym_exp
= SCM_CAR (x
);
1119 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1120 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1122 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1123 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1124 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1125 /* The first call to scm_sym2var will look beyond the current
1126 module, while the second call wont. */
1127 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1128 if (SCM_FALSEP (var
))
1129 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1130 vars
= scm_cons (var
, vars
);
1131 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1133 return scm_cons (SCM_IM_BIND
,
1134 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1138 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1139 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1142 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1144 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1145 scm_s_expression
, s_at_call_with_values
);
1146 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1150 scm_m_expand_body (SCM xorig
, SCM env
)
1152 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1153 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1155 while (SCM_NIMP (x
))
1157 SCM form
= SCM_CAR (x
);
1158 if (!SCM_CONSP (form
))
1160 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1163 form
= scm_macroexp (scm_cons_source (form
,
1168 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1170 defs
= scm_cons (SCM_CDR (form
), defs
);
1173 else if (!SCM_IMP (defs
))
1177 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1179 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1183 x
= scm_cons (form
, SCM_CDR (x
));
1188 if (!SCM_NULLP (defs
))
1190 SCM rvars
, inits
, body
, letrec
;
1191 transform_bindings (defs
, &rvars
, &inits
, what
);
1192 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1193 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1194 SCM_SETCAR (xorig
, letrec
);
1195 SCM_SETCDR (xorig
, SCM_EOL
);
1199 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1200 SCM_SETCAR (xorig
, SCM_CAR (x
));
1201 SCM_SETCDR (xorig
, SCM_CDR (x
));
1208 scm_macroexp (SCM x
, SCM env
)
1210 SCM res
, proc
, orig_sym
;
1212 /* Don't bother to produce error messages here. We get them when we
1213 eventually execute the code for real. */
1216 orig_sym
= SCM_CAR (x
);
1217 if (!SCM_SYMBOLP (orig_sym
))
1221 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1222 if (proc_ptr
== NULL
)
1224 /* We have lost the race. */
1230 /* Only handle memoizing macros. `Acros' and `macros' are really
1231 special forms and should not be evaluated here. */
1233 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1236 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1237 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1239 if (scm_ilength (res
) <= 0)
1240 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1243 SCM_SETCAR (x
, SCM_CAR (res
));
1244 SCM_SETCDR (x
, SCM_CDR (res
));
1250 /* scm_unmemocopy takes a memoized expression together with its
1251 * environment and rewrites it to its original form. Thus, it is the
1252 * inversion of the rewrite rules above. The procedure is not
1253 * optimized for speed. It's used in scm_iprin1 when printing the
1254 * code of a closure, in scm_procedure_source, in display_frame when
1255 * generating the source for a stackframe in a backtrace, and in
1256 * display_expression.
1258 * Unmemoizing is not a reliable process. You cannot in general
1259 * expect to get the original source back.
1261 * However, GOOPS currently relies on this for method compilation.
1262 * This ought to change.
1265 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1268 build_binding_list (SCM names
, SCM inits
)
1270 SCM bindings
= SCM_EOL
;
1271 while (!SCM_NULLP (names
))
1273 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1274 bindings
= scm_cons (binding
, bindings
);
1275 names
= SCM_CDR (names
);
1276 inits
= SCM_CDR (inits
);
1282 unmemocopy (SCM x
, SCM env
)
1288 p
= scm_whash_lookup (scm_source_whash
, x
);
1289 switch (SCM_ITAG7 (SCM_CAR (x
)))
1291 case SCM_BIT8(SCM_IM_AND
):
1292 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1294 case SCM_BIT8(SCM_IM_BEGIN
):
1295 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1297 case SCM_BIT8(SCM_IM_CASE
):
1298 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1300 case SCM_BIT8(SCM_IM_COND
):
1301 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1303 case SCM_BIT8 (SCM_IM_DO
):
1305 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1306 * where nx is the name of a local variable, ix is an initializer for
1307 * the local variable, test is the test clause of the do loop, body is
1308 * the body of the do loop and sx are the step clauses for the local
1310 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1313 names
= SCM_CAR (x
);
1315 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1316 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1318 test
= unmemocopy (SCM_CAR (x
), env
);
1320 memoized_body
= SCM_CAR (x
);
1322 steps
= scm_reverse (unmemocopy (x
, env
));
1324 /* build transformed binding list */
1326 while (!SCM_NULLP (names
))
1328 SCM name
= SCM_CAR (names
);
1329 SCM init
= SCM_CAR (inits
);
1330 SCM step
= SCM_CAR (steps
);
1331 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1333 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1335 names
= SCM_CDR (names
);
1336 inits
= SCM_CDR (inits
);
1337 steps
= SCM_CDR (steps
);
1339 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1340 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1342 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1345 case SCM_BIT8(SCM_IM_IF
):
1346 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1348 case SCM_BIT8 (SCM_IM_LET
):
1350 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1351 * where nx is the name of a local variable, ix is an initializer for
1352 * the local variable and by are the body clauses. */
1353 SCM names
, inits
, bindings
;
1356 names
= SCM_CAR (x
);
1358 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1359 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1361 bindings
= build_binding_list (names
, inits
);
1362 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1363 ls
= scm_cons (scm_sym_let
, z
);
1366 case SCM_BIT8 (SCM_IM_LETREC
):
1368 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1369 * where nx is the name of a local variable, ix is an initializer for
1370 * the local variable and by are the body clauses. */
1371 SCM names
, inits
, bindings
;
1374 names
= SCM_CAR (x
);
1375 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1377 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1379 bindings
= build_binding_list (names
, inits
);
1380 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1381 ls
= scm_cons (scm_sym_letrec
, z
);
1384 case SCM_BIT8(SCM_IM_LETSTAR
):
1392 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1395 y
= z
= scm_acons (SCM_CAR (b
),
1397 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1399 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1403 SCM_SETCDR (y
, SCM_EOL
);
1404 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1409 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1411 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1414 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1417 while (SCM_NIMP (b
));
1418 SCM_SETCDR (z
, SCM_EOL
);
1420 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1423 case SCM_BIT8(SCM_IM_OR
):
1424 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1426 case SCM_BIT8(SCM_IM_LAMBDA
):
1428 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1429 ls
= scm_cons (scm_sym_lambda
, z
);
1430 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1432 case SCM_BIT8(SCM_IM_QUOTE
):
1433 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1435 case SCM_BIT8(SCM_IM_SET_X
):
1436 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1438 case SCM_BIT8(SCM_IM_DEFINE
):
1443 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1444 ls
= scm_cons (scm_sym_define
, z
);
1445 if (!SCM_NULLP (env
))
1446 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1451 case SCM_BIT8(SCM_MAKISYM (0)):
1455 switch (SCM_ISYMNUM (z
))
1457 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1458 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1460 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1461 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1463 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1464 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1467 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1468 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1471 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1472 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1475 /* appease the Sun compiler god: */ ;
1479 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1485 while (SCM_CONSP (x
))
1487 SCM form
= SCM_CAR (x
);
1488 if (!SCM_ISYMP (form
))
1490 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1491 SCM_SETCDR (z
, unmemocar (copy
, env
));
1497 if (!SCM_FALSEP (p
))
1498 scm_whash_insert (scm_source_whash
, ls
, p
);
1504 scm_unmemocopy (SCM x
, SCM env
)
1506 if (!SCM_NULLP (env
))
1507 /* Make a copy of the lowest frame to protect it from
1508 modifications by SCM_IM_DEFINE */
1509 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1511 return unmemocopy (x
, env
);
1516 scm_badargsp (SCM formals
, SCM args
)
1518 while (!SCM_NULLP (formals
))
1520 if (!SCM_CONSP (formals
))
1522 if (SCM_NULLP (args
))
1524 formals
= SCM_CDR (formals
);
1525 args
= SCM_CDR (args
);
1527 return !SCM_NULLP (args
) ? 1 : 0;
1532 scm_badformalsp (SCM closure
, int n
)
1534 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1535 while (!SCM_NULLP (formals
))
1537 if (!SCM_CONSP (formals
))
1542 formals
= SCM_CDR (formals
);
1549 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1551 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1552 while (SCM_CONSP (l
))
1554 res
= EVALCAR (l
, env
);
1556 *lloc
= scm_list_1 (res
);
1557 lloc
= SCM_CDRLOC (*lloc
);
1561 scm_wrong_num_args (proc
);
1566 scm_eval_body (SCM code
, SCM env
)
1570 next
= SCM_CDR (code
);
1571 while (!SCM_NULLP (next
))
1573 if (SCM_IMP (SCM_CAR (code
)))
1575 if (SCM_ISYMP (SCM_CAR (code
)))
1577 scm_rec_mutex_lock (&source_mutex
);
1578 /* check for race condition */
1579 if (SCM_ISYMP (SCM_CAR (code
)))
1580 code
= scm_m_expand_body (code
, env
);
1581 scm_rec_mutex_unlock (&source_mutex
);
1586 SCM_XEVAL (SCM_CAR (code
), env
);
1588 next
= SCM_CDR (code
);
1590 return SCM_XEVALCAR (code
, env
);
1597 /* SECTION: This code is specific for the debugging support. One
1598 * branch is read when DEVAL isn't defined, the other when DEVAL is
1604 #define SCM_APPLY scm_apply
1605 #define PREP_APPLY(proc, args)
1607 #define RETURN(x) do { return x; } while (0)
1608 #ifdef STACK_CHECKING
1609 #ifndef NO_CEVAL_STACK_CHECKING
1610 #define EVAL_STACK_CHECKING
1617 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1619 #define SCM_APPLY scm_dapply
1621 #define PREP_APPLY(p, l) \
1622 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1624 #define ENTER_APPLY \
1626 SCM_SET_ARGSREADY (debug);\
1627 if (scm_check_apply_p && SCM_TRAPS_P)\
1628 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1630 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1631 SCM_SET_TRACED_FRAME (debug); \
1633 if (SCM_CHEAPTRAPS_P)\
1635 tmp = scm_make_debugobj (&debug);\
1636 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1641 tmp = scm_make_continuation (&first);\
1643 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1649 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1650 #ifdef STACK_CHECKING
1651 #ifndef EVAL_STACK_CHECKING
1652 #define EVAL_STACK_CHECKING
1656 /* scm_ceval_ptr points to the currently selected evaluator.
1657 * *fixme*: Although efficiency is important here, this state variable
1658 * should probably not be a global. It should be related to the
1663 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1665 /* scm_last_debug_frame contains a pointer to the last debugging
1666 * information stack frame. It is accessed very often from the
1667 * debugging evaluator, so it should probably not be indirectly
1668 * addressed. Better to save and restore it from the current root at
1672 /* scm_debug_eframe_size is the number of slots available for pseudo
1673 * stack frames at each real stack frame.
1676 long scm_debug_eframe_size
;
1678 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1680 long scm_eval_stack
;
1682 scm_t_option scm_eval_opts
[] = {
1683 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1686 scm_t_option scm_debug_opts
[] = {
1687 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1688 "*Flyweight representation of the stack at traps." },
1689 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1690 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1691 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1692 "Record procedure names at definition." },
1693 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1694 "Display backtrace in anti-chronological order." },
1695 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1696 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1697 { SCM_OPTION_INTEGER
, "frames", 3,
1698 "Maximum number of tail-recursive frames in backtrace." },
1699 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1700 "Maximal number of stored backtrace frames." },
1701 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1702 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1703 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1704 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1705 { 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."}
1708 scm_t_option scm_evaluator_trap_table
[] = {
1709 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1710 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1711 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1712 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1713 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1714 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1715 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1718 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1720 "Option interface for the evaluation options. Instead of using\n"
1721 "this procedure directly, use the procedures @code{eval-enable},\n"
1722 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1723 #define FUNC_NAME s_scm_eval_options_interface
1727 ans
= scm_options (setting
,
1731 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1737 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1739 "Option interface for the evaluator trap options.")
1740 #define FUNC_NAME s_scm_evaluator_traps
1744 ans
= scm_options (setting
,
1745 scm_evaluator_trap_table
,
1746 SCM_N_EVALUATOR_TRAPS
,
1748 SCM_RESET_DEBUG_MODE
;
1755 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1757 SCM
*results
= lloc
, res
;
1758 while (SCM_CONSP (l
))
1760 res
= EVALCAR (l
, env
);
1762 *lloc
= scm_list_1 (res
);
1763 lloc
= SCM_CDRLOC (*lloc
);
1767 scm_wrong_num_args (proc
);
1774 /* SECTION: This code is compiled twice.
1778 /* Update the toplevel environment frame ENV so that it refers to the
1779 * current module. */
1780 #define UPDATE_TOPLEVEL_ENV(env) \
1782 SCM p = scm_current_module_lookup_closure (); \
1783 if (p != SCM_CAR(env)) \
1784 env = scm_top_level_env (p); \
1788 /* This is the evaluator. Like any real monster, it has three heads:
1790 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1791 * version. Both are implemented using a common code base, using the
1792 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1793 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1794 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1795 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1796 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1797 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1798 * are enclosed within #ifdef DEVAL ... #endif.
1800 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1801 * take two input parameters, x and env: x is a single expression to be
1802 * evalutated. env is the environment in which bindings are searched.
1804 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1805 * is a single expression, it is necessarily in a tail position. If x is just
1806 * a call to another function like in the expression (foo exp1 exp2 ...), the
1807 * realization of that call therefore _must_not_ increase stack usage (the
1808 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1809 * making extensive use of 'goto' statements within the evaluator: The gotos
1810 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1811 * that SCM_CEVAL was already using. If, however, x represents some form that
1812 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1813 * then recursive calls to SCM_CEVAL are performed for all but the last
1814 * expression of that sequence. */
1818 scm_ceval (SCM x
, SCM env
)
1824 scm_deval (SCM x
, SCM env
)
1829 SCM_CEVAL (SCM x
, SCM env
)
1833 scm_t_debug_frame debug
;
1834 scm_t_debug_info
*debug_info_end
;
1835 debug
.prev
= scm_last_debug_frame
;
1838 * The debug.vect contains twice as much scm_t_debug_info frames as the
1839 * user has specified with (debug-set! frames <n>).
1841 * Even frames are eval frames, odd frames are apply frames.
1843 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1844 * sizeof (scm_t_debug_info
));
1845 debug
.info
= debug
.vect
;
1846 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1847 scm_last_debug_frame
= &debug
;
1849 #ifdef EVAL_STACK_CHECKING
1850 if (scm_stack_checking_enabled_p
1851 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1854 debug
.info
->e
.exp
= x
;
1855 debug
.info
->e
.env
= env
;
1857 scm_report_stack_overflow ();
1867 SCM_CLEAR_ARGSREADY (debug
);
1868 if (SCM_OVERFLOWP (debug
))
1871 * In theory, this should be the only place where it is necessary to
1872 * check for space in debug.vect since both eval frames and
1873 * available space are even.
1875 * For this to be the case, however, it is necessary that primitive
1876 * special forms which jump back to `loop', `begin' or some similar
1877 * label call PREP_APPLY.
1879 else if (++debug
.info
>= debug_info_end
)
1881 SCM_SET_OVERFLOW (debug
);
1886 debug
.info
->e
.exp
= x
;
1887 debug
.info
->e
.env
= env
;
1888 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1890 if (SCM_ENTER_FRAME_P
1891 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1894 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1895 SCM_SET_TAILREC (debug
);
1896 if (SCM_CHEAPTRAPS_P
)
1897 stackrep
= scm_make_debugobj (&debug
);
1901 SCM val
= scm_make_continuation (&first
);
1911 /* This gives the possibility for the debugger to
1912 modify the source expression before evaluation. */
1917 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1918 scm_sym_enter_frame
,
1921 scm_unmemocopy (x
, env
));
1928 switch (SCM_TYP7 (x
))
1930 case scm_tc7_symbol
:
1931 /* Only happens when called at top level. */
1932 x
= scm_cons (x
, SCM_UNDEFINED
);
1933 RETURN (*scm_lookupcar (x
, env
, 1));
1935 case SCM_BIT8 (SCM_IM_AND
):
1937 while (!SCM_NULLP (SCM_CDR (x
)))
1939 SCM test_result
= EVALCAR (x
, env
);
1940 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1941 RETURN (SCM_BOOL_F
);
1945 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1948 case SCM_BIT8 (SCM_IM_BEGIN
):
1951 RETURN (SCM_UNSPECIFIED
);
1953 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1956 /* If we are on toplevel with a lookup closure, we need to sync
1957 with the current module. */
1958 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1960 UPDATE_TOPLEVEL_ENV (env
);
1961 while (!SCM_NULLP (SCM_CDR (x
)))
1964 UPDATE_TOPLEVEL_ENV (env
);
1970 goto nontoplevel_begin
;
1973 while (!SCM_NULLP (SCM_CDR (x
)))
1975 SCM form
= SCM_CAR (x
);
1978 if (SCM_ISYMP (form
))
1980 scm_rec_mutex_lock (&source_mutex
);
1981 /* check for race condition */
1982 if (SCM_ISYMP (SCM_CAR (x
)))
1983 x
= scm_m_expand_body (x
, env
);
1984 scm_rec_mutex_unlock (&source_mutex
);
1985 goto nontoplevel_begin
;
1988 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
1991 SCM_CEVAL (form
, env
);
1997 /* scm_eval last form in list */
1998 SCM last_form
= SCM_CAR (x
);
2000 if (SCM_CONSP (last_form
))
2002 /* This is by far the most frequent case. */
2004 goto loop
; /* tail recurse */
2006 else if (SCM_IMP (last_form
))
2007 RETURN (SCM_EVALIM (last_form
, env
));
2008 else if (SCM_VARIABLEP (last_form
))
2009 RETURN (SCM_VARIABLE_REF (last_form
));
2010 else if (SCM_SYMBOLP (last_form
))
2011 RETURN (*scm_lookupcar (x
, env
, 1));
2017 case SCM_BIT8 (SCM_IM_CASE
):
2020 SCM key
= EVALCAR (x
, env
);
2022 while (!SCM_NULLP (x
))
2024 SCM clause
= SCM_CAR (x
);
2025 SCM labels
= SCM_CAR (clause
);
2026 if (SCM_EQ_P (labels
, scm_sym_else
))
2028 x
= SCM_CDR (clause
);
2029 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2032 while (!SCM_NULLP (labels
))
2034 SCM label
= SCM_CAR (labels
);
2035 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2037 x
= SCM_CDR (clause
);
2038 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2041 labels
= SCM_CDR (labels
);
2046 RETURN (SCM_UNSPECIFIED
);
2049 case SCM_BIT8 (SCM_IM_COND
):
2051 while (!SCM_NULLP (x
))
2053 SCM clause
= SCM_CAR (x
);
2054 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2056 x
= SCM_CDR (clause
);
2057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2062 arg1
= EVALCAR (clause
, env
);
2063 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2065 x
= SCM_CDR (clause
);
2068 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2070 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2076 proc
= EVALCAR (proc
, env
);
2077 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2078 PREP_APPLY (proc
, scm_list_1 (arg1
));
2080 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2081 goto umwrongnumargs
;
2089 RETURN (SCM_UNSPECIFIED
);
2092 case SCM_BIT8 (SCM_IM_DO
):
2095 /* Compute the initialization values and the initial environment. */
2096 SCM init_forms
= SCM_CADR (x
);
2097 SCM init_values
= SCM_EOL
;
2098 while (!SCM_NULLP (init_forms
))
2100 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2101 init_forms
= SCM_CDR (init_forms
);
2103 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2107 SCM test_form
= SCM_CAR (x
);
2108 SCM body_forms
= SCM_CADR (x
);
2109 SCM step_forms
= SCM_CDDR (x
);
2111 SCM test_result
= EVALCAR (test_form
, env
);
2113 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2116 /* Evaluate body forms. */
2118 for (temp_forms
= body_forms
;
2119 !SCM_NULLP (temp_forms
);
2120 temp_forms
= SCM_CDR (temp_forms
))
2122 SCM form
= SCM_CAR (temp_forms
);
2123 /* Dirk:FIXME: We only need to eval forms, that may have a
2124 * side effect here. This is only true for forms that start
2125 * with a pair. All others are just constants. However,
2126 * since in the common case there is no constant expression
2127 * in a body of a do form, we just check for immediates here
2128 * and have SCM_CEVAL take care of other cases. In the long
2129 * run it would make sense to get rid of this test and have
2130 * the macro transformer of 'do' eliminate all forms that
2131 * have no sideeffect. */
2132 if (!SCM_IMP (form
))
2133 SCM_CEVAL (form
, env
);
2138 /* Evaluate the step expressions. */
2140 SCM step_values
= SCM_EOL
;
2141 for (temp_forms
= step_forms
;
2142 !SCM_NULLP (temp_forms
);
2143 temp_forms
= SCM_CDR (temp_forms
))
2145 SCM value
= EVALCAR (temp_forms
, env
);
2146 step_values
= scm_cons (value
, step_values
);
2148 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2151 test_result
= EVALCAR (test_form
, env
);
2156 RETURN (SCM_UNSPECIFIED
);
2157 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2158 goto nontoplevel_begin
;
2161 case SCM_BIT8 (SCM_IM_IF
):
2164 SCM test_result
= EVALCAR (x
, env
);
2165 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2171 RETURN (SCM_UNSPECIFIED
);
2174 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2178 case SCM_BIT8 (SCM_IM_LET
):
2181 SCM init_forms
= SCM_CADR (x
);
2182 SCM init_values
= SCM_EOL
;
2185 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2186 init_forms
= SCM_CDR (init_forms
);
2188 while (!SCM_NULLP (init_forms
));
2189 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2192 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2193 goto nontoplevel_begin
;
2196 case SCM_BIT8 (SCM_IM_LETREC
):
2198 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2201 SCM init_forms
= SCM_CAR (x
);
2202 SCM init_values
= SCM_EOL
;
2205 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2206 init_forms
= SCM_CDR (init_forms
);
2208 while (!SCM_NULLP (init_forms
));
2209 SCM_SETCDR (SCM_CAR (env
), init_values
);
2212 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2213 goto nontoplevel_begin
;
2216 case SCM_BIT8 (SCM_IM_LETSTAR
):
2219 SCM bindings
= SCM_CAR (x
);
2220 if (SCM_NULLP (bindings
))
2221 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2226 SCM name
= SCM_CAR (bindings
);
2227 SCM init
= SCM_CDR (bindings
);
2228 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2229 bindings
= SCM_CDR (init
);
2231 while (!SCM_NULLP (bindings
));
2235 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2236 goto nontoplevel_begin
;
2239 case SCM_BIT8 (SCM_IM_OR
):
2241 while (!SCM_NULLP (SCM_CDR (x
)))
2243 SCM val
= EVALCAR (x
, env
);
2244 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2249 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2253 case SCM_BIT8 (SCM_IM_LAMBDA
):
2254 RETURN (scm_closure (SCM_CDR (x
), env
));
2257 case SCM_BIT8 (SCM_IM_QUOTE
):
2258 RETURN (SCM_CADR (x
));
2261 case SCM_BIT8 (SCM_IM_SET_X
):
2265 SCM variable
= SCM_CAR (x
);
2266 if (SCM_ILOCP (variable
))
2267 location
= scm_ilookup (variable
, env
);
2268 else if (SCM_VARIABLEP (variable
))
2269 location
= SCM_VARIABLE_LOC (variable
);
2270 else /* (SCM_SYMBOLP (variable)) is known to be true */
2271 location
= scm_lookupcar (x
, env
, 1);
2273 *location
= EVALCAR (x
, env
);
2275 RETURN (SCM_UNSPECIFIED
);
2278 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2279 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2282 /* new syntactic forms go here. */
2283 case SCM_BIT8 (SCM_MAKISYM (0)):
2285 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2286 switch (SCM_ISYMNUM (proc
))
2290 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2292 proc
= EVALCAR (proc
, env
);
2293 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2294 if (SCM_CLOSUREP (proc
))
2296 PREP_APPLY (proc
, SCM_EOL
);
2297 arg1
= SCM_CDDR (x
);
2298 arg1
= EVALCAR (arg1
, env
);
2300 /* Go here to tail-call a closure. PROC is the closure
2301 and ARG1 is the list of arguments. Do not forget to
2304 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2306 debug
.info
->a
.args
= arg1
;
2308 if (scm_badargsp (formals
, arg1
))
2309 scm_wrong_num_args (proc
);
2311 /* Copy argument list */
2312 if (SCM_NULL_OR_NIL_P (arg1
))
2313 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2316 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2318 arg1
= SCM_CDR (arg1
);
2319 while (!SCM_NULL_OR_NIL_P (arg1
))
2321 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2322 SCM_SETCDR (tail
, new_tail
);
2324 arg1
= SCM_CDR (arg1
);
2326 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2329 x
= SCM_CLOSURE_BODY (proc
);
2330 goto nontoplevel_begin
;
2340 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2343 SCM val
= scm_make_continuation (&first
);
2351 proc
= scm_eval_car (proc
, env
);
2352 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2353 PREP_APPLY (proc
, scm_list_1 (arg1
));
2355 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2356 goto umwrongnumargs
;
2362 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2363 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2366 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2367 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2370 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2372 /* If not done yet, evaluate the operand forms. The result is a
2373 * list of arguments stored in arg1, which is used to perform the
2374 * function dispatch. */
2375 SCM operand_forms
= SCM_CADR (x
);
2376 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2377 if (SCM_ILOCP (operand_forms
))
2378 arg1
= *scm_ilookup (operand_forms
, env
);
2379 else if (SCM_VARIABLEP (operand_forms
))
2380 arg1
= SCM_VARIABLE_REF (operand_forms
);
2381 else if (!SCM_CONSP (operand_forms
))
2382 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2385 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2386 operand_forms
= SCM_CDR (operand_forms
);
2387 while (!SCM_NULLP (operand_forms
))
2389 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2390 SCM_SETCDR (tail
, new_tail
);
2392 operand_forms
= SCM_CDR (operand_forms
);
2397 /* The type dispatch code is duplicated below
2398 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2399 * cuts down execution time for type dispatch to 50%. */
2400 type_dispatch
: /* inputs: x, arg1 */
2401 /* Type dispatch means to determine from the types of the function
2402 * arguments (i. e. the 'signature' of the call), which method from
2403 * a generic function is to be called. This process of selecting
2404 * the right method takes some time. To speed it up, guile uses
2405 * caching: Together with the macro call to dispatch the signatures
2406 * of some previous calls to that generic function from the same
2407 * place are stored (in the code!) in a cache that we call the
2408 * 'method cache'. This is done since it is likely, that
2409 * consecutive calls to dispatch from that position in the code will
2410 * have the same signature. Thus, the type dispatch works as
2411 * follows: First, determine a hash value from the signature of the
2412 * actual arguments. Second, use this hash value as an index to
2413 * find that same signature in the method cache stored at this
2414 * position in the code. If found, you have also found the
2415 * corresponding method that belongs to that signature. If the
2416 * signature is not found in the method cache, you have to perform a
2417 * full search over all signatures stored with the generic
2420 unsigned long int specializers
;
2421 unsigned long int hash_value
;
2422 unsigned long int cache_end_pos
;
2423 unsigned long int mask
;
2427 SCM z
= SCM_CDDR (x
);
2428 SCM tmp
= SCM_CADR (z
);
2429 specializers
= SCM_INUM (SCM_CAR (z
));
2431 /* Compute a hash value for searching the method cache. There
2432 * are two variants for computing the hash value, a (rather)
2433 * complicated one, and a simple one. For the complicated one
2434 * explained below, tmp holds a number that is used in the
2436 if (SCM_INUMP (tmp
))
2438 /* Use the signature of the actual arguments to determine
2439 * the hash value. This is done as follows: Each class has
2440 * an array of random numbers, that are determined when the
2441 * class is created. The integer 'hashset' is an index into
2442 * that array of random numbers. Now, from all classes that
2443 * are part of the signature of the actual arguments, the
2444 * random numbers at index 'hashset' are taken and summed
2445 * up, giving the hash value. The value of 'hashset' is
2446 * stored at the call to dispatch. This allows to have
2447 * different 'formulas' for calculating the hash value at
2448 * different places where dispatch is called. This allows
2449 * to optimize the hash formula at every individual place
2450 * where dispatch is called, such that hopefully the hash
2451 * value that is computed will directly point to the right
2452 * method in the method cache. */
2453 unsigned long int hashset
= SCM_INUM (tmp
);
2454 unsigned long int counter
= specializers
+ 1;
2457 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2459 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2460 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2461 tmp_arg
= SCM_CDR (tmp_arg
);
2465 method_cache
= SCM_CADR (z
);
2466 mask
= SCM_INUM (SCM_CAR (z
));
2468 cache_end_pos
= hash_value
;
2472 /* This method of determining the hash value is much
2473 * simpler: Set the hash value to zero and just perform a
2474 * linear search through the method cache. */
2476 mask
= (unsigned long int) ((long) -1);
2478 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2483 /* Search the method cache for a method with a matching
2484 * signature. Start the search at position 'hash_value'. The
2485 * hashing implementation uses linear probing for conflict
2486 * resolution, that is, if the signature in question is not
2487 * found at the starting index in the hash table, the next table
2488 * entry is tried, and so on, until in the worst case the whole
2489 * cache has been searched, but still the signature has not been
2494 SCM args
= arg1
; /* list of arguments */
2495 z
= SCM_VELTS (method_cache
)[hash_value
];
2496 while (!SCM_NULLP (args
))
2498 /* More arguments than specifiers => CLASS != ENV */
2499 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2500 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2502 args
= SCM_CDR (args
);
2505 /* Fewer arguments than specifiers => CAR != ENV */
2506 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2509 hash_value
= (hash_value
+ 1) & mask
;
2510 } while (hash_value
!= cache_end_pos
);
2512 /* No appropriate method was found in the cache. */
2513 z
= scm_memoize_method (x
, arg1
);
2515 apply_cmethod
: /* inputs: z, arg1 */
2517 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2518 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2519 x
= SCM_CMETHOD_BODY (z
);
2520 goto nontoplevel_begin
;
2526 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2529 SCM instance
= EVALCAR (x
, env
);
2530 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2531 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2535 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2538 SCM instance
= EVALCAR (x
, env
);
2539 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2540 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2541 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2542 RETURN (SCM_UNSPECIFIED
);
2546 #if SCM_ENABLE_ELISP
2548 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2550 SCM test_form
= SCM_CDR (x
);
2551 x
= SCM_CDR (test_form
);
2552 while (!SCM_NULL_OR_NIL_P (x
))
2554 SCM test_result
= EVALCAR (test_form
, env
);
2555 if (!(SCM_FALSEP (test_result
)
2556 || SCM_NULL_OR_NIL_P (test_result
)))
2558 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2559 RETURN (test_result
);
2560 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2565 test_form
= SCM_CDR (x
);
2566 x
= SCM_CDR (test_form
);
2570 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2574 #endif /* SCM_ENABLE_ELISP */
2576 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2578 SCM vars
, exps
, vals
;
2581 vars
= SCM_CAAR (x
);
2582 exps
= SCM_CDAR (x
);
2586 while (SCM_NIMP (exps
))
2588 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2589 exps
= SCM_CDR (exps
);
2592 scm_swap_bindings (vars
, vals
);
2593 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2595 /* Ignore all but the last evaluation result. */
2596 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2598 if (SCM_CONSP (SCM_CAR (x
)))
2599 SCM_CEVAL (SCM_CAR (x
), env
);
2601 proc
= EVALCAR (x
, env
);
2603 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2604 scm_swap_bindings (vars
, vals
);
2610 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2613 x
= EVALCAR (proc
, env
);
2614 proc
= SCM_CDR (proc
);
2615 proc
= EVALCAR (proc
, env
);
2616 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2617 if (SCM_VALUESP (arg1
))
2618 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2620 arg1
= scm_list_1 (arg1
);
2621 if (SCM_CLOSUREP (proc
))
2623 PREP_APPLY (proc
, arg1
);
2626 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2637 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2638 case scm_tc7_vector
:
2642 case scm_tc7_byvect
:
2649 #if SCM_SIZEOF_LONG_LONG != 0
2650 case scm_tc7_llvect
:
2653 case scm_tc7_string
:
2655 case scm_tcs_closures
:
2659 case scm_tcs_struct
:
2662 case scm_tc7_variable
:
2663 RETURN (SCM_VARIABLE_REF(x
));
2665 case SCM_BIT8(SCM_ILOC00
):
2666 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2667 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2670 case scm_tcs_cons_nimcar
:
2671 if (SCM_SYMBOLP (SCM_CAR (x
)))
2673 SCM orig_sym
= SCM_CAR (x
);
2675 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2676 if (location
== NULL
)
2678 /* we have lost the race, start again. */
2686 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2690 if (SCM_MACROP (proc
))
2692 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2694 handle_a_macro
: /* inputs: x, env, proc */
2696 /* Set a flag during macro expansion so that macro
2697 application frames can be deleted from the backtrace. */
2698 SCM_SET_MACROEXP (debug
);
2700 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2701 scm_cons (env
, scm_listofnull
));
2704 SCM_CLEAR_MACROEXP (debug
);
2706 switch (SCM_MACRO_TYPE (proc
))
2709 if (scm_ilength (arg1
) <= 0)
2710 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2712 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2715 SCM_SETCAR (x
, SCM_CAR (arg1
));
2716 SCM_SETCDR (x
, SCM_CDR (arg1
));
2720 /* Prevent memoizing of debug info expression. */
2721 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2726 SCM_SETCAR (x
, SCM_CAR (arg1
));
2727 SCM_SETCDR (x
, SCM_CDR (arg1
));
2729 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2731 #if SCM_ENABLE_DEPRECATED == 1
2736 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2748 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2749 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2752 if (SCM_CLOSUREP (proc
))
2754 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2755 SCM args
= SCM_CDR (x
);
2756 while (!SCM_NULLP (formals
))
2758 if (!SCM_CONSP (formals
))
2761 goto umwrongnumargs
;
2762 formals
= SCM_CDR (formals
);
2763 args
= SCM_CDR (args
);
2765 if (!SCM_NULLP (args
))
2766 goto umwrongnumargs
;
2768 else if (SCM_MACROP (proc
))
2769 goto handle_a_macro
;
2773 evapply
: /* inputs: x, proc */
2774 PREP_APPLY (proc
, SCM_EOL
);
2775 if (SCM_NULLP (SCM_CDR (x
))) {
2778 switch (SCM_TYP7 (proc
))
2779 { /* no arguments given */
2780 case scm_tc7_subr_0
:
2781 RETURN (SCM_SUBRF (proc
) ());
2782 case scm_tc7_subr_1o
:
2783 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2785 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2786 case scm_tc7_rpsubr
:
2787 RETURN (SCM_BOOL_T
);
2789 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2791 if (!SCM_SMOB_APPLICABLE_P (proc
))
2793 RETURN (SCM_SMOB_APPLY_0 (proc
));
2796 proc
= SCM_CCLO_SUBR (proc
);
2798 debug
.info
->a
.proc
= proc
;
2799 debug
.info
->a
.args
= scm_list_1 (arg1
);
2803 proc
= SCM_PROCEDURE (proc
);
2805 debug
.info
->a
.proc
= proc
;
2807 if (!SCM_CLOSUREP (proc
))
2809 if (scm_badformalsp (proc
, 0))
2810 goto umwrongnumargs
;
2811 case scm_tcs_closures
:
2812 x
= SCM_CLOSURE_BODY (proc
);
2813 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2814 goto nontoplevel_begin
;
2815 case scm_tcs_struct
:
2816 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2818 x
= SCM_ENTITY_PROCEDURE (proc
);
2822 else if (!SCM_I_OPERATORP (proc
))
2827 proc
= (SCM_I_ENTITYP (proc
)
2828 ? SCM_ENTITY_PROCEDURE (proc
)
2829 : SCM_OPERATOR_PROCEDURE (proc
));
2831 debug
.info
->a
.proc
= proc
;
2832 debug
.info
->a
.args
= scm_list_1 (arg1
);
2834 if (SCM_NIMP (proc
))
2839 case scm_tc7_subr_1
:
2840 case scm_tc7_subr_2
:
2841 case scm_tc7_subr_2o
:
2843 case scm_tc7_subr_3
:
2844 case scm_tc7_lsubr_2
:
2847 scm_wrong_num_args (proc
);
2849 /* handle macros here */
2854 /* must handle macros by here */
2857 arg1
= EVALCAR (x
, env
);
2859 scm_wrong_num_args (proc
);
2861 debug
.info
->a
.args
= scm_list_1 (arg1
);
2869 evap1
: /* inputs: proc, arg1 */
2870 switch (SCM_TYP7 (proc
))
2871 { /* have one argument in arg1 */
2872 case scm_tc7_subr_2o
:
2873 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2874 case scm_tc7_subr_1
:
2875 case scm_tc7_subr_1o
:
2876 RETURN (SCM_SUBRF (proc
) (arg1
));
2878 if (SCM_SUBRF (proc
))
2880 if (SCM_INUMP (arg1
))
2882 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2884 else if (SCM_REALP (arg1
))
2886 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2888 else if (SCM_BIGP (arg1
))
2890 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2892 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2893 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2895 proc
= SCM_SNAME (proc
);
2897 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2898 while ('c' != *--chrs
)
2900 SCM_ASSERT (SCM_CONSP (arg1
),
2901 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2902 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2906 case scm_tc7_rpsubr
:
2907 RETURN (SCM_BOOL_T
);
2909 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2912 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2914 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2917 if (!SCM_SMOB_APPLICABLE_P (proc
))
2919 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2923 proc
= SCM_CCLO_SUBR (proc
);
2925 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2926 debug
.info
->a
.proc
= proc
;
2930 proc
= SCM_PROCEDURE (proc
);
2932 debug
.info
->a
.proc
= proc
;
2934 if (!SCM_CLOSUREP (proc
))
2936 if (scm_badformalsp (proc
, 1))
2937 goto umwrongnumargs
;
2938 case scm_tcs_closures
:
2940 x
= SCM_CLOSURE_BODY (proc
);
2942 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2944 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2946 goto nontoplevel_begin
;
2947 case scm_tcs_struct
:
2948 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2950 x
= SCM_ENTITY_PROCEDURE (proc
);
2952 arg1
= debug
.info
->a
.args
;
2954 arg1
= scm_list_1 (arg1
);
2958 else if (!SCM_I_OPERATORP (proc
))
2964 proc
= (SCM_I_ENTITYP (proc
)
2965 ? SCM_ENTITY_PROCEDURE (proc
)
2966 : SCM_OPERATOR_PROCEDURE (proc
));
2968 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2969 debug
.info
->a
.proc
= proc
;
2971 if (SCM_NIMP (proc
))
2976 case scm_tc7_subr_2
:
2977 case scm_tc7_subr_0
:
2978 case scm_tc7_subr_3
:
2979 case scm_tc7_lsubr_2
:
2980 scm_wrong_num_args (proc
);
2986 arg2
= EVALCAR (x
, env
);
2988 scm_wrong_num_args (proc
);
2990 { /* have two or more arguments */
2992 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
2995 if (SCM_NULLP (x
)) {
2998 switch (SCM_TYP7 (proc
))
2999 { /* have two arguments */
3000 case scm_tc7_subr_2
:
3001 case scm_tc7_subr_2o
:
3002 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3005 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3007 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3009 case scm_tc7_lsubr_2
:
3010 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3011 case scm_tc7_rpsubr
:
3013 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3015 if (!SCM_SMOB_APPLICABLE_P (proc
))
3017 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3021 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3022 scm_cons (proc
, debug
.info
->a
.args
),
3025 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3026 scm_cons2 (proc
, arg1
,
3033 case scm_tcs_struct
:
3034 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3036 x
= SCM_ENTITY_PROCEDURE (proc
);
3038 arg1
= debug
.info
->a
.args
;
3040 arg1
= scm_list_2 (arg1
, arg2
);
3044 else if (!SCM_I_OPERATORP (proc
))
3050 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3051 ? SCM_ENTITY_PROCEDURE (proc
)
3052 : SCM_OPERATOR_PROCEDURE (proc
),
3053 scm_cons (proc
, debug
.info
->a
.args
),
3056 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3057 ? SCM_ENTITY_PROCEDURE (proc
)
3058 : SCM_OPERATOR_PROCEDURE (proc
),
3059 scm_cons2 (proc
, arg1
,
3067 case scm_tc7_subr_0
:
3069 case scm_tc7_subr_1o
:
3070 case scm_tc7_subr_1
:
3071 case scm_tc7_subr_3
:
3072 scm_wrong_num_args (proc
);
3076 proc
= SCM_PROCEDURE (proc
);
3078 debug
.info
->a
.proc
= proc
;
3080 if (!SCM_CLOSUREP (proc
))
3082 if (scm_badformalsp (proc
, 2))
3083 goto umwrongnumargs
;
3084 case scm_tcs_closures
:
3087 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3091 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3092 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3094 x
= SCM_CLOSURE_BODY (proc
);
3095 goto nontoplevel_begin
;
3099 scm_wrong_num_args (proc
);
3101 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3102 deval_args (x
, env
, proc
,
3103 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3107 switch (SCM_TYP7 (proc
))
3108 { /* have 3 or more arguments */
3110 case scm_tc7_subr_3
:
3111 if (!SCM_NULLP (SCM_CDR (x
)))
3112 scm_wrong_num_args (proc
);
3114 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3115 SCM_CADDR (debug
.info
->a
.args
)));
3117 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3118 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3121 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3122 arg2
= SCM_CDR (arg2
);
3124 while (SCM_NIMP (arg2
));
3126 case scm_tc7_rpsubr
:
3127 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3128 RETURN (SCM_BOOL_F
);
3129 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3132 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3133 RETURN (SCM_BOOL_F
);
3134 arg2
= SCM_CAR (arg1
);
3135 arg1
= SCM_CDR (arg1
);
3137 while (SCM_NIMP (arg1
));
3138 RETURN (SCM_BOOL_T
);
3139 case scm_tc7_lsubr_2
:
3140 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3141 SCM_CDDR (debug
.info
->a
.args
)));
3143 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3145 if (!SCM_SMOB_APPLICABLE_P (proc
))
3147 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3148 SCM_CDDR (debug
.info
->a
.args
)));
3152 proc
= SCM_PROCEDURE (proc
);
3153 debug
.info
->a
.proc
= proc
;
3154 if (!SCM_CLOSUREP (proc
))
3156 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3157 goto umwrongnumargs
;
3158 case scm_tcs_closures
:
3159 SCM_SET_ARGSREADY (debug
);
3160 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3163 x
= SCM_CLOSURE_BODY (proc
);
3164 goto nontoplevel_begin
;
3166 case scm_tc7_subr_3
:
3167 if (!SCM_NULLP (SCM_CDR (x
)))
3168 scm_wrong_num_args (proc
);
3170 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3172 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3175 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3178 while (SCM_NIMP (x
));
3180 case scm_tc7_rpsubr
:
3181 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3182 RETURN (SCM_BOOL_F
);
3185 arg1
= EVALCAR (x
, env
);
3186 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3187 RETURN (SCM_BOOL_F
);
3191 while (SCM_NIMP (x
));
3192 RETURN (SCM_BOOL_T
);
3193 case scm_tc7_lsubr_2
:
3194 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3196 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3198 scm_eval_args (x
, env
, proc
))));
3200 if (!SCM_SMOB_APPLICABLE_P (proc
))
3202 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3203 scm_eval_args (x
, env
, proc
)));
3207 proc
= SCM_PROCEDURE (proc
);
3208 if (!SCM_CLOSUREP (proc
))
3211 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3212 if (SCM_NULLP (formals
)
3213 || (SCM_CONSP (formals
)
3214 && (SCM_NULLP (SCM_CDR (formals
))
3215 || (SCM_CONSP (SCM_CDR (formals
))
3216 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3217 goto umwrongnumargs
;
3219 case scm_tcs_closures
:
3221 SCM_SET_ARGSREADY (debug
);
3223 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3226 scm_eval_args (x
, env
, proc
)),
3228 x
= SCM_CLOSURE_BODY (proc
);
3229 goto nontoplevel_begin
;
3231 case scm_tcs_struct
:
3232 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3235 arg1
= debug
.info
->a
.args
;
3237 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3239 x
= SCM_ENTITY_PROCEDURE (proc
);
3242 else if (!SCM_I_OPERATORP (proc
))
3246 case scm_tc7_subr_2
:
3247 case scm_tc7_subr_1o
:
3248 case scm_tc7_subr_2o
:
3249 case scm_tc7_subr_0
:
3251 case scm_tc7_subr_1
:
3252 scm_wrong_num_args (proc
);
3260 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3261 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3263 SCM_CLEAR_TRACED_FRAME (debug
);
3264 if (SCM_CHEAPTRAPS_P
)
3265 arg1
= scm_make_debugobj (&debug
);
3269 SCM val
= scm_make_continuation (&first
);
3280 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3284 scm_last_debug_frame
= debug
.prev
;
3290 /* SECTION: This code is compiled once.
3296 /* Simple procedure calls
3300 scm_call_0 (SCM proc
)
3302 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3306 scm_call_1 (SCM proc
, SCM arg1
)
3308 return scm_apply (proc
, arg1
, scm_listofnull
);
3312 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3314 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3318 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3320 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3324 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3326 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3327 scm_cons (arg4
, scm_listofnull
)));
3330 /* Simple procedure applies
3334 scm_apply_0 (SCM proc
, SCM args
)
3336 return scm_apply (proc
, args
, SCM_EOL
);
3340 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3342 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3346 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3348 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3352 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3354 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3358 /* This code processes the arguments to apply:
3360 (apply PROC ARG1 ... ARGS)
3362 Given a list (ARG1 ... ARGS), this function conses the ARG1
3363 ... arguments onto the front of ARGS, and returns the resulting
3364 list. Note that ARGS is a list; thus, the argument to this
3365 function is a list whose last element is a list.
3367 Apply calls this function, and applies PROC to the elements of the
3368 result. apply:nconc2last takes care of building the list of
3369 arguments, given (ARG1 ... ARGS).
3371 Rather than do new consing, apply:nconc2last destroys its argument.
3372 On that topic, this code came into my care with the following
3373 beautifully cryptic comment on that topic: "This will only screw
3374 you if you do (scm_apply scm_apply '( ... ))" If you know what
3375 they're referring to, send me a patch to this comment. */
3377 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3379 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3380 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3381 "@var{args}, and returns the resulting list. Note that\n"
3382 "@var{args} is a list; thus, the argument to this function is\n"
3383 "a list whose last element is a list.\n"
3384 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3385 "destroys its argument, so use with care.")
3386 #define FUNC_NAME s_scm_nconc2last
3389 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3391 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3392 SCM_NULL_OR_NIL_P, but not
3393 needed in 99.99% of cases,
3394 and it could seriously hurt
3395 performance. - Neil */
3396 lloc
= SCM_CDRLOC (*lloc
);
3397 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3398 *lloc
= SCM_CAR (*lloc
);
3406 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3407 * It is compiled twice.
3412 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3418 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3423 /* Apply a function to a list of arguments.
3425 This function is exported to the Scheme level as taking two
3426 required arguments and a tail argument, as if it were:
3427 (lambda (proc arg1 . args) ...)
3428 Thus, if you just have a list of arguments to pass to a procedure,
3429 pass the list as ARG1, and '() for ARGS. If you have some fixed
3430 args, pass the first as ARG1, then cons any remaining fixed args
3431 onto the front of your argument list, and pass that as ARGS. */
3434 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3437 scm_t_debug_frame debug
;
3438 scm_t_debug_info debug_vect_body
;
3439 debug
.prev
= scm_last_debug_frame
;
3440 debug
.status
= SCM_APPLYFRAME
;
3441 debug
.vect
= &debug_vect_body
;
3442 debug
.vect
[0].a
.proc
= proc
;
3443 debug
.vect
[0].a
.args
= SCM_EOL
;
3444 scm_last_debug_frame
= &debug
;
3447 return scm_dapply (proc
, arg1
, args
);
3450 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3452 /* If ARGS is the empty list, then we're calling apply with only two
3453 arguments --- ARG1 is the list of arguments for PROC. Whatever
3454 the case, futz with things so that ARG1 is the first argument to
3455 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3458 Setting the debug apply frame args this way is pretty messy.
3459 Perhaps we should store arg1 and args directly in the frame as
3460 received, and let scm_frame_arguments unpack them, because that's
3461 a relatively rare operation. This works for now; if the Guile
3462 developer archives are still around, see Mikael's post of
3464 if (SCM_NULLP (args
))
3466 if (SCM_NULLP (arg1
))
3468 arg1
= SCM_UNDEFINED
;
3470 debug
.vect
[0].a
.args
= SCM_EOL
;
3476 debug
.vect
[0].a
.args
= arg1
;
3478 args
= SCM_CDR (arg1
);
3479 arg1
= SCM_CAR (arg1
);
3484 args
= scm_nconc2last (args
);
3486 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3490 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3493 if (SCM_CHEAPTRAPS_P
)
3494 tmp
= scm_make_debugobj (&debug
);
3499 tmp
= scm_make_continuation (&first
);
3504 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3511 switch (SCM_TYP7 (proc
))
3513 case scm_tc7_subr_2o
:
3514 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3515 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3516 case scm_tc7_subr_2
:
3517 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3518 scm_wrong_num_args (proc
);
3519 args
= SCM_CAR (args
);
3520 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3521 case scm_tc7_subr_0
:
3522 if (!SCM_UNBNDP (arg1
))
3523 scm_wrong_num_args (proc
);
3525 RETURN (SCM_SUBRF (proc
) ());
3526 case scm_tc7_subr_1
:
3527 if (SCM_UNBNDP (arg1
))
3528 scm_wrong_num_args (proc
);
3529 case scm_tc7_subr_1o
:
3530 if (!SCM_NULLP (args
))
3531 scm_wrong_num_args (proc
);
3533 RETURN (SCM_SUBRF (proc
) (arg1
));
3535 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3536 scm_wrong_num_args (proc
);
3537 if (SCM_SUBRF (proc
))
3539 if (SCM_INUMP (arg1
))
3541 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3543 else if (SCM_REALP (arg1
))
3545 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3547 else if (SCM_BIGP (arg1
))
3548 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3549 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3550 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3552 proc
= SCM_SNAME (proc
);
3554 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3555 while ('c' != *--chrs
)
3557 SCM_ASSERT (SCM_CONSP (arg1
),
3558 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3559 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3563 case scm_tc7_subr_3
:
3564 if (SCM_NULLP (args
)
3565 || SCM_NULLP (SCM_CDR (args
))
3566 || !SCM_NULLP (SCM_CDDR (args
)))
3567 scm_wrong_num_args (proc
);
3569 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3572 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3574 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3576 case scm_tc7_lsubr_2
:
3577 if (!SCM_CONSP (args
))
3578 scm_wrong_num_args (proc
);
3580 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3582 if (SCM_NULLP (args
))
3583 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3584 while (SCM_NIMP (args
))
3586 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3587 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3588 args
= SCM_CDR (args
);
3591 case scm_tc7_rpsubr
:
3592 if (SCM_NULLP (args
))
3593 RETURN (SCM_BOOL_T
);
3594 while (SCM_NIMP (args
))
3596 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3597 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3598 RETURN (SCM_BOOL_F
);
3599 arg1
= SCM_CAR (args
);
3600 args
= SCM_CDR (args
);
3602 RETURN (SCM_BOOL_T
);
3603 case scm_tcs_closures
:
3605 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3607 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3609 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3610 scm_wrong_num_args (proc
);
3612 /* Copy argument list */
3617 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3618 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3620 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3624 SCM_SETCDR (tl
, arg1
);
3627 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3628 proc
= SCM_CLOSURE_BODY (proc
);
3631 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3633 if (SCM_IMP (SCM_CAR (proc
)))
3635 if (SCM_ISYMP (SCM_CAR (proc
)))
3637 scm_rec_mutex_lock (&source_mutex
);
3638 /* check for race condition */
3639 if (SCM_ISYMP (SCM_CAR (proc
)))
3640 proc
= scm_m_expand_body (proc
, args
);
3641 scm_rec_mutex_unlock (&source_mutex
);
3645 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3648 SCM_CEVAL (SCM_CAR (proc
), args
);
3651 RETURN (EVALCAR (proc
, args
));
3653 if (!SCM_SMOB_APPLICABLE_P (proc
))
3655 if (SCM_UNBNDP (arg1
))
3656 RETURN (SCM_SMOB_APPLY_0 (proc
));
3657 else if (SCM_NULLP (args
))
3658 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3659 else if (SCM_NULLP (SCM_CDR (args
)))
3660 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3662 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3665 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3667 proc
= SCM_CCLO_SUBR (proc
);
3668 debug
.vect
[0].a
.proc
= proc
;
3669 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3671 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3673 proc
= SCM_CCLO_SUBR (proc
);
3677 proc
= SCM_PROCEDURE (proc
);
3679 debug
.vect
[0].a
.proc
= proc
;
3682 case scm_tcs_struct
:
3683 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3686 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3688 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3690 RETURN (scm_apply_generic (proc
, args
));
3692 else if (!SCM_I_OPERATORP (proc
))
3698 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3700 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3703 proc
= (SCM_I_ENTITYP (proc
)
3704 ? SCM_ENTITY_PROCEDURE (proc
)
3705 : SCM_OPERATOR_PROCEDURE (proc
));
3707 debug
.vect
[0].a
.proc
= proc
;
3708 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3710 if (SCM_NIMP (proc
))
3717 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3721 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3722 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3724 SCM_CLEAR_TRACED_FRAME (debug
);
3725 if (SCM_CHEAPTRAPS_P
)
3726 arg1
= scm_make_debugobj (&debug
);
3730 SCM val
= scm_make_continuation (&first
);
3741 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3745 scm_last_debug_frame
= debug
.prev
;
3751 /* SECTION: The rest of this file is only read once.
3758 * Trampolines make it possible to move procedure application dispatch
3759 * outside inner loops. The motivation was clean implementation of
3760 * efficient replacements of R5RS primitives in SRFI-1.
3762 * The semantics is clear: scm_trampoline_N returns an optimized
3763 * version of scm_call_N (or NULL if the procedure isn't applicable
3766 * Applying the optimization to map and for-each increased efficiency
3767 * noticeably. For example, (map abs ls) is now 8 times faster than
3772 call_subr0_0 (SCM proc
)
3774 return SCM_SUBRF (proc
) ();
3778 call_subr1o_0 (SCM proc
)
3780 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3784 call_lsubr_0 (SCM proc
)
3786 return SCM_SUBRF (proc
) (SCM_EOL
);
3790 scm_i_call_closure_0 (SCM proc
)
3792 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3793 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3799 scm_trampoline_0 (SCM proc
)
3805 switch (SCM_TYP7 (proc
))
3807 case scm_tc7_subr_0
:
3808 return call_subr0_0
;
3809 case scm_tc7_subr_1o
:
3810 return call_subr1o_0
;
3812 return call_lsubr_0
;
3813 case scm_tcs_closures
:
3815 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3816 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3817 return scm_i_call_closure_0
;
3821 case scm_tcs_struct
:
3822 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3823 return scm_call_generic_0
;
3824 else if (!SCM_I_OPERATORP (proc
))
3828 if (SCM_SMOB_APPLICABLE_P (proc
))
3829 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3834 case scm_tc7_rpsubr
:
3839 return 0; /* not applicable on one arg */
3844 call_subr1_1 (SCM proc
, SCM arg1
)
3846 return SCM_SUBRF (proc
) (arg1
);
3850 call_subr2o_1 (SCM proc
, SCM arg1
)
3852 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3856 call_lsubr_1 (SCM proc
, SCM arg1
)
3858 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3862 call_dsubr_1 (SCM proc
, SCM arg1
)
3864 if (SCM_INUMP (arg1
))
3866 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3868 else if (SCM_REALP (arg1
))
3870 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3872 else if (SCM_BIGP (arg1
))
3873 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3874 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3875 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3879 call_cxr_1 (SCM proc
, SCM arg1
)
3881 proc
= SCM_SNAME (proc
);
3883 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3884 while ('c' != *--chrs
)
3886 SCM_ASSERT (SCM_CONSP (arg1
),
3887 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3888 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3895 call_closure_1 (SCM proc
, SCM arg1
)
3897 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3898 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3904 scm_trampoline_1 (SCM proc
)
3910 switch (SCM_TYP7 (proc
))
3912 case scm_tc7_subr_1
:
3913 case scm_tc7_subr_1o
:
3914 return call_subr1_1
;
3915 case scm_tc7_subr_2o
:
3916 return call_subr2o_1
;
3918 return call_lsubr_1
;
3920 if (SCM_SUBRF (proc
))
3921 return call_dsubr_1
;
3924 case scm_tcs_closures
:
3926 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3927 if (!SCM_NULLP (formals
)
3928 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
3929 return call_closure_1
;
3933 case scm_tcs_struct
:
3934 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3935 return scm_call_generic_1
;
3936 else if (!SCM_I_OPERATORP (proc
))
3940 if (SCM_SMOB_APPLICABLE_P (proc
))
3941 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3946 case scm_tc7_rpsubr
:
3951 return 0; /* not applicable on one arg */
3956 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3958 return SCM_SUBRF (proc
) (arg1
, arg2
);
3962 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3964 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3968 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3970 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3974 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3976 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3977 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3978 scm_list_2 (arg1
, arg2
),
3983 scm_trampoline_2 (SCM proc
)
3989 switch (SCM_TYP7 (proc
))
3991 case scm_tc7_subr_2
:
3992 case scm_tc7_subr_2o
:
3993 case scm_tc7_rpsubr
:
3995 return call_subr2_2
;
3996 case scm_tc7_lsubr_2
:
3997 return call_lsubr2_2
;
3999 return call_lsubr_2
;
4000 case scm_tcs_closures
:
4002 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4003 if (!SCM_NULLP (formals
)
4004 && (!SCM_CONSP (formals
)
4005 || (!SCM_NULLP (SCM_CDR (formals
))
4006 && (!SCM_CONSP (SCM_CDR (formals
))
4007 || !SCM_CONSP (SCM_CDDR (formals
))))))
4008 return call_closure_2
;
4012 case scm_tcs_struct
:
4013 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4014 return scm_call_generic_2
;
4015 else if (!SCM_I_OPERATORP (proc
))
4019 if (SCM_SMOB_APPLICABLE_P (proc
))
4020 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4028 return 0; /* not applicable on two args */
4032 /* Typechecking for multi-argument MAP and FOR-EACH.
4034 Verify that each element of the vector ARGV, except for the first,
4035 is a proper list whose length is LEN. Attribute errors to WHO,
4036 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4038 check_map_args (SCM argv
,
4045 SCM
const *ve
= SCM_VELTS (argv
);
4048 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4050 long elt_len
= scm_ilength (ve
[i
]);
4055 scm_apply_generic (gf
, scm_cons (proc
, args
));
4057 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4061 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4064 scm_remember_upto_here_1 (argv
);
4068 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4070 /* Note: Currently, scm_map applies PROC to the argument list(s)
4071 sequentially, starting with the first element(s). This is used in
4072 evalext.c where the Scheme procedure `map-in-order', which guarantees
4073 sequential behaviour, is implemented using scm_map. If the
4074 behaviour changes, we need to update `map-in-order'.
4078 scm_map (SCM proc
, SCM arg1
, SCM args
)
4079 #define FUNC_NAME s_map
4084 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4086 len
= scm_ilength (arg1
);
4087 SCM_GASSERTn (len
>= 0,
4088 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4089 SCM_VALIDATE_REST_ARGUMENT (args
);
4090 if (SCM_NULLP (args
))
4092 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4093 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4094 while (SCM_NIMP (arg1
))
4096 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4097 pres
= SCM_CDRLOC (*pres
);
4098 arg1
= SCM_CDR (arg1
);
4102 if (SCM_NULLP (SCM_CDR (args
)))
4104 SCM arg2
= SCM_CAR (args
);
4105 int len2
= scm_ilength (arg2
);
4106 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4108 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4109 SCM_GASSERTn (len2
>= 0,
4110 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4112 SCM_OUT_OF_RANGE (3, arg2
);
4113 while (SCM_NIMP (arg1
))
4115 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4116 pres
= SCM_CDRLOC (*pres
);
4117 arg1
= SCM_CDR (arg1
);
4118 arg2
= SCM_CDR (arg2
);
4122 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4123 ve
= SCM_VELTS (args
);
4124 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4128 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4130 if (SCM_IMP (ve
[i
]))
4132 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4133 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4135 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4136 pres
= SCM_CDRLOC (*pres
);
4142 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4145 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4146 #define FUNC_NAME s_for_each
4148 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4150 len
= scm_ilength (arg1
);
4151 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4152 SCM_ARG2
, s_for_each
);
4153 SCM_VALIDATE_REST_ARGUMENT (args
);
4154 if (SCM_NULLP (args
))
4156 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4157 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4158 while (SCM_NIMP (arg1
))
4160 call (proc
, SCM_CAR (arg1
));
4161 arg1
= SCM_CDR (arg1
);
4163 return SCM_UNSPECIFIED
;
4165 if (SCM_NULLP (SCM_CDR (args
)))
4167 SCM arg2
= SCM_CAR (args
);
4168 int len2
= scm_ilength (arg2
);
4169 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4170 SCM_GASSERTn (call
, g_for_each
,
4171 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4172 SCM_GASSERTn (len2
>= 0, g_for_each
,
4173 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4175 SCM_OUT_OF_RANGE (3, arg2
);
4176 while (SCM_NIMP (arg1
))
4178 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4179 arg1
= SCM_CDR (arg1
);
4180 arg2
= SCM_CDR (arg2
);
4182 return SCM_UNSPECIFIED
;
4184 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4185 ve
= SCM_VELTS (args
);
4186 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4190 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4192 if (SCM_IMP (ve
[i
]))
4193 return SCM_UNSPECIFIED
;
4194 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4195 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4197 scm_apply (proc
, arg1
, SCM_EOL
);
4204 scm_closure (SCM code
, SCM env
)
4207 SCM closcar
= scm_cons (code
, SCM_EOL
);
4208 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4209 scm_remember_upto_here (closcar
);
4214 scm_t_bits scm_tc16_promise
;
4217 scm_makprom (SCM code
)
4219 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4221 scm_make_rec_mutex ());
4225 promise_free (SCM promise
)
4227 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4232 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4234 int writingp
= SCM_WRITINGP (pstate
);
4235 scm_puts ("#<promise ", port
);
4236 SCM_SET_WRITINGP (pstate
, 1);
4237 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4238 SCM_SET_WRITINGP (pstate
, writingp
);
4239 scm_putc ('>', port
);
4243 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4245 "If the promise @var{x} has not been computed yet, compute and\n"
4246 "return @var{x}, otherwise just return the previously computed\n"
4248 #define FUNC_NAME s_scm_force
4250 SCM_VALIDATE_SMOB (1, promise
, promise
);
4251 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4252 if (!SCM_PROMISE_COMPUTED_P (promise
))
4254 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4255 if (!SCM_PROMISE_COMPUTED_P (promise
))
4257 SCM_SET_PROMISE_DATA (promise
, ans
);
4258 SCM_SET_PROMISE_COMPUTED (promise
);
4261 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4262 return SCM_PROMISE_DATA (promise
);
4267 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4269 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4270 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4271 #define FUNC_NAME s_scm_promise_p
4273 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4278 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4279 (SCM xorig
, SCM x
, SCM y
),
4280 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4281 "Any source properties associated with @var{xorig} are also associated\n"
4282 "with the new pair.")
4283 #define FUNC_NAME s_scm_cons_source
4286 z
= scm_cons (x
, y
);
4287 /* Copy source properties possibly associated with xorig. */
4288 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4290 scm_whash_insert (scm_source_whash
, z
, p
);
4296 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4298 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4299 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4300 "contents of both pairs and vectors (since both cons cells and vector\n"
4301 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4302 "any other object.")
4303 #define FUNC_NAME s_scm_copy_tree
4308 if (SCM_VECTORP (obj
))
4310 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4311 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4313 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4316 if (!SCM_CONSP (obj
))
4318 ans
= tl
= scm_cons_source (obj
,
4319 scm_copy_tree (SCM_CAR (obj
)),
4321 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4323 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4327 SCM_SETCDR (tl
, obj
);
4333 /* We have three levels of EVAL here:
4335 - scm_i_eval (exp, env)
4337 evaluates EXP in environment ENV. ENV is a lexical environment
4338 structure as used by the actual tree code evaluator. When ENV is
4339 a top-level environment, then changes to the current module are
4340 tracked by updating ENV so that it continues to be in sync with
4343 - scm_primitive_eval (exp)
4345 evaluates EXP in the top-level environment as determined by the
4346 current module. This is done by constructing a suitable
4347 environment and calling scm_i_eval. Thus, changes to the
4348 top-level module are tracked normally.
4350 - scm_eval (exp, mod)
4352 evaluates EXP while MOD is the current module. This is done by
4353 setting the current module to MOD, invoking scm_primitive_eval on
4354 EXP, and then restoring the current module to the value it had
4355 previously. That is, while EXP is evaluated, changes to the
4356 current module are tracked, but these changes do not persist when
4359 For each level of evals, there are two variants, distinguished by a
4360 _x suffix: the ordinary variant does not modify EXP while the _x
4361 variant can destructively modify EXP into something completely
4362 unintelligible. A Scheme data structure passed as EXP to one of the
4363 _x variants should not ever be used again for anything. So when in
4364 doubt, use the ordinary variant.
4369 scm_i_eval_x (SCM exp
, SCM env
)
4371 return SCM_XEVAL (exp
, env
);
4375 scm_i_eval (SCM exp
, SCM env
)
4377 exp
= scm_copy_tree (exp
);
4378 return SCM_XEVAL (exp
, env
);
4382 scm_primitive_eval_x (SCM exp
)
4385 SCM transformer
= scm_current_module_transformer ();
4386 if (SCM_NIMP (transformer
))
4387 exp
= scm_call_1 (transformer
, exp
);
4388 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4389 return scm_i_eval_x (exp
, env
);
4392 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4394 "Evaluate @var{exp} in the top-level environment specified by\n"
4395 "the current module.")
4396 #define FUNC_NAME s_scm_primitive_eval
4399 SCM transformer
= scm_current_module_transformer ();
4400 if (SCM_NIMP (transformer
))
4401 exp
= scm_call_1 (transformer
, exp
);
4402 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4403 return scm_i_eval (exp
, env
);
4407 /* Eval does not take the second arg optionally. This is intentional
4408 * in order to be R5RS compatible, and to prepare for the new module
4409 * system, where we would like to make the choice of evaluation
4410 * environment explicit. */
4413 change_environment (void *data
)
4415 SCM pair
= SCM_PACK (data
);
4416 SCM new_module
= SCM_CAR (pair
);
4417 SCM old_module
= scm_current_module ();
4418 SCM_SETCDR (pair
, old_module
);
4419 scm_set_current_module (new_module
);
4424 restore_environment (void *data
)
4426 SCM pair
= SCM_PACK (data
);
4427 SCM old_module
= SCM_CDR (pair
);
4428 SCM new_module
= scm_current_module ();
4429 SCM_SETCAR (pair
, new_module
);
4430 scm_set_current_module (old_module
);
4434 inner_eval_x (void *data
)
4436 return scm_primitive_eval_x (SCM_PACK(data
));
4440 scm_eval_x (SCM exp
, SCM module
)
4441 #define FUNC_NAME "eval!"
4443 SCM_VALIDATE_MODULE (2, module
);
4445 return scm_internal_dynamic_wind
4446 (change_environment
, inner_eval_x
, restore_environment
,
4447 (void *) SCM_UNPACK (exp
),
4448 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4453 inner_eval (void *data
)
4455 return scm_primitive_eval (SCM_PACK(data
));
4458 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4459 (SCM exp
, SCM module
),
4460 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4461 "in the top-level environment specified by @var{module}.\n"
4462 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4463 "@var{module} is made the current module. The current module\n"
4464 "is reset to its previous value when @var{eval} returns.")
4465 #define FUNC_NAME s_scm_eval
4467 SCM_VALIDATE_MODULE (2, module
);
4469 return scm_internal_dynamic_wind
4470 (change_environment
, inner_eval
, restore_environment
,
4471 (void *) SCM_UNPACK (exp
),
4472 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4477 /* At this point, scm_deval and scm_dapply are generated.
4488 scm_init_opts (scm_evaluator_traps
,
4489 scm_evaluator_trap_table
,
4490 SCM_N_EVALUATOR_TRAPS
);
4491 scm_init_opts (scm_eval_options_interface
,
4493 SCM_N_EVAL_OPTIONS
);
4495 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4496 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4497 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4498 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4500 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4501 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4502 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4503 scm_listofnull
= scm_list_1 (SCM_EOL
);
4505 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4510 #include "libguile/eval.x"
4512 scm_add_feature ("delay");