1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program 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
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 /* This file is read twice in order to produce debugging versions of
45 * scm_ceval and scm_apply. These functions, scm_deval and
46 * scm_dapply, are produced when we define the preprocessor macro
47 * DEVAL. The file is divided into sections which are treated
48 * differently with respect to DEVAL. The heads of these sections are
49 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
57 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
58 #include "libguile/scmconfig.h"
60 /* AIX requires this to be the first thing in the file. The #pragma
61 directive is indented so pre-ANSI compilers will ignore it, rather
70 # ifndef alloca /* predefined by HP cc +Olibcalls */
77 #include "libguile/_scm.h"
78 #include "libguile/debug.h"
79 #include "libguile/dynwind.h"
80 #include "libguile/alist.h"
81 #include "libguile/eq.h"
82 #include "libguile/continuations.h"
83 #include "libguile/throw.h"
84 #include "libguile/smob.h"
85 #include "libguile/macros.h"
86 #include "libguile/procprop.h"
87 #include "libguile/hashtab.h"
88 #include "libguile/hash.h"
89 #include "libguile/srcprop.h"
90 #include "libguile/stackchk.h"
91 #include "libguile/objects.h"
92 #include "libguile/async.h"
93 #include "libguile/feature.h"
94 #include "libguile/modules.h"
95 #include "libguile/ports.h"
96 #include "libguile/root.h"
97 #include "libguile/vectors.h"
98 #include "libguile/fluids.h"
99 #include "libguile/goops.h"
100 #include "libguile/values.h"
102 #include "libguile/validate.h"
103 #include "libguile/eval.h"
104 #include "libguile/lang.h"
108 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
110 if (SCM_EQ_P ((x), SCM_EOL)) \
111 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
116 /* The evaluator contains a plethora of EVAL symbols.
117 * This is an attempt at explanation.
119 * The following macros should be used in code which is read twice
120 * (where the choice of evaluator is hard soldered):
122 * SCM_CEVAL is the symbol used within one evaluator to call itself.
123 * Originally, it is defined to scm_ceval, but is redefined to
124 * scm_deval during the second pass.
126 * SCM_EVALIM is used when it is known that the expression is an
127 * immediate. (This macro never calls an evaluator.)
129 * EVALCAR evaluates the car of an expression.
131 * The following macros should be used in code which is read once
132 * (where the choice of evaluator is dynamic):
134 * SCM_XEVAL takes care of immediates without calling an evaluator. It
135 * then calls scm_ceval *or* scm_deval, depending on the debugging
138 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
139 * depending on the debugging mode.
141 * The main motivation for keeping this plethora is efficiency
142 * together with maintainability (=> locality of code).
145 #define SCM_CEVAL scm_ceval
147 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
148 ? SCM_EVALIM (SCM_CAR (x), env) \
149 : (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env)))
153 #define EXTEND_ENV SCM_EXTEND_ENV
155 SCM_REC_CRITICAL_SECTION (source
);
156 #define SOURCE_SECTION_START SCM_REC_CRITICAL_SECTION_START (source);
157 #define SOURCE_SECTION_END SCM_REC_CRITICAL_SECTION_END (source);
160 scm_ilookup (SCM iloc
, SCM env
)
162 register long ir
= SCM_IFRAME (iloc
);
163 register SCM er
= env
;
164 for (; 0 != ir
; --ir
)
167 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
169 if (SCM_ICDRP (iloc
))
170 return SCM_CDRLOC (er
);
171 return SCM_CARLOC (SCM_CDR (er
));
174 /* The Lookup Car Race
177 Memoization of variables and special forms is done while executing
178 the code for the first time. As long as there is only one thread
179 everything is fine, but as soon as two threads execute the same
180 code concurrently `for the first time' they can come into conflict.
182 This memoization includes rewriting variable references into more
183 efficient forms and expanding macros. Furthermore, macro expansion
184 includes `compiling' special forms like `let', `cond', etc. into
185 tree-code instructions.
187 There shouldn't normally be a problem with memoizing local and
188 global variable references (into ilocs and variables), because all
189 threads will mutate the code in *exactly* the same way and (if I
190 read the C code correctly) it is not possible to observe a half-way
191 mutated cons cell. The lookup procedure can handle this
192 transparently without any critical sections.
194 It is different with macro expansion, because macro expansion
195 happens outside of the lookup procedure and can't be
196 undone. Therefore the lookup procedure can't cope with it. It has
197 to indicate failure when it detects a lost race and hope that the
198 caller can handle it. Luckily, it turns out that this is the case.
200 An example to illustrate this: Suppose that the following form will
201 be memoized concurrently by two threads
205 Let's first examine the lookup of X in the body. The first thread
206 decides that it has to find the symbol "x" in the environment and
207 starts to scan it. Then the other thread takes over and actually
208 overtakes the first. It looks up "x" and substitutes an
209 appropriate iloc for it. Now the first thread continues and
210 completes its lookup. It comes to exactly the same conclusions as
211 the second one and could - without much ado - just overwrite the
212 iloc with the same iloc.
214 But let's see what will happen when the race occurs while looking
215 up the symbol "let" at the start of the form. It could happen that
216 the second thread interrupts the lookup of the first thread and not
217 only substitutes a variable for it but goes right ahead and
218 replaces it with the compiled form (#@let* (x 12) x). Now, when
219 the first thread completes its lookup, it would replace the #@let*
220 with a variable containing the "let" binding, effectively reverting
221 the form to (let (x 12) x). This is wrong. It has to detect that
222 it has lost the race and the evaluator has to reconsider the
223 changed form completely.
225 This race condition could be resolved with some kind of traffic
226 light (like mutexes) around scm_lookupcar, but I think that it is
227 best to avoid them in this case. They would serialize memoization
228 completely and because lookup involves calling arbitrary Scheme
229 code (via the lookup-thunk), threads could be blocked for an
230 arbitrary amount of time or even deadlock. But with the current
231 solution a lot of unnecessary work is potentially done. */
233 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
234 return NULL to indicate a failed lookup due to some race conditions
235 between threads. This only happens when VLOC is the first cell of
236 a special form that will eventually be memoized (like `let', etc.)
237 In that case the whole lookup is bogus and the caller has to
238 reconsider the complete special form.
240 SCM_LOOKUPCAR is still there, of course. It just calls
241 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
242 should only be called when it is known that VLOC is not the first
243 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
244 for NULL. I think I've found the only places where this
247 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
250 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
253 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
254 register SCM iloc
= SCM_ILOC00
;
255 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
257 if (!SCM_CONSP (SCM_CAR (env
)))
259 al
= SCM_CARLOC (env
);
260 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
264 if (SCM_EQ_P (fl
, var
))
266 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
268 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
269 return SCM_CDRLOC (*al
);
274 al
= SCM_CDRLOC (*al
);
275 if (SCM_EQ_P (SCM_CAR (fl
), var
))
277 if (SCM_UNBNDP (SCM_CAR (*al
)))
282 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
284 SCM_SETCAR (vloc
, iloc
);
285 return SCM_CARLOC (*al
);
287 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
289 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
292 SCM top_thunk
, real_var
;
295 top_thunk
= SCM_CAR (env
); /* env now refers to a
296 top level env thunk */
300 top_thunk
= SCM_BOOL_F
;
301 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
302 if (SCM_FALSEP (real_var
))
305 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
311 scm_error (scm_unbound_variable_key
, NULL
,
312 "Unbound variable: ~S",
313 scm_list_1 (var
), SCM_BOOL_F
);
315 scm_misc_error (NULL
, "Damaged environment: ~S",
320 /* A variable could not be found, but we shall
321 not throw an error. */
322 static SCM undef_object
= SCM_UNDEFINED
;
323 return &undef_object
;
327 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
329 /* Some other thread has changed the very cell we are working
330 on. In effect, it must have done our job or messed it up
333 var
= SCM_CAR (vloc
);
334 if (SCM_VARIABLEP (var
))
335 return SCM_VARIABLE_LOC (var
);
336 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
337 return scm_ilookup (var
, genv
);
338 /* We can't cope with anything else than variables and ilocs. When
339 a special form has been memoized (i.e. `let' into `#@let') we
340 return NULL and expect the calling function to do the right
341 thing. For the evaluator, this means going back and redoing
342 the dispatch on the car of the form. */
346 SCM_SETCAR (vloc
, real_var
);
347 return SCM_VARIABLE_LOC (real_var
);
352 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
354 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
360 #define unmemocar scm_unmemocar
362 SCM_SYMBOL (sym_three_question_marks
, "???");
365 scm_unmemocar (SCM form
, SCM env
)
367 if (!SCM_CONSP (form
))
371 SCM c
= SCM_CAR (form
);
372 if (SCM_VARIABLEP (c
))
374 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
375 if (SCM_FALSEP (sym
))
376 sym
= sym_three_question_marks
;
377 SCM_SETCAR (form
, sym
);
379 else if (SCM_ILOCP (c
))
381 unsigned long int ir
;
383 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
385 env
= SCM_CAAR (env
);
386 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
388 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
396 scm_eval_car (SCM pair
, SCM env
)
398 return SCM_XEVALCAR (pair
, env
);
403 * The following rewrite expressions and
404 * some memoized forms have different syntax
407 const char scm_s_expression
[] = "missing or extra expression";
408 const char scm_s_test
[] = "bad test";
409 const char scm_s_body
[] = "bad body";
410 const char scm_s_bindings
[] = "bad bindings";
411 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
412 const char scm_s_variable
[] = "bad variable";
413 const char scm_s_clauses
[] = "bad or missing clauses";
414 const char scm_s_formals
[] = "bad formals";
415 const char scm_s_duplicate_formals
[] = "duplicate formals";
416 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
418 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
419 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
420 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
421 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
422 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
426 #ifdef DEBUG_EXTENSIONS
427 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
428 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
429 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
430 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
434 /* Check that the body denoted by XORIG is valid and rewrite it into
435 its internal form. The internal form of a body is just the body
436 itself, but prefixed with an ISYM that denotes to what kind of
437 outer construct this body belongs. A lambda body starts with
438 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
439 etc. The one exception is a body that belongs to a letrec that has
440 been formed by rewriting internal defines: it starts with
443 /* XXX - Besides controlling the rewriting of internal defines, the
444 additional ISYM could be used for improved error messages.
445 This is not done yet. */
448 scm_m_body (SCM op
, SCM xorig
, const char *what
)
450 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
452 /* Don't add another ISYM if one is present already. */
453 if (SCM_ISYMP (SCM_CAR (xorig
)))
456 /* Retain possible doc string. */
457 if (!SCM_CONSP (SCM_CAR (xorig
)))
459 if (!SCM_NULLP (SCM_CDR (xorig
)))
460 return scm_cons (SCM_CAR (xorig
),
461 scm_m_body (op
, SCM_CDR (xorig
), what
));
465 return scm_cons (op
, xorig
);
469 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
470 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
473 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
475 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
476 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
480 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
481 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
484 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
486 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
487 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
491 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
492 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
495 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
497 long len
= scm_ilength (SCM_CDR (xorig
));
498 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
499 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
503 /* Will go into the RnRS module when Guile is factorized.
504 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
505 const char scm_s_set_x
[] = "set!";
506 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
509 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
511 SCM x
= SCM_CDR (xorig
);
512 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
513 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
514 return scm_cons (SCM_IM_SET_X
, x
);
518 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
519 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
522 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
524 long len
= scm_ilength (SCM_CDR (xorig
));
525 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
527 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
533 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
534 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
537 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
539 long len
= scm_ilength (SCM_CDR (xorig
));
540 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
542 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
548 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
549 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
552 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
555 SCM cdrx
= SCM_CDR (xorig
);
556 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
557 clauses
= SCM_CDR (cdrx
);
558 while (!SCM_NULLP (clauses
))
560 SCM clause
= SCM_CAR (clauses
);
561 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
562 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
563 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
564 && SCM_NULLP (SCM_CDR (clauses
))),
565 scm_s_clauses
, s_case
);
566 clauses
= SCM_CDR (clauses
);
568 return scm_cons (SCM_IM_CASE
, cdrx
);
572 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
573 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
576 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
578 SCM cdrx
= SCM_CDR (xorig
);
580 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
581 while (!SCM_NULLP (clauses
))
583 SCM clause
= SCM_CAR (clauses
);
584 long len
= scm_ilength (clause
);
585 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
586 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
588 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
589 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
591 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
593 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
594 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
596 clauses
= SCM_CDR (clauses
);
598 return scm_cons (SCM_IM_COND
, cdrx
);
602 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
603 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
605 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
606 * cdr of the last cons. (Thus, LIST is not required to be a proper
607 * list and OBJ can also be found in the improper ending.) */
609 scm_c_improper_memq (SCM obj
, SCM list
)
611 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
613 if (SCM_EQ_P (SCM_CAR (list
), obj
))
616 return SCM_EQ_P (list
, obj
);
620 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
623 SCM x
= SCM_CDR (xorig
);
625 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
627 formals
= SCM_CAR (x
);
628 while (SCM_CONSP (formals
))
630 SCM formal
= SCM_CAR (formals
);
631 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
632 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
633 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
634 formals
= SCM_CDR (formals
);
636 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
637 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
639 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
640 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
644 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
645 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
647 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
648 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
650 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
653 SCM x
= SCM_CDR (xorig
);
657 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
659 bindings
= SCM_CAR (x
);
660 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
661 while (!SCM_NULLP (bindings
))
663 SCM binding
= SCM_CAR (bindings
);
664 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
665 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
666 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
667 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
668 bindings
= SCM_CDR (bindings
);
671 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
672 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
676 /* DO gets the most radically altered syntax. The order of the vars is
677 * reversed here. In contrast, the order of the inits and steps is reversed
678 * during the evaluation:
680 (do ((<var1> <init1> <step1>)
688 (#@do (varn ... var2 var1)
689 (<init1> <init2> ... <initn>)
692 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
695 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
696 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
699 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
702 SCM x
= SCM_CDR (xorig
);
705 SCM
*initloc
= &inits
;
707 SCM
*steploc
= &steps
;
708 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
709 bindings
= SCM_CAR (x
);
710 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
711 while (!SCM_NULLP (bindings
))
713 SCM binding
= SCM_CAR (bindings
);
714 long len
= scm_ilength (binding
);
715 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
717 SCM name
= SCM_CAR (binding
);
718 SCM init
= SCM_CADR (binding
);
719 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
720 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
721 vars
= scm_cons (name
, vars
);
722 *initloc
= scm_list_1 (init
);
723 initloc
= SCM_CDRLOC (*initloc
);
724 *steploc
= scm_list_1 (step
);
725 steploc
= SCM_CDRLOC (*steploc
);
726 bindings
= SCM_CDR (bindings
);
730 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
731 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
732 x
= scm_cons2 (vars
, inits
, x
);
733 return scm_cons (SCM_IM_DO
, x
);
737 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
738 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
740 /* Internal function to handle a quasiquotation: 'form' is the parameter in
741 * the call (quasiquotation form), 'env' is the environment where unquoted
742 * expressions will be evaluated, and 'depth' is the current quasiquotation
743 * nesting level and is known to be greater than zero. */
745 iqq (SCM form
, SCM env
, unsigned long int depth
)
747 if (SCM_CONSP (form
))
749 SCM tmp
= SCM_CAR (form
);
750 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
752 SCM args
= SCM_CDR (form
);
753 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
754 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
756 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
758 SCM args
= SCM_CDR (form
);
759 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
761 return scm_eval_car (args
, env
);
763 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
765 else if (SCM_CONSP (tmp
)
766 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
768 SCM args
= SCM_CDR (tmp
);
769 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
772 SCM list
= scm_eval_car (args
, env
);
773 SCM rest
= SCM_CDR (form
);
774 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
775 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
778 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
779 iqq (SCM_CDR (form
), env
, depth
));
782 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
783 iqq (SCM_CDR (form
), env
, depth
));
785 else if (SCM_VECTORP (form
))
787 size_t i
= SCM_VECTOR_LENGTH (form
);
788 SCM
const *data
= SCM_VELTS (form
);
791 tmp
= scm_cons (data
[--i
], tmp
);
792 scm_remember_upto_here_1 (form
);
793 return scm_vector (iqq (tmp
, env
, depth
));
800 scm_m_quasiquote (SCM xorig
, SCM env
)
802 SCM x
= SCM_CDR (xorig
);
803 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
804 return iqq (SCM_CAR (x
), env
, 1);
808 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
809 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
811 /* Promises are implemented as closures with an empty parameter list. Thus,
812 * (delay <expression>) is transformed into (#@delay '() <expression>), where
813 * the empty list represents the empty parameter list. This representation
814 * allows for easy creation of the closure during evaluation. */
816 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
818 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
819 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
823 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
824 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
826 /* Guile provides an extension to R5RS' define syntax to represent function
827 * currying in a compact way. With this extension, it is allowed to write
828 * (define <nested-variable> <body>), where <nested-variable> has of one of
829 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
830 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
831 * should be either a sequence of zero or more variables, or a sequence of one
832 * or more variables followed by a space-delimited period and another
833 * variable. Each level of argument nesting wraps the <body> within another
834 * lambda expression. For example, the following forms are allowed, each one
835 * followed by an equivalent, more explicit implementation.
837 * (define ((a b . c) . d) <body>) is equivalent to
838 * (define a (lambda (b . c) (lambda d <body>)))
840 * (define (((a) b) c . d) <body>) is equivalent to
841 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
843 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
844 * module that does not implement this extension. */
846 scm_m_define (SCM x
, SCM env
)
850 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
853 while (SCM_CONSP (name
))
855 /* This while loop realizes function currying by variable nesting. */
856 SCM formals
= SCM_CDR (name
);
857 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
858 name
= SCM_CAR (name
);
860 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
861 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
862 if (SCM_TOP_LEVEL (env
))
865 x
= scm_eval_car (x
, env
);
866 if (SCM_REC_PROCNAMES_P
)
869 while (SCM_MACROP (tmp
))
870 tmp
= SCM_MACRO_CODE (tmp
);
871 if (SCM_CLOSUREP (tmp
)
872 /* Only the first definition determines the name. */
873 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
874 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
876 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
877 SCM_VARIABLE_SET (var
, x
);
878 return SCM_UNSPECIFIED
;
881 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
885 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
886 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
887 * reversed here, the list of inits gets reversed during evaluation. */
889 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
895 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
899 SCM binding
= SCM_CAR (bindings
);
900 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
901 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
902 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
903 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
904 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
905 *initloc
= scm_list_1 (SCM_CADR (binding
));
906 initloc
= SCM_CDRLOC (*initloc
);
907 bindings
= SCM_CDR (bindings
);
909 while (!SCM_NULLP (bindings
));
915 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
916 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
919 scm_m_letrec (SCM xorig
, SCM env
)
921 SCM x
= SCM_CDR (xorig
);
922 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
924 if (SCM_NULLP (SCM_CAR (x
)))
926 /* null binding, let* faster */
927 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
928 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
932 SCM rvars
, inits
, body
;
933 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
934 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
935 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
940 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
941 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
944 scm_m_let (SCM xorig
, SCM env
)
946 SCM x
= SCM_CDR (xorig
);
949 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
952 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
954 /* null or single binding, let* is faster */
956 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
957 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
959 else if (SCM_CONSP (temp
))
963 SCM rvars
, inits
, body
;
964 transform_bindings (bindings
, &rvars
, &inits
, "let");
965 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
966 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
970 /* named let: Transform (let name ((var init) ...) body ...) into
971 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
977 SCM
*initloc
= &inits
;
980 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
982 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
983 bindings
= SCM_CAR (x
);
984 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
985 while (!SCM_NULLP (bindings
))
986 { /* vars and inits both in order */
987 SCM binding
= SCM_CAR (bindings
);
988 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
989 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
990 *varloc
= scm_list_1 (SCM_CAR (binding
));
991 varloc
= SCM_CDRLOC (*varloc
);
992 *initloc
= scm_list_1 (SCM_CADR (binding
));
993 initloc
= SCM_CDRLOC (*initloc
);
994 bindings
= SCM_CDR (bindings
);
998 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
999 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1000 SCM rvar
= scm_list_1 (name
);
1001 SCM init
= scm_list_1 (lambda_form
);
1002 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1003 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1004 return scm_cons (letrec
, inits
);
1010 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1011 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1012 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1015 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1017 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1018 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1022 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1023 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1027 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1029 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1030 scm_s_expression
, s_atcall_cc
);
1031 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1034 #ifdef SCM_ENABLE_ELISP
1036 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1039 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1041 long len
= scm_ilength (SCM_CDR (xorig
));
1042 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1043 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1046 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1049 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1051 SCM x
= SCM_CDR (xorig
), var
;
1052 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1053 var
= scm_symbol_fref (SCM_CAR (x
));
1054 /* Passing the symbol name as the `subr' arg here isn't really
1055 right, but without it it can be very difficult to work out from
1056 the error message which function definition was missing. In any
1057 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1058 something equivalent to (signal void-function (list SYM)) in
1060 SCM_ASSYNT (SCM_VARIABLEP (var
),
1061 "Symbol's function definition is void",
1062 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1063 /* Support `defalias'. */
1064 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1066 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1067 SCM_ASSYNT (SCM_VARIABLEP (var
),
1068 "Symbol's function definition is void",
1069 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1071 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1072 former allows for automatically picking up redefinitions of the
1073 corresponding symbol. */
1074 SCM_SETCAR (x
, var
);
1075 /* If the variable contains a procedure, leave the
1076 `transformer-macro' in place so that the procedure's arguments
1077 get properly transformed, and change the initial @fop to
1079 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1081 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1084 /* Otherwise (the variable contains a macro), the arguments should
1085 not be transformed, so cut the `transformer-macro' out and return
1086 the resulting expression starting with the variable. */
1087 SCM_SETCDR (x
, SCM_CDADR (x
));
1091 #endif /* SCM_ENABLE_ELISP */
1093 /* (@bind ((var exp) ...) body ...)
1095 This will assign the values of the `exp's to the global variables
1096 named by `var's (symbols, not evaluated), creating them if they
1097 don't exist, executes body, and then restores the previous values of
1098 the `var's. Additionally, whenever control leaves body, the values
1099 of the `var's are saved and restored when control returns. It is an
1100 error when a symbol appears more than once among the `var's.
1101 All `exp's are evaluated before any `var' is set.
1103 Think of this as `let' for dynamic scope.
1105 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1107 XXX - also implement `@bind*'.
1110 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1113 scm_m_atbind (SCM xorig
, SCM env
)
1115 SCM x
= SCM_CDR (xorig
);
1116 SCM top_level
= scm_env_top_level (env
);
1117 SCM vars
= SCM_EOL
, var
;
1120 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1123 while (SCM_NIMP (x
))
1126 SCM sym_exp
= SCM_CAR (x
);
1127 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1128 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1130 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1131 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1132 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1133 /* The first call to scm_sym2var will look beyond the current
1134 module, while the second call wont. */
1135 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1136 if (SCM_FALSEP (var
))
1137 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1138 vars
= scm_cons (var
, vars
);
1139 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1141 return scm_cons (SCM_IM_BIND
,
1142 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1146 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1147 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1150 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1152 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1153 scm_s_expression
, s_at_call_with_values
);
1154 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1158 scm_m_expand_body (SCM xorig
, SCM env
)
1160 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1161 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1163 while (SCM_NIMP (x
))
1165 SCM form
= SCM_CAR (x
);
1166 if (!SCM_CONSP (form
))
1168 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1171 form
= scm_macroexp (scm_cons_source (form
,
1176 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1178 defs
= scm_cons (SCM_CDR (form
), defs
);
1181 else if (!SCM_IMP (defs
))
1185 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1187 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1191 x
= scm_cons (form
, SCM_CDR (x
));
1196 if (!SCM_NULLP (defs
))
1198 SCM rvars
, inits
, body
, letrec
;
1199 transform_bindings (defs
, &rvars
, &inits
, what
);
1200 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1201 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1202 SCM_SETCAR (xorig
, letrec
);
1203 SCM_SETCDR (xorig
, SCM_EOL
);
1207 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1208 SCM_SETCAR (xorig
, SCM_CAR (x
));
1209 SCM_SETCDR (xorig
, SCM_CDR (x
));
1216 scm_macroexp (SCM x
, SCM env
)
1218 SCM res
, proc
, orig_sym
;
1220 /* Don't bother to produce error messages here. We get them when we
1221 eventually execute the code for real. */
1224 orig_sym
= SCM_CAR (x
);
1225 if (!SCM_SYMBOLP (orig_sym
))
1229 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1230 if (proc_ptr
== NULL
)
1232 /* We have lost the race. */
1238 /* Only handle memoizing macros. `Acros' and `macros' are really
1239 special forms and should not be evaluated here. */
1241 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1244 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1245 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1247 if (scm_ilength (res
) <= 0)
1248 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1251 SCM_SETCAR (x
, SCM_CAR (res
));
1252 SCM_SETCDR (x
, SCM_CDR (res
));
1258 /* scm_unmemocopy takes a memoized expression together with its
1259 * environment and rewrites it to its original form. Thus, it is the
1260 * inversion of the rewrite rules above. The procedure is not
1261 * optimized for speed. It's used in scm_iprin1 when printing the
1262 * code of a closure, in scm_procedure_source, in display_frame when
1263 * generating the source for a stackframe in a backtrace, and in
1264 * display_expression.
1266 * Unmemoizing is not a reliable process. You cannot in general
1267 * expect to get the original source back.
1269 * However, GOOPS currently relies on this for method compilation.
1270 * This ought to change.
1273 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1276 build_binding_list (SCM names
, SCM inits
)
1278 SCM bindings
= SCM_EOL
;
1279 while (!SCM_NULLP (names
))
1281 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1282 bindings
= scm_cons (binding
, bindings
);
1283 names
= SCM_CDR (names
);
1284 inits
= SCM_CDR (inits
);
1290 unmemocopy (SCM x
, SCM env
)
1293 #ifdef DEBUG_EXTENSIONS
1298 #ifdef DEBUG_EXTENSIONS
1299 p
= scm_whash_lookup (scm_source_whash
, x
);
1301 switch (SCM_ITAG7 (SCM_CAR (x
)))
1303 case SCM_BIT8(SCM_IM_AND
):
1304 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1306 case SCM_BIT8(SCM_IM_BEGIN
):
1307 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1309 case SCM_BIT8(SCM_IM_CASE
):
1310 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1312 case SCM_BIT8(SCM_IM_COND
):
1313 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1315 case SCM_BIT8 (SCM_IM_DO
):
1317 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1318 * where nx is the name of a local variable, ix is an initializer for
1319 * the local variable, test is the test clause of the do loop, body is
1320 * the body of the do loop and sx are the step clauses for the local
1322 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1325 names
= SCM_CAR (x
);
1327 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1328 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1330 test
= unmemocopy (SCM_CAR (x
), env
);
1332 memoized_body
= SCM_CAR (x
);
1334 steps
= scm_reverse (unmemocopy (x
, env
));
1336 /* build transformed binding list */
1338 while (!SCM_NULLP (names
))
1340 SCM name
= SCM_CAR (names
);
1341 SCM init
= SCM_CAR (inits
);
1342 SCM step
= SCM_CAR (steps
);
1343 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1345 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1347 names
= SCM_CDR (names
);
1348 inits
= SCM_CDR (inits
);
1349 steps
= SCM_CDR (steps
);
1351 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1352 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1354 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1357 case SCM_BIT8(SCM_IM_IF
):
1358 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1360 case SCM_BIT8 (SCM_IM_LET
):
1362 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1363 * where nx is the name of a local variable, ix is an initializer for
1364 * the local variable and by are the body clauses. */
1365 SCM names
, inits
, bindings
;
1368 names
= SCM_CAR (x
);
1370 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1371 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1373 bindings
= build_binding_list (names
, inits
);
1374 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1375 ls
= scm_cons (scm_sym_let
, z
);
1378 case SCM_BIT8 (SCM_IM_LETREC
):
1380 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1381 * where nx is the name of a local variable, ix is an initializer for
1382 * the local variable and by are the body clauses. */
1383 SCM names
, inits
, bindings
;
1386 names
= SCM_CAR (x
);
1387 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1389 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1391 bindings
= build_binding_list (names
, inits
);
1392 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1393 ls
= scm_cons (scm_sym_letrec
, z
);
1396 case SCM_BIT8(SCM_IM_LETSTAR
):
1404 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1407 y
= z
= scm_acons (SCM_CAR (b
),
1409 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1411 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1415 SCM_SETCDR (y
, SCM_EOL
);
1416 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1421 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1423 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1426 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1429 while (SCM_NIMP (b
));
1430 SCM_SETCDR (z
, SCM_EOL
);
1432 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1435 case SCM_BIT8(SCM_IM_OR
):
1436 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1438 case SCM_BIT8(SCM_IM_LAMBDA
):
1440 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1441 ls
= scm_cons (scm_sym_lambda
, z
);
1442 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1444 case SCM_BIT8(SCM_IM_QUOTE
):
1445 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1447 case SCM_BIT8(SCM_IM_SET_X
):
1448 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1450 case SCM_BIT8(SCM_IM_DEFINE
):
1455 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1456 ls
= scm_cons (scm_sym_define
, z
);
1457 if (!SCM_NULLP (env
))
1458 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1463 case SCM_BIT8(SCM_MAKISYM (0)):
1467 switch (SCM_ISYMNUM (z
))
1469 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1470 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1472 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1473 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1475 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1476 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1479 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1480 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1483 /* appease the Sun compiler god: */ ;
1487 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1493 while (SCM_CONSP (x
))
1495 SCM form
= SCM_CAR (x
);
1496 if (!SCM_ISYMP (form
))
1498 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1499 SCM_SETCDR (z
, unmemocar (copy
, env
));
1505 #ifdef DEBUG_EXTENSIONS
1506 if (!SCM_FALSEP (p
))
1507 scm_whash_insert (scm_source_whash
, ls
, p
);
1514 scm_unmemocopy (SCM x
, SCM env
)
1516 if (!SCM_NULLP (env
))
1517 /* Make a copy of the lowest frame to protect it from
1518 modifications by SCM_IM_DEFINE */
1519 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1521 return unmemocopy (x
, env
);
1526 scm_badargsp (SCM formals
, SCM args
)
1528 while (!SCM_NULLP (formals
))
1530 if (!SCM_CONSP (formals
))
1532 if (SCM_NULLP (args
))
1534 formals
= SCM_CDR (formals
);
1535 args
= SCM_CDR (args
);
1537 return !SCM_NULLP (args
) ? 1 : 0;
1542 scm_badformalsp (SCM closure
, int n
)
1544 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1545 while (!SCM_NULLP (formals
))
1547 if (!SCM_CONSP (formals
))
1552 formals
= SCM_CDR (formals
);
1559 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1561 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1562 while (SCM_CONSP (l
))
1564 res
= EVALCAR (l
, env
);
1566 *lloc
= scm_list_1 (res
);
1567 lloc
= SCM_CDRLOC (*lloc
);
1571 scm_wrong_num_args (proc
);
1576 scm_eval_body (SCM code
, SCM env
)
1580 next
= SCM_CDR (code
);
1581 while (!SCM_NULLP (next
))
1583 if (SCM_IMP (SCM_CAR (code
)))
1585 if (SCM_ISYMP (SCM_CAR (code
)))
1587 SOURCE_SECTION_START
;
1588 /* check for race condition */
1589 if (SCM_ISYMP (SCM_CAR (code
)))
1590 code
= scm_m_expand_body (code
, env
);
1596 SCM_XEVAL (SCM_CAR (code
), env
);
1598 next
= SCM_CDR (code
);
1600 return SCM_XEVALCAR (code
, env
);
1607 /* SECTION: This code is specific for the debugging support. One
1608 * branch is read when DEVAL isn't defined, the other when DEVAL is
1614 #define SCM_APPLY scm_apply
1615 #define PREP_APPLY(proc, args)
1617 #define RETURN(x) do { return x; } while (0)
1618 #ifdef STACK_CHECKING
1619 #ifndef NO_CEVAL_STACK_CHECKING
1620 #define EVAL_STACK_CHECKING
1627 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1629 #define SCM_APPLY scm_dapply
1631 #define PREP_APPLY(p, l) \
1632 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1634 #define ENTER_APPLY \
1636 SCM_SET_ARGSREADY (debug);\
1637 if (scm_check_apply_p && SCM_TRAPS_P)\
1638 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1640 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1641 SCM_SET_TRACED_FRAME (debug); \
1643 if (SCM_CHEAPTRAPS_P)\
1645 tmp = scm_make_debugobj (&debug);\
1646 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1651 tmp = scm_make_continuation (&first);\
1653 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1659 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1660 #ifdef STACK_CHECKING
1661 #ifndef EVAL_STACK_CHECKING
1662 #define EVAL_STACK_CHECKING
1666 /* scm_ceval_ptr points to the currently selected evaluator.
1667 * *fixme*: Although efficiency is important here, this state variable
1668 * should probably not be a global. It should be related to the
1673 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1675 /* scm_last_debug_frame contains a pointer to the last debugging
1676 * information stack frame. It is accessed very often from the
1677 * debugging evaluator, so it should probably not be indirectly
1678 * addressed. Better to save and restore it from the current root at
1682 /* scm_debug_eframe_size is the number of slots available for pseudo
1683 * stack frames at each real stack frame.
1686 long scm_debug_eframe_size
;
1688 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1690 long scm_eval_stack
;
1692 scm_t_option scm_eval_opts
[] = {
1693 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1696 scm_t_option scm_debug_opts
[] = {
1697 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1698 "*Flyweight representation of the stack at traps." },
1699 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1700 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1701 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1702 "Record procedure names at definition." },
1703 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1704 "Display backtrace in anti-chronological order." },
1705 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1706 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1707 { SCM_OPTION_INTEGER
, "frames", 3,
1708 "Maximum number of tail-recursive frames in backtrace." },
1709 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1710 "Maximal number of stored backtrace frames." },
1711 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1712 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1713 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1714 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1715 { 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."}
1718 scm_t_option scm_evaluator_trap_table
[] = {
1719 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1720 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1721 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1722 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1723 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1724 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1725 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1728 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1730 "Option interface for the evaluation options. Instead of using\n"
1731 "this procedure directly, use the procedures @code{eval-enable},\n"
1732 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1733 #define FUNC_NAME s_scm_eval_options_interface
1737 ans
= scm_options (setting
,
1741 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1747 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1749 "Option interface for the evaluator trap options.")
1750 #define FUNC_NAME s_scm_evaluator_traps
1754 ans
= scm_options (setting
,
1755 scm_evaluator_trap_table
,
1756 SCM_N_EVALUATOR_TRAPS
,
1758 SCM_RESET_DEBUG_MODE
;
1765 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1767 SCM
*results
= lloc
, res
;
1768 while (SCM_CONSP (l
))
1770 res
= EVALCAR (l
, env
);
1772 *lloc
= scm_list_1 (res
);
1773 lloc
= SCM_CDRLOC (*lloc
);
1777 scm_wrong_num_args (proc
);
1784 /* SECTION: This code is compiled twice.
1788 /* Update the toplevel environment frame ENV so that it refers to the
1789 * current module. */
1790 #define UPDATE_TOPLEVEL_ENV(env) \
1792 SCM p = scm_current_module_lookup_closure (); \
1793 if (p != SCM_CAR(env)) \
1794 env = scm_top_level_env (p); \
1798 /* This is the evaluator. Like any real monster, it has three heads:
1800 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1801 * version. Both are implemented using a common code base, using the
1802 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1803 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1804 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1805 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1806 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1807 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1808 * are enclosed within #ifdef DEVAL ... #endif.
1810 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1811 * take two input parameters, x and env: x is a single expression to be
1812 * evalutated. env is the environment in which bindings are searched.
1814 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1815 * is a single expression, it is necessarily in a tail position. If x is just
1816 * a call to another function like in the expression (foo exp1 exp2 ...), the
1817 * realization of that call therefore _must_not_ increase stack usage (the
1818 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1819 * making extensive use of 'goto' statements within the evaluator: The gotos
1820 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1821 * that SCM_CEVAL was already using. If, however, x represents some form that
1822 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1823 * then recursive calls to SCM_CEVAL are performed for all but the last
1824 * expression of that sequence. */
1828 scm_ceval (SCM x
, SCM env
)
1834 scm_deval (SCM x
, SCM env
)
1839 SCM_CEVAL (SCM x
, SCM env
)
1843 scm_t_debug_frame debug
;
1844 scm_t_debug_info
*debug_info_end
;
1845 debug
.prev
= scm_last_debug_frame
;
1848 * The debug.vect contains twice as much scm_t_debug_info frames as the
1849 * user has specified with (debug-set! frames <n>).
1851 * Even frames are eval frames, odd frames are apply frames.
1853 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1854 * sizeof (scm_t_debug_info
));
1855 debug
.info
= debug
.vect
;
1856 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1857 scm_last_debug_frame
= &debug
;
1859 #ifdef EVAL_STACK_CHECKING
1860 if (scm_stack_checking_enabled_p
1861 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1864 debug
.info
->e
.exp
= x
;
1865 debug
.info
->e
.env
= env
;
1867 scm_report_stack_overflow ();
1877 SCM_CLEAR_ARGSREADY (debug
);
1878 if (SCM_OVERFLOWP (debug
))
1881 * In theory, this should be the only place where it is necessary to
1882 * check for space in debug.vect since both eval frames and
1883 * available space are even.
1885 * For this to be the case, however, it is necessary that primitive
1886 * special forms which jump back to `loop', `begin' or some similar
1887 * label call PREP_APPLY.
1889 else if (++debug
.info
>= debug_info_end
)
1891 SCM_SET_OVERFLOW (debug
);
1896 debug
.info
->e
.exp
= x
;
1897 debug
.info
->e
.env
= env
;
1898 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1900 if (SCM_ENTER_FRAME_P
1901 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1904 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1905 SCM_SET_TAILREC (debug
);
1906 if (SCM_CHEAPTRAPS_P
)
1907 stackrep
= scm_make_debugobj (&debug
);
1911 SCM val
= scm_make_continuation (&first
);
1921 /* This gives the possibility for the debugger to
1922 modify the source expression before evaluation. */
1927 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1928 scm_sym_enter_frame
,
1931 scm_unmemocopy (x
, env
));
1938 switch (SCM_TYP7 (x
))
1940 case scm_tc7_symbol
:
1941 /* Only happens when called at top level. */
1942 x
= scm_cons (x
, SCM_UNDEFINED
);
1943 RETURN (*scm_lookupcar (x
, env
, 1));
1945 case SCM_BIT8 (SCM_IM_AND
):
1947 while (!SCM_NULLP (SCM_CDR (x
)))
1949 SCM test_result
= EVALCAR (x
, env
);
1950 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1951 RETURN (SCM_BOOL_F
);
1955 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1958 case SCM_BIT8 (SCM_IM_BEGIN
):
1961 RETURN (SCM_UNSPECIFIED
);
1963 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1966 /* If we are on toplevel with a lookup closure, we need to sync
1967 with the current module. */
1968 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1970 UPDATE_TOPLEVEL_ENV (env
);
1971 while (!SCM_NULLP (SCM_CDR (x
)))
1974 UPDATE_TOPLEVEL_ENV (env
);
1980 goto nontoplevel_begin
;
1983 while (!SCM_NULLP (SCM_CDR (x
)))
1985 SCM form
= SCM_CAR (x
);
1988 if (SCM_ISYMP (form
))
1990 SOURCE_SECTION_START
;
1991 /* check for race condition */
1992 if (SCM_ISYMP (SCM_CAR (x
)))
1993 x
= scm_m_expand_body (x
, env
);
1995 goto nontoplevel_begin
;
1998 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2001 SCM_CEVAL (form
, env
);
2007 /* scm_eval last form in list */
2008 SCM last_form
= SCM_CAR (x
);
2010 if (SCM_CONSP (last_form
))
2012 /* This is by far the most frequent case. */
2014 goto loop
; /* tail recurse */
2016 else if (SCM_IMP (last_form
))
2017 RETURN (SCM_EVALIM (last_form
, env
));
2018 else if (SCM_VARIABLEP (last_form
))
2019 RETURN (SCM_VARIABLE_REF (last_form
));
2020 else if (SCM_SYMBOLP (last_form
))
2021 RETURN (*scm_lookupcar (x
, env
, 1));
2027 case SCM_BIT8 (SCM_IM_CASE
):
2030 SCM key
= EVALCAR (x
, env
);
2032 while (!SCM_NULLP (x
))
2034 SCM clause
= SCM_CAR (x
);
2035 SCM labels
= SCM_CAR (clause
);
2036 if (SCM_EQ_P (labels
, scm_sym_else
))
2038 x
= SCM_CDR (clause
);
2039 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2042 while (!SCM_NULLP (labels
))
2044 SCM label
= SCM_CAR (labels
);
2045 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2047 x
= SCM_CDR (clause
);
2048 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2051 labels
= SCM_CDR (labels
);
2056 RETURN (SCM_UNSPECIFIED
);
2059 case SCM_BIT8 (SCM_IM_COND
):
2061 while (!SCM_NULLP (x
))
2063 SCM clause
= SCM_CAR (x
);
2064 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2066 x
= SCM_CDR (clause
);
2067 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2072 arg1
= EVALCAR (clause
, env
);
2073 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2075 x
= SCM_CDR (clause
);
2078 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2080 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2086 proc
= EVALCAR (proc
, env
);
2087 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2088 PREP_APPLY (proc
, scm_list_1 (arg1
));
2090 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2091 goto umwrongnumargs
;
2099 RETURN (SCM_UNSPECIFIED
);
2102 case SCM_BIT8 (SCM_IM_DO
):
2105 /* Compute the initialization values and the initial environment. */
2106 SCM init_forms
= SCM_CADR (x
);
2107 SCM init_values
= SCM_EOL
;
2108 while (!SCM_NULLP (init_forms
))
2110 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2111 init_forms
= SCM_CDR (init_forms
);
2113 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2117 SCM test_form
= SCM_CAR (x
);
2118 SCM body_forms
= SCM_CADR (x
);
2119 SCM step_forms
= SCM_CDDR (x
);
2121 SCM test_result
= EVALCAR (test_form
, env
);
2123 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2126 /* Evaluate body forms. */
2128 for (temp_forms
= body_forms
;
2129 !SCM_NULLP (temp_forms
);
2130 temp_forms
= SCM_CDR (temp_forms
))
2132 SCM form
= SCM_CAR (temp_forms
);
2133 /* Dirk:FIXME: We only need to eval forms, that may have a
2134 * side effect here. This is only true for forms that start
2135 * with a pair. All others are just constants. However,
2136 * since in the common case there is no constant expression
2137 * in a body of a do form, we just check for immediates here
2138 * and have SCM_CEVAL take care of other cases. In the long
2139 * run it would make sense to get rid of this test and have
2140 * the macro transformer of 'do' eliminate all forms that
2141 * have no sideeffect. */
2142 if (!SCM_IMP (form
))
2143 SCM_CEVAL (form
, env
);
2148 /* Evaluate the step expressions. */
2150 SCM step_values
= SCM_EOL
;
2151 for (temp_forms
= step_forms
;
2152 !SCM_NULLP (temp_forms
);
2153 temp_forms
= SCM_CDR (temp_forms
))
2155 SCM value
= EVALCAR (temp_forms
, env
);
2156 step_values
= scm_cons (value
, step_values
);
2158 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2161 test_result
= EVALCAR (test_form
, env
);
2166 RETURN (SCM_UNSPECIFIED
);
2167 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2168 goto nontoplevel_begin
;
2171 case SCM_BIT8 (SCM_IM_IF
):
2174 SCM test_result
= EVALCAR (x
, env
);
2175 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2181 RETURN (SCM_UNSPECIFIED
);
2184 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2188 case SCM_BIT8 (SCM_IM_LET
):
2191 SCM init_forms
= SCM_CADR (x
);
2192 SCM init_values
= SCM_EOL
;
2195 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2196 init_forms
= SCM_CDR (init_forms
);
2198 while (!SCM_NULLP (init_forms
));
2199 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2202 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2203 goto nontoplevel_begin
;
2206 case SCM_BIT8 (SCM_IM_LETREC
):
2208 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2211 SCM init_forms
= SCM_CAR (x
);
2212 SCM init_values
= SCM_EOL
;
2215 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2216 init_forms
= SCM_CDR (init_forms
);
2218 while (!SCM_NULLP (init_forms
));
2219 SCM_SETCDR (SCM_CAR (env
), init_values
);
2222 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2223 goto nontoplevel_begin
;
2226 case SCM_BIT8 (SCM_IM_LETSTAR
):
2229 SCM bindings
= SCM_CAR (x
);
2230 if (SCM_NULLP (bindings
))
2231 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2236 SCM name
= SCM_CAR (bindings
);
2237 SCM init
= SCM_CDR (bindings
);
2238 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2239 bindings
= SCM_CDR (init
);
2241 while (!SCM_NULLP (bindings
));
2245 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2246 goto nontoplevel_begin
;
2249 case SCM_BIT8 (SCM_IM_OR
):
2251 while (!SCM_NULLP (SCM_CDR (x
)))
2253 SCM val
= EVALCAR (x
, env
);
2254 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2259 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2263 case SCM_BIT8 (SCM_IM_LAMBDA
):
2264 RETURN (scm_closure (SCM_CDR (x
), env
));
2267 case SCM_BIT8 (SCM_IM_QUOTE
):
2268 RETURN (SCM_CADR (x
));
2271 case SCM_BIT8 (SCM_IM_SET_X
):
2275 SCM variable
= SCM_CAR (x
);
2276 if (SCM_ILOCP (variable
))
2277 location
= scm_ilookup (variable
, env
);
2278 else if (SCM_VARIABLEP (variable
))
2279 location
= SCM_VARIABLE_LOC (variable
);
2280 else /* (SCM_SYMBOLP (variable)) is known to be true */
2281 location
= scm_lookupcar (x
, env
, 1);
2283 *location
= EVALCAR (x
, env
);
2285 RETURN (SCM_UNSPECIFIED
);
2288 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2289 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2292 /* new syntactic forms go here. */
2293 case SCM_BIT8 (SCM_MAKISYM (0)):
2295 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2296 switch (SCM_ISYMNUM (proc
))
2300 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2302 proc
= EVALCAR (proc
, env
);
2303 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2304 if (SCM_CLOSUREP (proc
))
2306 PREP_APPLY (proc
, SCM_EOL
);
2307 arg1
= SCM_CDDR (x
);
2308 arg1
= EVALCAR (arg1
, env
);
2310 /* Go here to tail-call a closure. PROC is the closure
2311 and ARG1 is the list of arguments. Do not forget to
2314 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2316 debug
.info
->a
.args
= arg1
;
2318 if (scm_badargsp (formals
, arg1
))
2319 scm_wrong_num_args (proc
);
2321 /* Copy argument list */
2322 if (SCM_NULL_OR_NIL_P (arg1
))
2323 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2326 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2328 arg1
= SCM_CDR (arg1
);
2329 while (!SCM_NULL_OR_NIL_P (arg1
))
2331 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2332 SCM_SETCDR (tail
, new_tail
);
2334 arg1
= SCM_CDR (arg1
);
2336 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2339 x
= SCM_CLOSURE_BODY (proc
);
2340 goto nontoplevel_begin
;
2350 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2353 SCM val
= scm_make_continuation (&first
);
2361 proc
= scm_eval_car (proc
, env
);
2362 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2363 PREP_APPLY (proc
, scm_list_1 (arg1
));
2365 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2366 goto umwrongnumargs
;
2372 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2373 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2376 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2378 /* If not done yet, evaluate the operand forms. The result is a
2379 * list of arguments stored in arg1, which is used to perform the
2380 * function dispatch. */
2381 SCM operand_forms
= SCM_CADR (x
);
2382 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2383 if (SCM_ILOCP (operand_forms
))
2384 arg1
= *scm_ilookup (operand_forms
, env
);
2385 else if (SCM_VARIABLEP (operand_forms
))
2386 arg1
= SCM_VARIABLE_REF (operand_forms
);
2387 else if (!SCM_CONSP (operand_forms
))
2388 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2391 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2392 operand_forms
= SCM_CDR (operand_forms
);
2393 while (!SCM_NULLP (operand_forms
))
2395 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2396 SCM_SETCDR (tail
, new_tail
);
2398 operand_forms
= SCM_CDR (operand_forms
);
2403 /* The type dispatch code is duplicated below
2404 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2405 * cuts down execution time for type dispatch to 50%. */
2406 type_dispatch
: /* inputs: x, arg1 */
2407 /* Type dispatch means to determine from the types of the function
2408 * arguments (i. e. the 'signature' of the call), which method from
2409 * a generic function is to be called. This process of selecting
2410 * the right method takes some time. To speed it up, guile uses
2411 * caching: Together with the macro call to dispatch the signatures
2412 * of some previous calls to that generic function from the same
2413 * place are stored (in the code!) in a cache that we call the
2414 * 'method cache'. This is done since it is likely, that
2415 * consecutive calls to dispatch from that position in the code will
2416 * have the same signature. Thus, the type dispatch works as
2417 * follows: First, determine a hash value from the signature of the
2418 * actual arguments. Second, use this hash value as an index to
2419 * find that same signature in the method cache stored at this
2420 * position in the code. If found, you have also found the
2421 * corresponding method that belongs to that signature. If the
2422 * signature is not found in the method cache, you have to perform a
2423 * full search over all signatures stored with the generic
2426 unsigned long int specializers
;
2427 unsigned long int hash_value
;
2428 unsigned long int cache_end_pos
;
2429 unsigned long int mask
;
2433 SCM z
= SCM_CDDR (x
);
2434 SCM tmp
= SCM_CADR (z
);
2435 specializers
= SCM_INUM (SCM_CAR (z
));
2437 /* Compute a hash value for searching the method cache. There
2438 * are two variants for computing the hash value, a (rather)
2439 * complicated one, and a simple one. For the complicated one
2440 * explained below, tmp holds a number that is used in the
2442 if (SCM_INUMP (tmp
))
2444 /* Use the signature of the actual arguments to determine
2445 * the hash value. This is done as follows: Each class has
2446 * an array of random numbers, that are determined when the
2447 * class is created. The integer 'hashset' is an index into
2448 * that array of random numbers. Now, from all classes that
2449 * are part of the signature of the actual arguments, the
2450 * random numbers at index 'hashset' are taken and summed
2451 * up, giving the hash value. The value of 'hashset' is
2452 * stored at the call to dispatch. This allows to have
2453 * different 'formulas' for calculating the hash value at
2454 * different places where dispatch is called. This allows
2455 * to optimize the hash formula at every individual place
2456 * where dispatch is called, such that hopefully the hash
2457 * value that is computed will directly point to the right
2458 * method in the method cache. */
2459 unsigned long int hashset
= SCM_INUM (tmp
);
2460 unsigned long int counter
= specializers
+ 1;
2463 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2465 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2466 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2467 tmp_arg
= SCM_CDR (tmp_arg
);
2471 method_cache
= SCM_CADR (z
);
2472 mask
= SCM_INUM (SCM_CAR (z
));
2474 cache_end_pos
= hash_value
;
2478 /* This method of determining the hash value is much
2479 * simpler: Set the hash value to zero and just perform a
2480 * linear search through the method cache. */
2482 mask
= (unsigned long int) ((long) -1);
2484 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2489 /* Search the method cache for a method with a matching
2490 * signature. Start the search at position 'hash_value'. The
2491 * hashing implementation uses linear probing for conflict
2492 * resolution, that is, if the signature in question is not
2493 * found at the starting index in the hash table, the next table
2494 * entry is tried, and so on, until in the worst case the whole
2495 * cache has been searched, but still the signature has not been
2500 SCM args
= arg1
; /* list of arguments */
2501 z
= SCM_VELTS (method_cache
)[hash_value
];
2502 while (!SCM_NULLP (args
))
2504 /* More arguments than specifiers => CLASS != ENV */
2505 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2506 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2508 args
= SCM_CDR (args
);
2511 /* Fewer arguments than specifiers => CAR != ENV */
2512 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2515 hash_value
= (hash_value
+ 1) & mask
;
2516 } while (hash_value
!= cache_end_pos
);
2518 /* No appropriate method was found in the cache. */
2519 z
= scm_memoize_method (x
, arg1
);
2521 apply_cmethod
: /* inputs: z, arg1 */
2523 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2524 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2525 x
= SCM_CMETHOD_BODY (z
);
2526 goto nontoplevel_begin
;
2532 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2535 SCM instance
= EVALCAR (x
, env
);
2536 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2537 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2541 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2544 SCM instance
= EVALCAR (x
, env
);
2545 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2546 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2547 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2548 RETURN (SCM_UNSPECIFIED
);
2552 #ifdef SCM_ENABLE_ELISP
2554 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2556 SCM test_form
= SCM_CDR (x
);
2557 x
= SCM_CDR (test_form
);
2558 while (!SCM_NULL_OR_NIL_P (x
))
2560 SCM test_result
= EVALCAR (test_form
, env
);
2561 if (!(SCM_FALSEP (test_result
)
2562 || SCM_NULL_OR_NIL_P (test_result
)))
2564 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2565 RETURN (test_result
);
2566 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2571 test_form
= SCM_CDR (x
);
2572 x
= SCM_CDR (test_form
);
2576 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2580 #endif /* SCM_ENABLE_ELISP */
2582 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2584 SCM vars
, exps
, vals
;
2587 vars
= SCM_CAAR (x
);
2588 exps
= SCM_CDAR (x
);
2592 while (SCM_NIMP (exps
))
2594 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2595 exps
= SCM_CDR (exps
);
2598 scm_swap_bindings (vars
, vals
);
2599 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2601 /* Ignore all but the last evaluation result. */
2602 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2604 if (SCM_CONSP (SCM_CAR (x
)))
2605 SCM_CEVAL (SCM_CAR (x
), env
);
2607 proc
= EVALCAR (x
, env
);
2609 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2610 scm_swap_bindings (vars
, vals
);
2616 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2619 x
= EVALCAR (proc
, env
);
2620 proc
= SCM_CDR (proc
);
2621 proc
= EVALCAR (proc
, env
);
2622 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2623 if (SCM_VALUESP (arg1
))
2624 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2626 arg1
= scm_list_1 (arg1
);
2627 if (SCM_CLOSUREP (proc
))
2629 PREP_APPLY (proc
, arg1
);
2632 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2643 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2644 case scm_tc7_vector
:
2648 case scm_tc7_byvect
:
2655 #ifdef HAVE_LONG_LONGS
2656 case scm_tc7_llvect
:
2659 case scm_tc7_string
:
2661 case scm_tcs_closures
:
2665 case scm_tcs_struct
:
2668 case scm_tc7_variable
:
2669 RETURN (SCM_VARIABLE_REF(x
));
2671 case SCM_BIT8(SCM_ILOC00
):
2672 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2673 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2676 case scm_tcs_cons_nimcar
:
2677 if (SCM_SYMBOLP (SCM_CAR (x
)))
2679 SCM orig_sym
= SCM_CAR (x
);
2681 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2682 if (location
== NULL
)
2684 /* we have lost the race, start again. */
2692 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2696 if (SCM_MACROP (proc
))
2698 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2700 handle_a_macro
: /* inputs: x, env, proc */
2702 /* Set a flag during macro expansion so that macro
2703 application frames can be deleted from the backtrace. */
2704 SCM_SET_MACROEXP (debug
);
2706 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2707 scm_cons (env
, scm_listofnull
));
2710 SCM_CLEAR_MACROEXP (debug
);
2712 switch (SCM_MACRO_TYPE (proc
))
2715 if (scm_ilength (arg1
) <= 0)
2716 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2718 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2721 SCM_SETCAR (x
, SCM_CAR (arg1
));
2722 SCM_SETCDR (x
, SCM_CDR (arg1
));
2726 /* Prevent memoizing of debug info expression. */
2727 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2732 SCM_SETCAR (x
, SCM_CAR (arg1
));
2733 SCM_SETCDR (x
, SCM_CDR (arg1
));
2735 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2737 #if SCM_ENABLE_DEPRECATED == 1
2742 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2754 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2755 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2758 if (SCM_CLOSUREP (proc
))
2760 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2761 SCM args
= SCM_CDR (x
);
2762 while (!SCM_NULLP (formals
))
2764 if (!SCM_CONSP (formals
))
2767 goto umwrongnumargs
;
2768 formals
= SCM_CDR (formals
);
2769 args
= SCM_CDR (args
);
2771 if (!SCM_NULLP (args
))
2772 goto umwrongnumargs
;
2774 else if (SCM_MACROP (proc
))
2775 goto handle_a_macro
;
2779 evapply
: /* inputs: x, proc */
2780 PREP_APPLY (proc
, SCM_EOL
);
2781 if (SCM_NULLP (SCM_CDR (x
))) {
2784 switch (SCM_TYP7 (proc
))
2785 { /* no arguments given */
2786 case scm_tc7_subr_0
:
2787 RETURN (SCM_SUBRF (proc
) ());
2788 case scm_tc7_subr_1o
:
2789 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2791 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2792 case scm_tc7_rpsubr
:
2793 RETURN (SCM_BOOL_T
);
2795 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2797 if (!SCM_SMOB_APPLICABLE_P (proc
))
2799 RETURN (SCM_SMOB_APPLY_0 (proc
));
2802 proc
= SCM_CCLO_SUBR (proc
);
2804 debug
.info
->a
.proc
= proc
;
2805 debug
.info
->a
.args
= scm_list_1 (arg1
);
2809 proc
= SCM_PROCEDURE (proc
);
2811 debug
.info
->a
.proc
= proc
;
2813 if (!SCM_CLOSUREP (proc
))
2815 if (scm_badformalsp (proc
, 0))
2816 goto umwrongnumargs
;
2817 case scm_tcs_closures
:
2818 x
= SCM_CLOSURE_BODY (proc
);
2819 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2820 goto nontoplevel_begin
;
2821 case scm_tcs_struct
:
2822 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2824 x
= SCM_ENTITY_PROCEDURE (proc
);
2828 else if (!SCM_I_OPERATORP (proc
))
2833 proc
= (SCM_I_ENTITYP (proc
)
2834 ? SCM_ENTITY_PROCEDURE (proc
)
2835 : SCM_OPERATOR_PROCEDURE (proc
));
2837 debug
.info
->a
.proc
= proc
;
2838 debug
.info
->a
.args
= scm_list_1 (arg1
);
2840 if (SCM_NIMP (proc
))
2845 case scm_tc7_subr_1
:
2846 case scm_tc7_subr_2
:
2847 case scm_tc7_subr_2o
:
2849 case scm_tc7_subr_3
:
2850 case scm_tc7_lsubr_2
:
2853 scm_wrong_num_args (proc
);
2855 /* handle macros here */
2860 /* must handle macros by here */
2863 arg1
= EVALCAR (x
, env
);
2865 scm_wrong_num_args (proc
);
2867 debug
.info
->a
.args
= scm_list_1 (arg1
);
2875 evap1
: /* inputs: proc, arg1 */
2876 switch (SCM_TYP7 (proc
))
2877 { /* have one argument in arg1 */
2878 case scm_tc7_subr_2o
:
2879 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2880 case scm_tc7_subr_1
:
2881 case scm_tc7_subr_1o
:
2882 RETURN (SCM_SUBRF (proc
) (arg1
));
2884 if (SCM_SUBRF (proc
))
2886 if (SCM_INUMP (arg1
))
2888 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2890 else if (SCM_REALP (arg1
))
2892 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2895 else if (SCM_BIGP (arg1
))
2897 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2900 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2901 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2903 proc
= SCM_SNAME (proc
);
2905 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2906 while ('c' != *--chrs
)
2908 SCM_ASSERT (SCM_CONSP (arg1
),
2909 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2910 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2914 case scm_tc7_rpsubr
:
2915 RETURN (SCM_BOOL_T
);
2917 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2920 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2922 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2925 if (!SCM_SMOB_APPLICABLE_P (proc
))
2927 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2931 proc
= SCM_CCLO_SUBR (proc
);
2933 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2934 debug
.info
->a
.proc
= proc
;
2938 proc
= SCM_PROCEDURE (proc
);
2940 debug
.info
->a
.proc
= proc
;
2942 if (!SCM_CLOSUREP (proc
))
2944 if (scm_badformalsp (proc
, 1))
2945 goto umwrongnumargs
;
2946 case scm_tcs_closures
:
2948 x
= SCM_CLOSURE_BODY (proc
);
2950 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2952 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2954 goto nontoplevel_begin
;
2955 case scm_tcs_struct
:
2956 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2958 x
= SCM_ENTITY_PROCEDURE (proc
);
2960 arg1
= debug
.info
->a
.args
;
2962 arg1
= scm_list_1 (arg1
);
2966 else if (!SCM_I_OPERATORP (proc
))
2972 proc
= (SCM_I_ENTITYP (proc
)
2973 ? SCM_ENTITY_PROCEDURE (proc
)
2974 : SCM_OPERATOR_PROCEDURE (proc
));
2976 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2977 debug
.info
->a
.proc
= proc
;
2979 if (SCM_NIMP (proc
))
2984 case scm_tc7_subr_2
:
2985 case scm_tc7_subr_0
:
2986 case scm_tc7_subr_3
:
2987 case scm_tc7_lsubr_2
:
2988 scm_wrong_num_args (proc
);
2994 arg2
= EVALCAR (x
, env
);
2996 scm_wrong_num_args (proc
);
2998 { /* have two or more arguments */
3000 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3003 if (SCM_NULLP (x
)) {
3006 switch (SCM_TYP7 (proc
))
3007 { /* have two arguments */
3008 case scm_tc7_subr_2
:
3009 case scm_tc7_subr_2o
:
3010 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3013 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3015 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3017 case scm_tc7_lsubr_2
:
3018 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3019 case scm_tc7_rpsubr
:
3021 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3023 if (!SCM_SMOB_APPLICABLE_P (proc
))
3025 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3029 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3030 scm_cons (proc
, debug
.info
->a
.args
),
3033 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3034 scm_cons2 (proc
, arg1
,
3041 case scm_tcs_struct
:
3042 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3044 x
= SCM_ENTITY_PROCEDURE (proc
);
3046 arg1
= debug
.info
->a
.args
;
3048 arg1
= scm_list_2 (arg1
, arg2
);
3052 else if (!SCM_I_OPERATORP (proc
))
3058 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3059 ? SCM_ENTITY_PROCEDURE (proc
)
3060 : SCM_OPERATOR_PROCEDURE (proc
),
3061 scm_cons (proc
, debug
.info
->a
.args
),
3064 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3065 ? SCM_ENTITY_PROCEDURE (proc
)
3066 : SCM_OPERATOR_PROCEDURE (proc
),
3067 scm_cons2 (proc
, arg1
,
3075 case scm_tc7_subr_0
:
3077 case scm_tc7_subr_1o
:
3078 case scm_tc7_subr_1
:
3079 case scm_tc7_subr_3
:
3080 scm_wrong_num_args (proc
);
3084 proc
= SCM_PROCEDURE (proc
);
3086 debug
.info
->a
.proc
= proc
;
3088 if (!SCM_CLOSUREP (proc
))
3090 if (scm_badformalsp (proc
, 2))
3091 goto umwrongnumargs
;
3092 case scm_tcs_closures
:
3095 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3099 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3100 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3102 x
= SCM_CLOSURE_BODY (proc
);
3103 goto nontoplevel_begin
;
3107 scm_wrong_num_args (proc
);
3109 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3110 deval_args (x
, env
, proc
,
3111 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3115 switch (SCM_TYP7 (proc
))
3116 { /* have 3 or more arguments */
3118 case scm_tc7_subr_3
:
3119 if (!SCM_NULLP (SCM_CDR (x
)))
3120 scm_wrong_num_args (proc
);
3122 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3123 SCM_CADDR (debug
.info
->a
.args
)));
3125 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3126 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3129 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3130 arg2
= SCM_CDR (arg2
);
3132 while (SCM_NIMP (arg2
));
3134 case scm_tc7_rpsubr
:
3135 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3136 RETURN (SCM_BOOL_F
);
3137 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3140 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3141 RETURN (SCM_BOOL_F
);
3142 arg2
= SCM_CAR (arg1
);
3143 arg1
= SCM_CDR (arg1
);
3145 while (SCM_NIMP (arg1
));
3146 RETURN (SCM_BOOL_T
);
3147 case scm_tc7_lsubr_2
:
3148 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3149 SCM_CDDR (debug
.info
->a
.args
)));
3151 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3153 if (!SCM_SMOB_APPLICABLE_P (proc
))
3155 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3156 SCM_CDDR (debug
.info
->a
.args
)));
3160 proc
= SCM_PROCEDURE (proc
);
3161 debug
.info
->a
.proc
= proc
;
3162 if (!SCM_CLOSUREP (proc
))
3164 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3165 goto umwrongnumargs
;
3166 case scm_tcs_closures
:
3167 SCM_SET_ARGSREADY (debug
);
3168 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3171 x
= SCM_CLOSURE_BODY (proc
);
3172 goto nontoplevel_begin
;
3174 case scm_tc7_subr_3
:
3175 if (!SCM_NULLP (SCM_CDR (x
)))
3176 scm_wrong_num_args (proc
);
3178 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3180 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3183 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3186 while (SCM_NIMP (x
));
3188 case scm_tc7_rpsubr
:
3189 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3190 RETURN (SCM_BOOL_F
);
3193 arg1
= EVALCAR (x
, env
);
3194 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3195 RETURN (SCM_BOOL_F
);
3199 while (SCM_NIMP (x
));
3200 RETURN (SCM_BOOL_T
);
3201 case scm_tc7_lsubr_2
:
3202 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3204 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3206 scm_eval_args (x
, env
, proc
))));
3208 if (!SCM_SMOB_APPLICABLE_P (proc
))
3210 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3211 scm_eval_args (x
, env
, proc
)));
3215 proc
= SCM_PROCEDURE (proc
);
3216 if (!SCM_CLOSUREP (proc
))
3219 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3220 if (SCM_NULLP (formals
)
3221 || (SCM_CONSP (formals
)
3222 && (SCM_NULLP (SCM_CDR (formals
))
3223 || (SCM_CONSP (SCM_CDR (formals
))
3224 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3225 goto umwrongnumargs
;
3227 case scm_tcs_closures
:
3229 SCM_SET_ARGSREADY (debug
);
3231 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3234 scm_eval_args (x
, env
, proc
)),
3236 x
= SCM_CLOSURE_BODY (proc
);
3237 goto nontoplevel_begin
;
3239 case scm_tcs_struct
:
3240 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3243 arg1
= debug
.info
->a
.args
;
3245 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3247 x
= SCM_ENTITY_PROCEDURE (proc
);
3250 else if (!SCM_I_OPERATORP (proc
))
3254 case scm_tc7_subr_2
:
3255 case scm_tc7_subr_1o
:
3256 case scm_tc7_subr_2o
:
3257 case scm_tc7_subr_0
:
3259 case scm_tc7_subr_1
:
3260 scm_wrong_num_args (proc
);
3268 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3269 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3271 SCM_CLEAR_TRACED_FRAME (debug
);
3272 if (SCM_CHEAPTRAPS_P
)
3273 arg1
= scm_make_debugobj (&debug
);
3277 SCM val
= scm_make_continuation (&first
);
3288 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3292 scm_last_debug_frame
= debug
.prev
;
3298 /* SECTION: This code is compiled once.
3304 /* Simple procedure calls
3308 scm_call_0 (SCM proc
)
3310 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3314 scm_call_1 (SCM proc
, SCM arg1
)
3316 return scm_apply (proc
, arg1
, scm_listofnull
);
3320 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3322 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3326 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3328 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3332 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3334 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3335 scm_cons (arg4
, scm_listofnull
)));
3338 /* Simple procedure applies
3342 scm_apply_0 (SCM proc
, SCM args
)
3344 return scm_apply (proc
, args
, SCM_EOL
);
3348 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3350 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3354 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3356 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3360 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3362 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3366 /* This code processes the arguments to apply:
3368 (apply PROC ARG1 ... ARGS)
3370 Given a list (ARG1 ... ARGS), this function conses the ARG1
3371 ... arguments onto the front of ARGS, and returns the resulting
3372 list. Note that ARGS is a list; thus, the argument to this
3373 function is a list whose last element is a list.
3375 Apply calls this function, and applies PROC to the elements of the
3376 result. apply:nconc2last takes care of building the list of
3377 arguments, given (ARG1 ... ARGS).
3379 Rather than do new consing, apply:nconc2last destroys its argument.
3380 On that topic, this code came into my care with the following
3381 beautifully cryptic comment on that topic: "This will only screw
3382 you if you do (scm_apply scm_apply '( ... ))" If you know what
3383 they're referring to, send me a patch to this comment. */
3385 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3387 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3388 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3389 "@var{args}, and returns the resulting list. Note that\n"
3390 "@var{args} is a list; thus, the argument to this function is\n"
3391 "a list whose last element is a list.\n"
3392 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3393 "destroys its argument, so use with care.")
3394 #define FUNC_NAME s_scm_nconc2last
3397 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3399 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3400 SCM_NULL_OR_NIL_P, but not
3401 needed in 99.99% of cases,
3402 and it could seriously hurt
3403 performance. - Neil */
3404 lloc
= SCM_CDRLOC (*lloc
);
3405 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3406 *lloc
= SCM_CAR (*lloc
);
3414 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3415 * It is compiled twice.
3420 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3426 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3431 /* Apply a function to a list of arguments.
3433 This function is exported to the Scheme level as taking two
3434 required arguments and a tail argument, as if it were:
3435 (lambda (proc arg1 . args) ...)
3436 Thus, if you just have a list of arguments to pass to a procedure,
3437 pass the list as ARG1, and '() for ARGS. If you have some fixed
3438 args, pass the first as ARG1, then cons any remaining fixed args
3439 onto the front of your argument list, and pass that as ARGS. */
3442 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3444 #ifdef DEBUG_EXTENSIONS
3446 scm_t_debug_frame debug
;
3447 scm_t_debug_info debug_vect_body
;
3448 debug
.prev
= scm_last_debug_frame
;
3449 debug
.status
= SCM_APPLYFRAME
;
3450 debug
.vect
= &debug_vect_body
;
3451 debug
.vect
[0].a
.proc
= proc
;
3452 debug
.vect
[0].a
.args
= SCM_EOL
;
3453 scm_last_debug_frame
= &debug
;
3456 return scm_dapply (proc
, arg1
, args
);
3460 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3462 /* If ARGS is the empty list, then we're calling apply with only two
3463 arguments --- ARG1 is the list of arguments for PROC. Whatever
3464 the case, futz with things so that ARG1 is the first argument to
3465 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3468 Setting the debug apply frame args this way is pretty messy.
3469 Perhaps we should store arg1 and args directly in the frame as
3470 received, and let scm_frame_arguments unpack them, because that's
3471 a relatively rare operation. This works for now; if the Guile
3472 developer archives are still around, see Mikael's post of
3474 if (SCM_NULLP (args
))
3476 if (SCM_NULLP (arg1
))
3478 arg1
= SCM_UNDEFINED
;
3480 debug
.vect
[0].a
.args
= SCM_EOL
;
3486 debug
.vect
[0].a
.args
= arg1
;
3488 args
= SCM_CDR (arg1
);
3489 arg1
= SCM_CAR (arg1
);
3494 args
= scm_nconc2last (args
);
3496 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3500 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3503 if (SCM_CHEAPTRAPS_P
)
3504 tmp
= scm_make_debugobj (&debug
);
3509 tmp
= scm_make_continuation (&first
);
3514 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3521 switch (SCM_TYP7 (proc
))
3523 case scm_tc7_subr_2o
:
3524 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3525 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3526 case scm_tc7_subr_2
:
3527 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3528 scm_wrong_num_args (proc
);
3529 args
= SCM_CAR (args
);
3530 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3531 case scm_tc7_subr_0
:
3532 if (!SCM_UNBNDP (arg1
))
3533 scm_wrong_num_args (proc
);
3535 RETURN (SCM_SUBRF (proc
) ());
3536 case scm_tc7_subr_1
:
3537 if (SCM_UNBNDP (arg1
))
3538 scm_wrong_num_args (proc
);
3539 case scm_tc7_subr_1o
:
3540 if (!SCM_NULLP (args
))
3541 scm_wrong_num_args (proc
);
3543 RETURN (SCM_SUBRF (proc
) (arg1
));
3545 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3546 scm_wrong_num_args (proc
);
3547 if (SCM_SUBRF (proc
))
3549 if (SCM_INUMP (arg1
))
3551 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3553 else if (SCM_REALP (arg1
))
3555 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3558 else if (SCM_BIGP (arg1
))
3559 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3561 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3562 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3564 proc
= SCM_SNAME (proc
);
3566 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3567 while ('c' != *--chrs
)
3569 SCM_ASSERT (SCM_CONSP (arg1
),
3570 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3571 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3575 case scm_tc7_subr_3
:
3576 if (SCM_NULLP (args
)
3577 || SCM_NULLP (SCM_CDR (args
))
3578 || !SCM_NULLP (SCM_CDDR (args
)))
3579 scm_wrong_num_args (proc
);
3581 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3584 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3586 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3588 case scm_tc7_lsubr_2
:
3589 if (!SCM_CONSP (args
))
3590 scm_wrong_num_args (proc
);
3592 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3594 if (SCM_NULLP (args
))
3595 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3596 while (SCM_NIMP (args
))
3598 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3599 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3600 args
= SCM_CDR (args
);
3603 case scm_tc7_rpsubr
:
3604 if (SCM_NULLP (args
))
3605 RETURN (SCM_BOOL_T
);
3606 while (SCM_NIMP (args
))
3608 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3609 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3610 RETURN (SCM_BOOL_F
);
3611 arg1
= SCM_CAR (args
);
3612 args
= SCM_CDR (args
);
3614 RETURN (SCM_BOOL_T
);
3615 case scm_tcs_closures
:
3617 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3619 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3621 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3622 scm_wrong_num_args (proc
);
3624 /* Copy argument list */
3629 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3630 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3632 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3636 SCM_SETCDR (tl
, arg1
);
3639 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3640 proc
= SCM_CLOSURE_BODY (proc
);
3643 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3645 if (SCM_IMP (SCM_CAR (proc
)))
3647 if (SCM_ISYMP (SCM_CAR (proc
)))
3649 SOURCE_SECTION_START
;
3650 /* check for race condition */
3651 if (SCM_ISYMP (SCM_CAR (proc
)))
3652 proc
= scm_m_expand_body (proc
, args
);
3657 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3660 SCM_CEVAL (SCM_CAR (proc
), args
);
3663 RETURN (EVALCAR (proc
, args
));
3665 if (!SCM_SMOB_APPLICABLE_P (proc
))
3667 if (SCM_UNBNDP (arg1
))
3668 RETURN (SCM_SMOB_APPLY_0 (proc
));
3669 else if (SCM_NULLP (args
))
3670 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3671 else if (SCM_NULLP (SCM_CDR (args
)))
3672 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3674 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3677 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3679 proc
= SCM_CCLO_SUBR (proc
);
3680 debug
.vect
[0].a
.proc
= proc
;
3681 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3683 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3685 proc
= SCM_CCLO_SUBR (proc
);
3689 proc
= SCM_PROCEDURE (proc
);
3691 debug
.vect
[0].a
.proc
= proc
;
3694 case scm_tcs_struct
:
3695 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3698 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3700 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3702 RETURN (scm_apply_generic (proc
, args
));
3704 else if (!SCM_I_OPERATORP (proc
))
3710 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3712 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3715 proc
= (SCM_I_ENTITYP (proc
)
3716 ? SCM_ENTITY_PROCEDURE (proc
)
3717 : SCM_OPERATOR_PROCEDURE (proc
));
3719 debug
.vect
[0].a
.proc
= proc
;
3720 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3722 if (SCM_NIMP (proc
))
3729 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3733 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3734 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3736 SCM_CLEAR_TRACED_FRAME (debug
);
3737 if (SCM_CHEAPTRAPS_P
)
3738 arg1
= scm_make_debugobj (&debug
);
3742 SCM val
= scm_make_continuation (&first
);
3753 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3757 scm_last_debug_frame
= debug
.prev
;
3763 /* SECTION: The rest of this file is only read once.
3770 * Trampolines make it possible to move procedure application dispatch
3771 * outside inner loops. The motivation was clean implementation of
3772 * efficient replacements of R5RS primitives in SRFI-1.
3774 * The semantics is clear: scm_trampoline_N returns an optimized
3775 * version of scm_call_N (or NULL if the procedure isn't applicable
3778 * Applying the optimization to map and for-each increased efficiency
3779 * noticeably. For example, (map abs ls) is now 8 times faster than
3784 call_subr1_1 (SCM proc
, SCM arg1
)
3786 return SCM_SUBRF (proc
) (arg1
);
3790 call_lsubr_1 (SCM proc
, SCM arg1
)
3792 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3796 call_dsubr_1 (SCM proc
, SCM arg1
)
3798 if (SCM_INUMP (arg1
))
3800 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3802 else if (SCM_REALP (arg1
))
3804 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3807 else if (SCM_BIGP (arg1
))
3808 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3810 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3811 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3815 call_cxr_1 (SCM proc
, SCM arg1
)
3817 proc
= SCM_SNAME (proc
);
3819 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3820 while ('c' != *--chrs
)
3822 SCM_ASSERT (SCM_CONSP (arg1
),
3823 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3824 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3831 call_closure_1 (SCM proc
, SCM arg1
)
3833 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3834 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3840 scm_trampoline_1 (SCM proc
)
3846 switch (SCM_TYP7 (proc
))
3848 case scm_tc7_subr_1
:
3849 case scm_tc7_subr_1o
:
3850 return call_subr1_1
;
3852 return call_lsubr_1
;
3854 if (SCM_SUBRF (proc
))
3855 return call_dsubr_1
;
3858 case scm_tcs_closures
:
3860 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3861 if (!SCM_CONSP (formals
) || SCM_NULLP (SCM_CDR (formals
)))
3862 return call_closure_1
;
3866 case scm_tcs_struct
:
3867 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3868 return scm_call_generic_1
;
3869 else if (!SCM_I_OPERATORP (proc
))
3873 if (SCM_SMOB_APPLICABLE_P (proc
))
3874 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3879 case scm_tc7_rpsubr
:
3884 return 0; /* not applicable on one arg */
3889 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3891 return SCM_SUBRF (proc
) (arg1
, arg2
);
3895 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3897 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3901 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3903 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3904 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3905 scm_list_2 (arg1
, arg2
),
3910 scm_trampoline_2 (SCM proc
)
3916 switch (SCM_TYP7 (proc
))
3918 case scm_tc7_subr_2
:
3919 case scm_tc7_subr_2o
:
3920 case scm_tc7_rpsubr
:
3922 return call_subr2_2
;
3924 return call_lsubr_2
;
3925 case scm_tcs_closures
:
3927 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3928 if (!SCM_CONSP (formals
)
3929 || (SCM_CONSP (SCM_CDR (formals
))
3930 && SCM_NULLP (SCM_CDDR (formals
))))
3931 return call_closure_2
;
3935 case scm_tcs_struct
:
3936 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3937 return scm_call_generic_2
;
3938 else if (!SCM_I_OPERATORP (proc
))
3942 if (SCM_SMOB_APPLICABLE_P (proc
))
3943 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3951 return 0; /* not applicable on two args */
3955 /* Typechecking for multi-argument MAP and FOR-EACH.
3957 Verify that each element of the vector ARGV, except for the first,
3958 is a proper list whose length is LEN. Attribute errors to WHO,
3959 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3961 check_map_args (SCM argv
,
3968 SCM
const *ve
= SCM_VELTS (argv
);
3971 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3973 long elt_len
= scm_ilength (ve
[i
]);
3978 scm_apply_generic (gf
, scm_cons (proc
, args
));
3980 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3984 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
3987 scm_remember_upto_here_1 (argv
);
3991 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3993 /* Note: Currently, scm_map applies PROC to the argument list(s)
3994 sequentially, starting with the first element(s). This is used in
3995 evalext.c where the Scheme procedure `map-in-order', which guarantees
3996 sequential behaviour, is implemented using scm_map. If the
3997 behaviour changes, we need to update `map-in-order'.
4001 scm_map (SCM proc
, SCM arg1
, SCM args
)
4002 #define FUNC_NAME s_map
4007 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4009 len
= scm_ilength (arg1
);
4010 SCM_GASSERTn (len
>= 0,
4011 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4012 SCM_VALIDATE_REST_ARGUMENT (args
);
4013 if (SCM_NULLP (args
))
4015 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4016 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4017 while (SCM_NIMP (arg1
))
4019 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4020 pres
= SCM_CDRLOC (*pres
);
4021 arg1
= SCM_CDR (arg1
);
4025 if (SCM_NULLP (SCM_CDR (args
)))
4027 SCM arg2
= SCM_CAR (args
);
4028 int len2
= scm_ilength (arg2
);
4029 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4031 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4032 SCM_GASSERTn (len2
>= 0,
4033 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4035 SCM_OUT_OF_RANGE (3, arg2
);
4036 while (SCM_NIMP (arg1
))
4038 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4039 pres
= SCM_CDRLOC (*pres
);
4040 arg1
= SCM_CDR (arg1
);
4041 arg2
= SCM_CDR (arg2
);
4045 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4046 ve
= SCM_VELTS (args
);
4047 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4051 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4053 if (SCM_IMP (ve
[i
]))
4055 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4056 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4058 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4059 pres
= SCM_CDRLOC (*pres
);
4065 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4068 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4069 #define FUNC_NAME s_for_each
4071 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4073 len
= scm_ilength (arg1
);
4074 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4075 SCM_ARG2
, s_for_each
);
4076 SCM_VALIDATE_REST_ARGUMENT (args
);
4077 if (SCM_NULLP (args
))
4079 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4080 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4081 while (SCM_NIMP (arg1
))
4083 call (proc
, SCM_CAR (arg1
));
4084 arg1
= SCM_CDR (arg1
);
4086 return SCM_UNSPECIFIED
;
4088 if (SCM_NULLP (SCM_CDR (args
)))
4090 SCM arg2
= SCM_CAR (args
);
4091 int len2
= scm_ilength (arg2
);
4092 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4093 SCM_GASSERTn (call
, g_for_each
,
4094 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4095 SCM_GASSERTn (len2
>= 0, g_for_each
,
4096 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4098 SCM_OUT_OF_RANGE (3, arg2
);
4099 while (SCM_NIMP (arg1
))
4101 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4102 arg1
= SCM_CDR (arg1
);
4103 arg2
= SCM_CDR (arg2
);
4105 return SCM_UNSPECIFIED
;
4107 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4108 ve
= SCM_VELTS (args
);
4109 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4113 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4115 if (SCM_IMP (ve
[i
]))
4116 return SCM_UNSPECIFIED
;
4117 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4118 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4120 scm_apply (proc
, arg1
, SCM_EOL
);
4127 scm_closure (SCM code
, SCM env
)
4130 SCM closcar
= scm_cons (code
, SCM_EOL
);
4131 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4132 scm_remember_upto_here (closcar
);
4137 scm_t_bits scm_tc16_promise
;
4140 scm_makprom (SCM code
)
4142 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
4148 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4150 int writingp
= SCM_WRITINGP (pstate
);
4151 scm_puts ("#<promise ", port
);
4152 SCM_SET_WRITINGP (pstate
, 1);
4153 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
4154 SCM_SET_WRITINGP (pstate
, writingp
);
4155 scm_putc ('>', port
);
4160 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4162 "If the promise @var{x} has not been computed yet, compute and\n"
4163 "return @var{x}, otherwise just return the previously computed\n"
4165 #define FUNC_NAME s_scm_force
4167 SCM_VALIDATE_SMOB (1, x
, promise
);
4168 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4170 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
4171 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4174 SCM_SET_CELL_OBJECT_1 (x
, ans
);
4175 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
4179 return SCM_CELL_OBJECT_1 (x
);
4184 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4186 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4187 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4188 #define FUNC_NAME s_scm_promise_p
4190 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4195 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4196 (SCM xorig
, SCM x
, SCM y
),
4197 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4198 "Any source properties associated with @var{xorig} are also associated\n"
4199 "with the new pair.")
4200 #define FUNC_NAME s_scm_cons_source
4203 z
= scm_cons (x
, y
);
4204 /* Copy source properties possibly associated with xorig. */
4205 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4207 scm_whash_insert (scm_source_whash
, z
, p
);
4213 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4215 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4216 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4217 "contents of both pairs and vectors (since both cons cells and vector\n"
4218 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4219 "any other object.")
4220 #define FUNC_NAME s_scm_copy_tree
4225 if (SCM_VECTORP (obj
))
4227 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4228 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4230 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4233 if (!SCM_CONSP (obj
))
4235 ans
= tl
= scm_cons_source (obj
,
4236 scm_copy_tree (SCM_CAR (obj
)),
4238 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4240 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4244 SCM_SETCDR (tl
, obj
);
4250 /* We have three levels of EVAL here:
4252 - scm_i_eval (exp, env)
4254 evaluates EXP in environment ENV. ENV is a lexical environment
4255 structure as used by the actual tree code evaluator. When ENV is
4256 a top-level environment, then changes to the current module are
4257 tracked by updating ENV so that it continues to be in sync with
4260 - scm_primitive_eval (exp)
4262 evaluates EXP in the top-level environment as determined by the
4263 current module. This is done by constructing a suitable
4264 environment and calling scm_i_eval. Thus, changes to the
4265 top-level module are tracked normally.
4267 - scm_eval (exp, mod)
4269 evaluates EXP while MOD is the current module. This is done by
4270 setting the current module to MOD, invoking scm_primitive_eval on
4271 EXP, and then restoring the current module to the value it had
4272 previously. That is, while EXP is evaluated, changes to the
4273 current module are tracked, but these changes do not persist when
4276 For each level of evals, there are two variants, distinguished by a
4277 _x suffix: the ordinary variant does not modify EXP while the _x
4278 variant can destructively modify EXP into something completely
4279 unintelligible. A Scheme data structure passed as EXP to one of the
4280 _x variants should not ever be used again for anything. So when in
4281 doubt, use the ordinary variant.
4286 scm_i_eval_x (SCM exp
, SCM env
)
4288 return SCM_XEVAL (exp
, env
);
4292 scm_i_eval (SCM exp
, SCM env
)
4294 exp
= scm_copy_tree (exp
);
4295 return SCM_XEVAL (exp
, env
);
4299 scm_primitive_eval_x (SCM exp
)
4302 SCM transformer
= scm_current_module_transformer ();
4303 if (SCM_NIMP (transformer
))
4304 exp
= scm_call_1 (transformer
, exp
);
4305 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4306 return scm_i_eval_x (exp
, env
);
4309 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4311 "Evaluate @var{exp} in the top-level environment specified by\n"
4312 "the current module.")
4313 #define FUNC_NAME s_scm_primitive_eval
4316 SCM transformer
= scm_current_module_transformer ();
4317 if (SCM_NIMP (transformer
))
4318 exp
= scm_call_1 (transformer
, exp
);
4319 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4320 return scm_i_eval (exp
, env
);
4324 /* Eval does not take the second arg optionally. This is intentional
4325 * in order to be R5RS compatible, and to prepare for the new module
4326 * system, where we would like to make the choice of evaluation
4327 * environment explicit. */
4330 change_environment (void *data
)
4332 SCM pair
= SCM_PACK (data
);
4333 SCM new_module
= SCM_CAR (pair
);
4334 SCM old_module
= scm_current_module ();
4335 SCM_SETCDR (pair
, old_module
);
4336 scm_set_current_module (new_module
);
4341 restore_environment (void *data
)
4343 SCM pair
= SCM_PACK (data
);
4344 SCM old_module
= SCM_CDR (pair
);
4345 SCM new_module
= scm_current_module ();
4346 SCM_SETCAR (pair
, new_module
);
4347 scm_set_current_module (old_module
);
4351 inner_eval_x (void *data
)
4353 return scm_primitive_eval_x (SCM_PACK(data
));
4357 scm_eval_x (SCM exp
, SCM module
)
4358 #define FUNC_NAME "eval!"
4360 SCM_VALIDATE_MODULE (2, module
);
4362 return scm_internal_dynamic_wind
4363 (change_environment
, inner_eval_x
, restore_environment
,
4364 (void *) SCM_UNPACK (exp
),
4365 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4370 inner_eval (void *data
)
4372 return scm_primitive_eval (SCM_PACK(data
));
4375 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4376 (SCM exp
, SCM module
),
4377 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4378 "in the top-level environment specified by @var{module}.\n"
4379 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4380 "@var{module} is made the current module. The current module\n"
4381 "is reset to its previous value when @var{eval} returns.")
4382 #define FUNC_NAME s_scm_eval
4384 SCM_VALIDATE_MODULE (2, module
);
4386 return scm_internal_dynamic_wind
4387 (change_environment
, inner_eval
, restore_environment
,
4388 (void *) SCM_UNPACK (exp
),
4389 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4394 /* At this point, scm_deval and scm_dapply are generated.
4397 #ifdef DEBUG_EXTENSIONS
4407 scm_init_opts (scm_evaluator_traps
,
4408 scm_evaluator_trap_table
,
4409 SCM_N_EVALUATOR_TRAPS
);
4410 scm_init_opts (scm_eval_options_interface
,
4412 SCM_N_EVAL_OPTIONS
);
4414 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4415 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4416 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4418 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4419 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4420 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4421 scm_listofnull
= scm_list_1 (SCM_EOL
);
4423 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4428 #include "libguile/eval.x"
4430 scm_add_feature ("delay");