1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 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/futures.h"
84 #include "libguile/throw.h"
85 #include "libguile/smob.h"
86 #include "libguile/macros.h"
87 #include "libguile/procprop.h"
88 #include "libguile/hashtab.h"
89 #include "libguile/hash.h"
90 #include "libguile/srcprop.h"
91 #include "libguile/stackchk.h"
92 #include "libguile/objects.h"
93 #include "libguile/async.h"
94 #include "libguile/feature.h"
95 #include "libguile/modules.h"
96 #include "libguile/ports.h"
97 #include "libguile/root.h"
98 #include "libguile/vectors.h"
99 #include "libguile/fluids.h"
100 #include "libguile/goops.h"
101 #include "libguile/values.h"
103 #include "libguile/validate.h"
104 #include "libguile/eval.h"
105 #include "libguile/lang.h"
109 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
111 if (SCM_EQ_P ((x), SCM_EOL)) \
112 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
117 /* The evaluator contains a plethora of EVAL symbols.
118 * This is an attempt at explanation.
120 * The following macros should be used in code which is read twice
121 * (where the choice of evaluator is hard soldered):
123 * SCM_CEVAL is the symbol used within one evaluator to call itself.
124 * Originally, it is defined to scm_ceval, but is redefined to
125 * scm_deval during the second pass.
127 * SCM_EVALIM is used when it is known that the expression is an
128 * immediate. (This macro never calls an evaluator.)
130 * EVALCAR evaluates the car of an expression.
132 * The following macros should be used in code which is read once
133 * (where the choice of evaluator is dynamic):
135 * SCM_XEVAL takes care of immediates without calling an evaluator. It
136 * then calls scm_ceval *or* scm_deval, depending on the debugging
139 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
140 * depending on the debugging mode.
142 * The main motivation for keeping this plethora is efficiency
143 * together with maintainability (=> locality of code).
146 #define SCM_CEVAL scm_ceval
148 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
149 ? SCM_EVALIM (SCM_CAR (x), env) \
150 : (SCM_SYMBOLP (SCM_CAR (x)) \
151 ? *scm_lookupcar (x, env, 1) \
152 : SCM_CEVAL (SCM_CAR (x), env)))
154 #define EXTEND_ENV SCM_EXTEND_ENV
156 SCM_REC_MUTEX (source_mutex
);
159 scm_ilookup (SCM iloc
, SCM env
)
161 register long ir
= SCM_IFRAME (iloc
);
162 register SCM er
= env
;
163 for (; 0 != ir
; --ir
)
166 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
168 if (SCM_ICDRP (iloc
))
169 return SCM_CDRLOC (er
);
170 return SCM_CARLOC (SCM_CDR (er
));
173 /* The Lookup Car Race
176 Memoization of variables and special forms is done while executing
177 the code for the first time. As long as there is only one thread
178 everything is fine, but as soon as two threads execute the same
179 code concurrently `for the first time' they can come into conflict.
181 This memoization includes rewriting variable references into more
182 efficient forms and expanding macros. Furthermore, macro expansion
183 includes `compiling' special forms like `let', `cond', etc. into
184 tree-code instructions.
186 There shouldn't normally be a problem with memoizing local and
187 global variable references (into ilocs and variables), because all
188 threads will mutate the code in *exactly* the same way and (if I
189 read the C code correctly) it is not possible to observe a half-way
190 mutated cons cell. The lookup procedure can handle this
191 transparently without any critical sections.
193 It is different with macro expansion, because macro expansion
194 happens outside of the lookup procedure and can't be
195 undone. Therefore the lookup procedure can't cope with it. It has
196 to indicate failure when it detects a lost race and hope that the
197 caller can handle it. Luckily, it turns out that this is the case.
199 An example to illustrate this: Suppose that the following form will
200 be memoized concurrently by two threads
204 Let's first examine the lookup of X in the body. The first thread
205 decides that it has to find the symbol "x" in the environment and
206 starts to scan it. Then the other thread takes over and actually
207 overtakes the first. It looks up "x" and substitutes an
208 appropriate iloc for it. Now the first thread continues and
209 completes its lookup. It comes to exactly the same conclusions as
210 the second one and could - without much ado - just overwrite the
211 iloc with the same iloc.
213 But let's see what will happen when the race occurs while looking
214 up the symbol "let" at the start of the form. It could happen that
215 the second thread interrupts the lookup of the first thread and not
216 only substitutes a variable for it but goes right ahead and
217 replaces it with the compiled form (#@let* (x 12) x). Now, when
218 the first thread completes its lookup, it would replace the #@let*
219 with a variable containing the "let" binding, effectively reverting
220 the form to (let (x 12) x). This is wrong. It has to detect that
221 it has lost the race and the evaluator has to reconsider the
222 changed form completely.
224 This race condition could be resolved with some kind of traffic
225 light (like mutexes) around scm_lookupcar, but I think that it is
226 best to avoid them in this case. They would serialize memoization
227 completely and because lookup involves calling arbitrary Scheme
228 code (via the lookup-thunk), threads could be blocked for an
229 arbitrary amount of time or even deadlock. But with the current
230 solution a lot of unnecessary work is potentially done. */
232 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
233 return NULL to indicate a failed lookup due to some race conditions
234 between threads. This only happens when VLOC is the first cell of
235 a special form that will eventually be memoized (like `let', etc.)
236 In that case the whole lookup is bogus and the caller has to
237 reconsider the complete special form.
239 SCM_LOOKUPCAR is still there, of course. It just calls
240 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
241 should only be called when it is known that VLOC is not the first
242 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
243 for NULL. I think I've found the only places where this
246 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
249 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
252 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
253 register SCM iloc
= SCM_ILOC00
;
254 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
256 if (!SCM_CONSP (SCM_CAR (env
)))
258 al
= SCM_CARLOC (env
);
259 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
263 if (SCM_EQ_P (fl
, var
))
265 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
267 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
268 return SCM_CDRLOC (*al
);
273 al
= SCM_CDRLOC (*al
);
274 if (SCM_EQ_P (SCM_CAR (fl
), var
))
276 if (SCM_UNBNDP (SCM_CAR (*al
)))
281 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
283 SCM_SETCAR (vloc
, iloc
);
284 return SCM_CARLOC (*al
);
286 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
288 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
291 SCM top_thunk
, real_var
;
294 top_thunk
= SCM_CAR (env
); /* env now refers to a
295 top level env thunk */
299 top_thunk
= SCM_BOOL_F
;
300 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
301 if (SCM_FALSEP (real_var
))
304 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
310 scm_error (scm_unbound_variable_key
, NULL
,
311 "Unbound variable: ~S",
312 scm_list_1 (var
), SCM_BOOL_F
);
314 scm_misc_error (NULL
, "Damaged environment: ~S",
319 /* A variable could not be found, but we shall
320 not throw an error. */
321 static SCM undef_object
= SCM_UNDEFINED
;
322 return &undef_object
;
326 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
328 /* Some other thread has changed the very cell we are working
329 on. In effect, it must have done our job or messed it up
332 var
= SCM_CAR (vloc
);
333 if (SCM_VARIABLEP (var
))
334 return SCM_VARIABLE_LOC (var
);
335 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
336 return scm_ilookup (var
, genv
);
337 /* We can't cope with anything else than variables and ilocs. When
338 a special form has been memoized (i.e. `let' into `#@let') we
339 return NULL and expect the calling function to do the right
340 thing. For the evaluator, this means going back and redoing
341 the dispatch on the car of the form. */
345 SCM_SETCAR (vloc
, real_var
);
346 return SCM_VARIABLE_LOC (real_var
);
351 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
353 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
359 #define unmemocar scm_unmemocar
361 SCM_SYMBOL (sym_three_question_marks
, "???");
364 scm_unmemocar (SCM form
, SCM env
)
366 if (!SCM_CONSP (form
))
370 SCM c
= SCM_CAR (form
);
371 if (SCM_VARIABLEP (c
))
373 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
374 if (SCM_FALSEP (sym
))
375 sym
= sym_three_question_marks
;
376 SCM_SETCAR (form
, sym
);
378 else if (SCM_ILOCP (c
))
380 unsigned long int ir
;
382 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
384 env
= SCM_CAAR (env
);
385 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
387 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
395 scm_eval_car (SCM pair
, SCM env
)
397 return SCM_XEVALCAR (pair
, env
);
402 * The following rewrite expressions and
403 * some memoized forms have different syntax
406 const char scm_s_expression
[] = "missing or extra expression";
407 const char scm_s_test
[] = "bad test";
408 const char scm_s_body
[] = "bad body";
409 const char scm_s_bindings
[] = "bad bindings";
410 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
411 const char scm_s_variable
[] = "bad variable";
412 const char scm_s_clauses
[] = "bad or missing clauses";
413 const char scm_s_formals
[] = "bad formals";
414 const char scm_s_duplicate_formals
[] = "duplicate formals";
415 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
417 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
418 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
419 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
420 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
421 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
425 #ifdef DEBUG_EXTENSIONS
426 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
427 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
428 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
429 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
433 /* Check that the body denoted by XORIG is valid and rewrite it into
434 its internal form. The internal form of a body is just the body
435 itself, but prefixed with an ISYM that denotes to what kind of
436 outer construct this body belongs. A lambda body starts with
437 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
438 etc. The one exception is a body that belongs to a letrec that has
439 been formed by rewriting internal defines: it starts with
442 /* XXX - Besides controlling the rewriting of internal defines, the
443 additional ISYM could be used for improved error messages.
444 This is not done yet. */
447 scm_m_body (SCM op
, SCM xorig
, const char *what
)
449 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
451 /* Don't add another ISYM if one is present already. */
452 if (SCM_ISYMP (SCM_CAR (xorig
)))
455 /* Retain possible doc string. */
456 if (!SCM_CONSP (SCM_CAR (xorig
)))
458 if (!SCM_NULLP (SCM_CDR (xorig
)))
459 return scm_cons (SCM_CAR (xorig
),
460 scm_m_body (op
, SCM_CDR (xorig
), what
));
464 return scm_cons (op
, xorig
);
468 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
469 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
472 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
474 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
475 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
479 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
480 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
483 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
485 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
486 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
490 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
491 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
494 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
496 long len
= scm_ilength (SCM_CDR (xorig
));
497 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
498 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
502 /* Will go into the RnRS module when Guile is factorized.
503 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
504 const char scm_s_set_x
[] = "set!";
505 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
508 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
510 SCM x
= SCM_CDR (xorig
);
511 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
512 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
513 return scm_cons (SCM_IM_SET_X
, x
);
517 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
518 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
521 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
523 long len
= scm_ilength (SCM_CDR (xorig
));
524 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
526 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
532 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
533 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
536 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
538 long len
= scm_ilength (SCM_CDR (xorig
));
539 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
541 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
547 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
548 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
551 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
554 SCM cdrx
= SCM_CDR (xorig
);
555 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
556 clauses
= SCM_CDR (cdrx
);
557 while (!SCM_NULLP (clauses
))
559 SCM clause
= SCM_CAR (clauses
);
560 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
561 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
562 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
563 && SCM_NULLP (SCM_CDR (clauses
))),
564 scm_s_clauses
, s_case
);
565 clauses
= SCM_CDR (clauses
);
567 return scm_cons (SCM_IM_CASE
, cdrx
);
571 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
572 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
575 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
577 SCM cdrx
= SCM_CDR (xorig
);
579 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
580 while (!SCM_NULLP (clauses
))
582 SCM clause
= SCM_CAR (clauses
);
583 long len
= scm_ilength (clause
);
584 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
585 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
587 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
588 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
590 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
592 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
593 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
595 clauses
= SCM_CDR (clauses
);
597 return scm_cons (SCM_IM_COND
, cdrx
);
601 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
602 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
604 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
605 * cdr of the last cons. (Thus, LIST is not required to be a proper
606 * list and OBJ can also be found in the improper ending.) */
608 scm_c_improper_memq (SCM obj
, SCM list
)
610 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
612 if (SCM_EQ_P (SCM_CAR (list
), obj
))
615 return SCM_EQ_P (list
, obj
);
619 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
622 SCM x
= SCM_CDR (xorig
);
624 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
626 formals
= SCM_CAR (x
);
627 while (SCM_CONSP (formals
))
629 SCM formal
= SCM_CAR (formals
);
630 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
631 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
632 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
633 formals
= SCM_CDR (formals
);
635 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
636 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
638 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
639 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
643 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
644 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
646 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
647 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
649 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
652 SCM x
= SCM_CDR (xorig
);
656 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
658 bindings
= SCM_CAR (x
);
659 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
660 while (!SCM_NULLP (bindings
))
662 SCM binding
= SCM_CAR (bindings
);
663 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
664 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
665 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
666 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
667 bindings
= SCM_CDR (bindings
);
670 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
671 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
675 /* DO gets the most radically altered syntax. The order of the vars is
676 * reversed here. In contrast, the order of the inits and steps is reversed
677 * during the evaluation:
679 (do ((<var1> <init1> <step1>)
687 (#@do (varn ... var2 var1)
688 (<init1> <init2> ... <initn>)
691 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
694 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
695 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
698 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
701 SCM x
= SCM_CDR (xorig
);
704 SCM
*initloc
= &inits
;
706 SCM
*steploc
= &steps
;
707 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
708 bindings
= SCM_CAR (x
);
709 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
710 while (!SCM_NULLP (bindings
))
712 SCM binding
= SCM_CAR (bindings
);
713 long len
= scm_ilength (binding
);
714 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
716 SCM name
= SCM_CAR (binding
);
717 SCM init
= SCM_CADR (binding
);
718 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
719 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
720 vars
= scm_cons (name
, vars
);
721 *initloc
= scm_list_1 (init
);
722 initloc
= SCM_CDRLOC (*initloc
);
723 *steploc
= scm_list_1 (step
);
724 steploc
= SCM_CDRLOC (*steploc
);
725 bindings
= SCM_CDR (bindings
);
729 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
730 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
731 x
= scm_cons2 (vars
, inits
, x
);
732 return scm_cons (SCM_IM_DO
, x
);
736 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
737 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
739 /* Internal function to handle a quasiquotation: 'form' is the parameter in
740 * the call (quasiquotation form), 'env' is the environment where unquoted
741 * expressions will be evaluated, and 'depth' is the current quasiquotation
742 * nesting level and is known to be greater than zero. */
744 iqq (SCM form
, SCM env
, unsigned long int depth
)
746 if (SCM_CONSP (form
))
748 SCM tmp
= SCM_CAR (form
);
749 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
751 SCM args
= SCM_CDR (form
);
752 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
753 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
755 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
757 SCM args
= SCM_CDR (form
);
758 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
760 return scm_eval_car (args
, env
);
762 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
764 else if (SCM_CONSP (tmp
)
765 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
767 SCM args
= SCM_CDR (tmp
);
768 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
771 SCM list
= scm_eval_car (args
, env
);
772 SCM rest
= SCM_CDR (form
);
773 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
774 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
777 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
778 iqq (SCM_CDR (form
), env
, depth
));
781 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
782 iqq (SCM_CDR (form
), env
, depth
));
784 else if (SCM_VECTORP (form
))
786 size_t i
= SCM_VECTOR_LENGTH (form
);
787 SCM
const *data
= SCM_VELTS (form
);
790 tmp
= scm_cons (data
[--i
], tmp
);
791 scm_remember_upto_here_1 (form
);
792 return scm_vector (iqq (tmp
, env
, depth
));
799 scm_m_quasiquote (SCM xorig
, SCM env
)
801 SCM x
= SCM_CDR (xorig
);
802 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
803 return iqq (SCM_CAR (x
), env
, 1);
807 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
808 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
810 /* Promises are implemented as closures with an empty parameter list. Thus,
811 * (delay <expression>) is transformed into (#@delay '() <expression>), where
812 * the empty list represents the empty parameter list. This representation
813 * allows for easy creation of the closure during evaluation. */
815 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
817 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
818 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
822 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
823 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
825 /* Like promises, futures are implemented as closures with an empty
826 * parameter list. Thus, (future <expression>) is transformed into
827 * (#@future '() <expression>), where the empty list represents the
828 * empty parameter list. This representation allows for easy creation
829 * of the closure during evaluation. */
831 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
833 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
834 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
838 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
839 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
841 /* Guile provides an extension to R5RS' define syntax to represent function
842 * currying in a compact way. With this extension, it is allowed to write
843 * (define <nested-variable> <body>), where <nested-variable> has of one of
844 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
845 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
846 * should be either a sequence of zero or more variables, or a sequence of one
847 * or more variables followed by a space-delimited period and another
848 * variable. Each level of argument nesting wraps the <body> within another
849 * lambda expression. For example, the following forms are allowed, each one
850 * followed by an equivalent, more explicit implementation.
852 * (define ((a b . c) . d) <body>) is equivalent to
853 * (define a (lambda (b . c) (lambda d <body>)))
855 * (define (((a) b) c . d) <body>) is equivalent to
856 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
858 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
859 * module that does not implement this extension. */
861 scm_m_define (SCM x
, SCM env
)
865 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
868 while (SCM_CONSP (name
))
870 /* This while loop realizes function currying by variable nesting. */
871 SCM formals
= SCM_CDR (name
);
872 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
873 name
= SCM_CAR (name
);
875 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
876 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
877 if (SCM_TOP_LEVEL (env
))
880 x
= scm_eval_car (x
, env
);
881 if (SCM_REC_PROCNAMES_P
)
884 while (SCM_MACROP (tmp
))
885 tmp
= SCM_MACRO_CODE (tmp
);
886 if (SCM_CLOSUREP (tmp
)
887 /* Only the first definition determines the name. */
888 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
889 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
891 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
892 SCM_VARIABLE_SET (var
, x
);
893 return SCM_UNSPECIFIED
;
896 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
900 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
901 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
902 * reversed here, the list of inits gets reversed during evaluation. */
904 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
910 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
914 SCM binding
= SCM_CAR (bindings
);
915 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
916 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
917 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
918 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
919 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
920 *initloc
= scm_list_1 (SCM_CADR (binding
));
921 initloc
= SCM_CDRLOC (*initloc
);
922 bindings
= SCM_CDR (bindings
);
924 while (!SCM_NULLP (bindings
));
930 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
931 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
934 scm_m_letrec (SCM xorig
, SCM env
)
936 SCM x
= SCM_CDR (xorig
);
937 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
939 if (SCM_NULLP (SCM_CAR (x
)))
941 /* null binding, let* faster */
942 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
943 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
947 SCM rvars
, inits
, body
;
948 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
949 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
950 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
955 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
956 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
959 scm_m_let (SCM xorig
, SCM env
)
961 SCM x
= SCM_CDR (xorig
);
964 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
967 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
969 /* null or single binding, let* is faster */
971 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
972 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
974 else if (SCM_CONSP (temp
))
978 SCM rvars
, inits
, body
;
979 transform_bindings (bindings
, &rvars
, &inits
, "let");
980 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
981 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
985 /* named let: Transform (let name ((var init) ...) body ...) into
986 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
992 SCM
*initloc
= &inits
;
995 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
997 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
998 bindings
= SCM_CAR (x
);
999 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1000 while (!SCM_NULLP (bindings
))
1001 { /* vars and inits both in order */
1002 SCM binding
= SCM_CAR (bindings
);
1003 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1004 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1005 *varloc
= scm_list_1 (SCM_CAR (binding
));
1006 varloc
= SCM_CDRLOC (*varloc
);
1007 *initloc
= scm_list_1 (SCM_CADR (binding
));
1008 initloc
= SCM_CDRLOC (*initloc
);
1009 bindings
= SCM_CDR (bindings
);
1013 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1014 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1015 SCM rvar
= scm_list_1 (name
);
1016 SCM init
= scm_list_1 (lambda_form
);
1017 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1018 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1019 return scm_cons (letrec
, inits
);
1025 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1026 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1027 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1030 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1032 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1033 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1037 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1038 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1042 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1044 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1045 scm_s_expression
, s_atcall_cc
);
1046 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1049 #ifdef SCM_ENABLE_ELISP
1051 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1054 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1056 long len
= scm_ilength (SCM_CDR (xorig
));
1057 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1058 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1061 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1064 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1066 SCM x
= SCM_CDR (xorig
), var
;
1067 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1068 var
= scm_symbol_fref (SCM_CAR (x
));
1069 /* Passing the symbol name as the `subr' arg here isn't really
1070 right, but without it it can be very difficult to work out from
1071 the error message which function definition was missing. In any
1072 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1073 something equivalent to (signal void-function (list SYM)) in
1075 SCM_ASSYNT (SCM_VARIABLEP (var
),
1076 "Symbol's function definition is void",
1077 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1078 /* Support `defalias'. */
1079 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1081 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1082 SCM_ASSYNT (SCM_VARIABLEP (var
),
1083 "Symbol's function definition is void",
1084 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1086 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1087 former allows for automatically picking up redefinitions of the
1088 corresponding symbol. */
1089 SCM_SETCAR (x
, var
);
1090 /* If the variable contains a procedure, leave the
1091 `transformer-macro' in place so that the procedure's arguments
1092 get properly transformed, and change the initial @fop to
1094 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1096 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1099 /* Otherwise (the variable contains a macro), the arguments should
1100 not be transformed, so cut the `transformer-macro' out and return
1101 the resulting expression starting with the variable. */
1102 SCM_SETCDR (x
, SCM_CDADR (x
));
1106 #endif /* SCM_ENABLE_ELISP */
1108 /* (@bind ((var exp) ...) body ...)
1110 This will assign the values of the `exp's to the global variables
1111 named by `var's (symbols, not evaluated), creating them if they
1112 don't exist, executes body, and then restores the previous values of
1113 the `var's. Additionally, whenever control leaves body, the values
1114 of the `var's are saved and restored when control returns. It is an
1115 error when a symbol appears more than once among the `var's.
1116 All `exp's are evaluated before any `var' is set.
1118 Think of this as `let' for dynamic scope.
1120 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1122 XXX - also implement `@bind*'.
1125 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1128 scm_m_atbind (SCM xorig
, SCM env
)
1130 SCM x
= SCM_CDR (xorig
);
1131 SCM top_level
= scm_env_top_level (env
);
1132 SCM vars
= SCM_EOL
, var
;
1135 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1138 while (SCM_NIMP (x
))
1141 SCM sym_exp
= SCM_CAR (x
);
1142 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1143 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1145 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1146 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1147 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1148 /* The first call to scm_sym2var will look beyond the current
1149 module, while the second call wont. */
1150 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1151 if (SCM_FALSEP (var
))
1152 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1153 vars
= scm_cons (var
, vars
);
1154 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1156 return scm_cons (SCM_IM_BIND
,
1157 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1161 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1162 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1165 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1167 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1168 scm_s_expression
, s_at_call_with_values
);
1169 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1173 scm_m_expand_body (SCM xorig
, SCM env
)
1175 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1176 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1178 while (SCM_NIMP (x
))
1180 SCM form
= SCM_CAR (x
);
1181 if (!SCM_CONSP (form
))
1183 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1186 form
= scm_macroexp (scm_cons_source (form
,
1191 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1193 defs
= scm_cons (SCM_CDR (form
), defs
);
1196 else if (!SCM_IMP (defs
))
1200 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1202 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1206 x
= scm_cons (form
, SCM_CDR (x
));
1211 if (!SCM_NULLP (defs
))
1213 SCM rvars
, inits
, body
, letrec
;
1214 transform_bindings (defs
, &rvars
, &inits
, what
);
1215 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1216 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1217 SCM_SETCAR (xorig
, letrec
);
1218 SCM_SETCDR (xorig
, SCM_EOL
);
1222 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1223 SCM_SETCAR (xorig
, SCM_CAR (x
));
1224 SCM_SETCDR (xorig
, SCM_CDR (x
));
1231 scm_macroexp (SCM x
, SCM env
)
1233 SCM res
, proc
, orig_sym
;
1235 /* Don't bother to produce error messages here. We get them when we
1236 eventually execute the code for real. */
1239 orig_sym
= SCM_CAR (x
);
1240 if (!SCM_SYMBOLP (orig_sym
))
1244 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1245 if (proc_ptr
== NULL
)
1247 /* We have lost the race. */
1253 /* Only handle memoizing macros. `Acros' and `macros' are really
1254 special forms and should not be evaluated here. */
1256 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1259 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1260 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1262 if (scm_ilength (res
) <= 0)
1263 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1266 SCM_SETCAR (x
, SCM_CAR (res
));
1267 SCM_SETCDR (x
, SCM_CDR (res
));
1273 /* scm_unmemocopy takes a memoized expression together with its
1274 * environment and rewrites it to its original form. Thus, it is the
1275 * inversion of the rewrite rules above. The procedure is not
1276 * optimized for speed. It's used in scm_iprin1 when printing the
1277 * code of a closure, in scm_procedure_source, in display_frame when
1278 * generating the source for a stackframe in a backtrace, and in
1279 * display_expression.
1281 * Unmemoizing is not a reliable process. You cannot in general
1282 * expect to get the original source back.
1284 * However, GOOPS currently relies on this for method compilation.
1285 * This ought to change.
1288 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1291 build_binding_list (SCM names
, SCM inits
)
1293 SCM bindings
= SCM_EOL
;
1294 while (!SCM_NULLP (names
))
1296 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1297 bindings
= scm_cons (binding
, bindings
);
1298 names
= SCM_CDR (names
);
1299 inits
= SCM_CDR (inits
);
1305 unmemocopy (SCM x
, SCM env
)
1308 #ifdef DEBUG_EXTENSIONS
1313 #ifdef DEBUG_EXTENSIONS
1314 p
= scm_whash_lookup (scm_source_whash
, x
);
1316 switch (SCM_ITAG7 (SCM_CAR (x
)))
1318 case SCM_BIT8(SCM_IM_AND
):
1319 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1321 case SCM_BIT8(SCM_IM_BEGIN
):
1322 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1324 case SCM_BIT8(SCM_IM_CASE
):
1325 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1327 case SCM_BIT8(SCM_IM_COND
):
1328 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1330 case SCM_BIT8 (SCM_IM_DO
):
1332 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1333 * where nx is the name of a local variable, ix is an initializer for
1334 * the local variable, test is the test clause of the do loop, body is
1335 * the body of the do loop and sx are the step clauses for the local
1337 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1340 names
= SCM_CAR (x
);
1342 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1343 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1345 test
= unmemocopy (SCM_CAR (x
), env
);
1347 memoized_body
= SCM_CAR (x
);
1349 steps
= scm_reverse (unmemocopy (x
, env
));
1351 /* build transformed binding list */
1353 while (!SCM_NULLP (names
))
1355 SCM name
= SCM_CAR (names
);
1356 SCM init
= SCM_CAR (inits
);
1357 SCM step
= SCM_CAR (steps
);
1358 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1360 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1362 names
= SCM_CDR (names
);
1363 inits
= SCM_CDR (inits
);
1364 steps
= SCM_CDR (steps
);
1366 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1367 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1369 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1372 case SCM_BIT8(SCM_IM_IF
):
1373 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1375 case SCM_BIT8 (SCM_IM_LET
):
1377 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1378 * where nx is the name of a local variable, ix is an initializer for
1379 * the local variable and by are the body clauses. */
1380 SCM names
, inits
, bindings
;
1383 names
= SCM_CAR (x
);
1385 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1386 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1388 bindings
= build_binding_list (names
, inits
);
1389 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1390 ls
= scm_cons (scm_sym_let
, z
);
1393 case SCM_BIT8 (SCM_IM_LETREC
):
1395 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1396 * where nx is the name of a local variable, ix is an initializer for
1397 * the local variable and by are the body clauses. */
1398 SCM names
, inits
, bindings
;
1401 names
= SCM_CAR (x
);
1402 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1404 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1406 bindings
= build_binding_list (names
, inits
);
1407 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1408 ls
= scm_cons (scm_sym_letrec
, z
);
1411 case SCM_BIT8(SCM_IM_LETSTAR
):
1419 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1422 y
= z
= scm_acons (SCM_CAR (b
),
1424 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1426 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1430 SCM_SETCDR (y
, SCM_EOL
);
1431 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1436 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1438 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1441 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1444 while (SCM_NIMP (b
));
1445 SCM_SETCDR (z
, SCM_EOL
);
1447 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1450 case SCM_BIT8(SCM_IM_OR
):
1451 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1453 case SCM_BIT8(SCM_IM_LAMBDA
):
1455 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1456 ls
= scm_cons (scm_sym_lambda
, z
);
1457 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1459 case SCM_BIT8(SCM_IM_QUOTE
):
1460 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1462 case SCM_BIT8(SCM_IM_SET_X
):
1463 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1465 case SCM_BIT8(SCM_IM_DEFINE
):
1470 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1471 ls
= scm_cons (scm_sym_define
, z
);
1472 if (!SCM_NULLP (env
))
1473 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1478 case SCM_BIT8(SCM_MAKISYM (0)):
1482 switch (SCM_ISYMNUM (z
))
1484 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1485 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1487 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1488 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1490 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1491 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1494 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1495 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1498 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1499 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1502 /* appease the Sun compiler god: */ ;
1506 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1512 while (SCM_CONSP (x
))
1514 SCM form
= SCM_CAR (x
);
1515 if (!SCM_ISYMP (form
))
1517 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1518 SCM_SETCDR (z
, unmemocar (copy
, env
));
1524 #ifdef DEBUG_EXTENSIONS
1525 if (!SCM_FALSEP (p
))
1526 scm_whash_insert (scm_source_whash
, ls
, p
);
1533 scm_unmemocopy (SCM x
, SCM env
)
1535 if (!SCM_NULLP (env
))
1536 /* Make a copy of the lowest frame to protect it from
1537 modifications by SCM_IM_DEFINE */
1538 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1540 return unmemocopy (x
, env
);
1545 scm_badargsp (SCM formals
, SCM args
)
1547 while (!SCM_NULLP (formals
))
1549 if (!SCM_CONSP (formals
))
1551 if (SCM_NULLP (args
))
1553 formals
= SCM_CDR (formals
);
1554 args
= SCM_CDR (args
);
1556 return !SCM_NULLP (args
) ? 1 : 0;
1561 scm_badformalsp (SCM closure
, int n
)
1563 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1564 while (!SCM_NULLP (formals
))
1566 if (!SCM_CONSP (formals
))
1571 formals
= SCM_CDR (formals
);
1578 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1580 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1581 while (SCM_CONSP (l
))
1583 res
= EVALCAR (l
, env
);
1585 *lloc
= scm_list_1 (res
);
1586 lloc
= SCM_CDRLOC (*lloc
);
1590 scm_wrong_num_args (proc
);
1595 scm_eval_body (SCM code
, SCM env
)
1599 next
= SCM_CDR (code
);
1600 while (!SCM_NULLP (next
))
1602 if (SCM_IMP (SCM_CAR (code
)))
1604 if (SCM_ISYMP (SCM_CAR (code
)))
1606 scm_rec_mutex_lock (&source_mutex
);
1607 /* check for race condition */
1608 if (SCM_ISYMP (SCM_CAR (code
)))
1609 code
= scm_m_expand_body (code
, env
);
1610 scm_rec_mutex_unlock (&source_mutex
);
1615 SCM_XEVAL (SCM_CAR (code
), env
);
1617 next
= SCM_CDR (code
);
1619 return SCM_XEVALCAR (code
, env
);
1626 /* SECTION: This code is specific for the debugging support. One
1627 * branch is read when DEVAL isn't defined, the other when DEVAL is
1633 #define SCM_APPLY scm_apply
1634 #define PREP_APPLY(proc, args)
1636 #define RETURN(x) do { return x; } while (0)
1637 #ifdef STACK_CHECKING
1638 #ifndef NO_CEVAL_STACK_CHECKING
1639 #define EVAL_STACK_CHECKING
1646 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1648 #define SCM_APPLY scm_dapply
1650 #define PREP_APPLY(p, l) \
1651 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1653 #define ENTER_APPLY \
1655 SCM_SET_ARGSREADY (debug);\
1656 if (scm_check_apply_p && SCM_TRAPS_P)\
1657 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1659 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1660 SCM_SET_TRACED_FRAME (debug); \
1662 if (SCM_CHEAPTRAPS_P)\
1664 tmp = scm_make_debugobj (&debug);\
1665 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1670 tmp = scm_make_continuation (&first);\
1672 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1678 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1679 #ifdef STACK_CHECKING
1680 #ifndef EVAL_STACK_CHECKING
1681 #define EVAL_STACK_CHECKING
1685 /* scm_ceval_ptr points to the currently selected evaluator.
1686 * *fixme*: Although efficiency is important here, this state variable
1687 * should probably not be a global. It should be related to the
1692 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1694 /* scm_last_debug_frame contains a pointer to the last debugging
1695 * information stack frame. It is accessed very often from the
1696 * debugging evaluator, so it should probably not be indirectly
1697 * addressed. Better to save and restore it from the current root at
1701 /* scm_debug_eframe_size is the number of slots available for pseudo
1702 * stack frames at each real stack frame.
1705 long scm_debug_eframe_size
;
1707 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1709 long scm_eval_stack
;
1711 scm_t_option scm_eval_opts
[] = {
1712 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1715 scm_t_option scm_debug_opts
[] = {
1716 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1717 "*Flyweight representation of the stack at traps." },
1718 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1719 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1720 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1721 "Record procedure names at definition." },
1722 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1723 "Display backtrace in anti-chronological order." },
1724 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1725 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1726 { SCM_OPTION_INTEGER
, "frames", 3,
1727 "Maximum number of tail-recursive frames in backtrace." },
1728 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1729 "Maximal number of stored backtrace frames." },
1730 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1731 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1732 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1733 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1734 { 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."}
1737 scm_t_option scm_evaluator_trap_table
[] = {
1738 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1739 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1740 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1741 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1742 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1743 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1744 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1747 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1749 "Option interface for the evaluation options. Instead of using\n"
1750 "this procedure directly, use the procedures @code{eval-enable},\n"
1751 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1752 #define FUNC_NAME s_scm_eval_options_interface
1756 ans
= scm_options (setting
,
1760 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1766 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1768 "Option interface for the evaluator trap options.")
1769 #define FUNC_NAME s_scm_evaluator_traps
1773 ans
= scm_options (setting
,
1774 scm_evaluator_trap_table
,
1775 SCM_N_EVALUATOR_TRAPS
,
1777 SCM_RESET_DEBUG_MODE
;
1784 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1786 SCM
*results
= lloc
, res
;
1787 while (SCM_CONSP (l
))
1789 res
= EVALCAR (l
, env
);
1791 *lloc
= scm_list_1 (res
);
1792 lloc
= SCM_CDRLOC (*lloc
);
1796 scm_wrong_num_args (proc
);
1803 /* SECTION: This code is compiled twice.
1807 /* Update the toplevel environment frame ENV so that it refers to the
1808 * current module. */
1809 #define UPDATE_TOPLEVEL_ENV(env) \
1811 SCM p = scm_current_module_lookup_closure (); \
1812 if (p != SCM_CAR(env)) \
1813 env = scm_top_level_env (p); \
1817 /* This is the evaluator. Like any real monster, it has three heads:
1819 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1820 * version. Both are implemented using a common code base, using the
1821 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1822 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1823 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1824 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1825 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1826 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1827 * are enclosed within #ifdef DEVAL ... #endif.
1829 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1830 * take two input parameters, x and env: x is a single expression to be
1831 * evalutated. env is the environment in which bindings are searched.
1833 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1834 * is a single expression, it is necessarily in a tail position. If x is just
1835 * a call to another function like in the expression (foo exp1 exp2 ...), the
1836 * realization of that call therefore _must_not_ increase stack usage (the
1837 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1838 * making extensive use of 'goto' statements within the evaluator: The gotos
1839 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1840 * that SCM_CEVAL was already using. If, however, x represents some form that
1841 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1842 * then recursive calls to SCM_CEVAL are performed for all but the last
1843 * expression of that sequence. */
1847 scm_ceval (SCM x
, SCM env
)
1853 scm_deval (SCM x
, SCM env
)
1858 SCM_CEVAL (SCM x
, SCM env
)
1862 scm_t_debug_frame debug
;
1863 scm_t_debug_info
*debug_info_end
;
1864 debug
.prev
= scm_last_debug_frame
;
1867 * The debug.vect contains twice as much scm_t_debug_info frames as the
1868 * user has specified with (debug-set! frames <n>).
1870 * Even frames are eval frames, odd frames are apply frames.
1872 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1873 * sizeof (scm_t_debug_info
));
1874 debug
.info
= debug
.vect
;
1875 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1876 scm_last_debug_frame
= &debug
;
1878 #ifdef EVAL_STACK_CHECKING
1879 if (scm_stack_checking_enabled_p
1880 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1883 debug
.info
->e
.exp
= x
;
1884 debug
.info
->e
.env
= env
;
1886 scm_report_stack_overflow ();
1896 SCM_CLEAR_ARGSREADY (debug
);
1897 if (SCM_OVERFLOWP (debug
))
1900 * In theory, this should be the only place where it is necessary to
1901 * check for space in debug.vect since both eval frames and
1902 * available space are even.
1904 * For this to be the case, however, it is necessary that primitive
1905 * special forms which jump back to `loop', `begin' or some similar
1906 * label call PREP_APPLY.
1908 else if (++debug
.info
>= debug_info_end
)
1910 SCM_SET_OVERFLOW (debug
);
1915 debug
.info
->e
.exp
= x
;
1916 debug
.info
->e
.env
= env
;
1917 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1919 if (SCM_ENTER_FRAME_P
1920 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1923 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1924 SCM_SET_TAILREC (debug
);
1925 if (SCM_CHEAPTRAPS_P
)
1926 stackrep
= scm_make_debugobj (&debug
);
1930 SCM val
= scm_make_continuation (&first
);
1940 /* This gives the possibility for the debugger to
1941 modify the source expression before evaluation. */
1946 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1947 scm_sym_enter_frame
,
1950 scm_unmemocopy (x
, env
));
1957 switch (SCM_TYP7 (x
))
1959 case scm_tc7_symbol
:
1960 /* Only happens when called at top level. */
1961 x
= scm_cons (x
, SCM_UNDEFINED
);
1962 RETURN (*scm_lookupcar (x
, env
, 1));
1964 case SCM_BIT8 (SCM_IM_AND
):
1966 while (!SCM_NULLP (SCM_CDR (x
)))
1968 SCM test_result
= EVALCAR (x
, env
);
1969 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1970 RETURN (SCM_BOOL_F
);
1974 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1977 case SCM_BIT8 (SCM_IM_BEGIN
):
1980 RETURN (SCM_UNSPECIFIED
);
1982 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1985 /* If we are on toplevel with a lookup closure, we need to sync
1986 with the current module. */
1987 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1989 UPDATE_TOPLEVEL_ENV (env
);
1990 while (!SCM_NULLP (SCM_CDR (x
)))
1993 UPDATE_TOPLEVEL_ENV (env
);
1999 goto nontoplevel_begin
;
2002 while (!SCM_NULLP (SCM_CDR (x
)))
2004 SCM form
= SCM_CAR (x
);
2007 if (SCM_ISYMP (form
))
2009 scm_rec_mutex_lock (&source_mutex
);
2010 /* check for race condition */
2011 if (SCM_ISYMP (SCM_CAR (x
)))
2012 x
= scm_m_expand_body (x
, env
);
2013 scm_rec_mutex_unlock (&source_mutex
);
2014 goto nontoplevel_begin
;
2017 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2020 SCM_CEVAL (form
, env
);
2026 /* scm_eval last form in list */
2027 SCM last_form
= SCM_CAR (x
);
2029 if (SCM_CONSP (last_form
))
2031 /* This is by far the most frequent case. */
2033 goto loop
; /* tail recurse */
2035 else if (SCM_IMP (last_form
))
2036 RETURN (SCM_EVALIM (last_form
, env
));
2037 else if (SCM_VARIABLEP (last_form
))
2038 RETURN (SCM_VARIABLE_REF (last_form
));
2039 else if (SCM_SYMBOLP (last_form
))
2040 RETURN (*scm_lookupcar (x
, env
, 1));
2046 case SCM_BIT8 (SCM_IM_CASE
):
2049 SCM key
= EVALCAR (x
, env
);
2051 while (!SCM_NULLP (x
))
2053 SCM clause
= SCM_CAR (x
);
2054 SCM labels
= SCM_CAR (clause
);
2055 if (SCM_EQ_P (labels
, scm_sym_else
))
2057 x
= SCM_CDR (clause
);
2058 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2061 while (!SCM_NULLP (labels
))
2063 SCM label
= SCM_CAR (labels
);
2064 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2066 x
= SCM_CDR (clause
);
2067 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2070 labels
= SCM_CDR (labels
);
2075 RETURN (SCM_UNSPECIFIED
);
2078 case SCM_BIT8 (SCM_IM_COND
):
2080 while (!SCM_NULLP (x
))
2082 SCM clause
= SCM_CAR (x
);
2083 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2085 x
= SCM_CDR (clause
);
2086 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2091 arg1
= EVALCAR (clause
, env
);
2092 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2094 x
= SCM_CDR (clause
);
2097 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2099 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2105 proc
= EVALCAR (proc
, env
);
2106 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2107 PREP_APPLY (proc
, scm_list_1 (arg1
));
2109 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2110 goto umwrongnumargs
;
2118 RETURN (SCM_UNSPECIFIED
);
2121 case SCM_BIT8 (SCM_IM_DO
):
2124 /* Compute the initialization values and the initial environment. */
2125 SCM init_forms
= SCM_CADR (x
);
2126 SCM init_values
= SCM_EOL
;
2127 while (!SCM_NULLP (init_forms
))
2129 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2130 init_forms
= SCM_CDR (init_forms
);
2132 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2136 SCM test_form
= SCM_CAR (x
);
2137 SCM body_forms
= SCM_CADR (x
);
2138 SCM step_forms
= SCM_CDDR (x
);
2140 SCM test_result
= EVALCAR (test_form
, env
);
2142 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2145 /* Evaluate body forms. */
2147 for (temp_forms
= body_forms
;
2148 !SCM_NULLP (temp_forms
);
2149 temp_forms
= SCM_CDR (temp_forms
))
2151 SCM form
= SCM_CAR (temp_forms
);
2152 /* Dirk:FIXME: We only need to eval forms, that may have a
2153 * side effect here. This is only true for forms that start
2154 * with a pair. All others are just constants. However,
2155 * since in the common case there is no constant expression
2156 * in a body of a do form, we just check for immediates here
2157 * and have SCM_CEVAL take care of other cases. In the long
2158 * run it would make sense to get rid of this test and have
2159 * the macro transformer of 'do' eliminate all forms that
2160 * have no sideeffect. */
2161 if (!SCM_IMP (form
))
2162 SCM_CEVAL (form
, env
);
2167 /* Evaluate the step expressions. */
2169 SCM step_values
= SCM_EOL
;
2170 for (temp_forms
= step_forms
;
2171 !SCM_NULLP (temp_forms
);
2172 temp_forms
= SCM_CDR (temp_forms
))
2174 SCM value
= EVALCAR (temp_forms
, env
);
2175 step_values
= scm_cons (value
, step_values
);
2177 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2180 test_result
= EVALCAR (test_form
, env
);
2185 RETURN (SCM_UNSPECIFIED
);
2186 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2187 goto nontoplevel_begin
;
2190 case SCM_BIT8 (SCM_IM_IF
):
2193 SCM test_result
= EVALCAR (x
, env
);
2194 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2200 RETURN (SCM_UNSPECIFIED
);
2203 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2207 case SCM_BIT8 (SCM_IM_LET
):
2210 SCM init_forms
= SCM_CADR (x
);
2211 SCM init_values
= SCM_EOL
;
2214 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2215 init_forms
= SCM_CDR (init_forms
);
2217 while (!SCM_NULLP (init_forms
));
2218 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2221 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2222 goto nontoplevel_begin
;
2225 case SCM_BIT8 (SCM_IM_LETREC
):
2227 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2230 SCM init_forms
= SCM_CAR (x
);
2231 SCM init_values
= SCM_EOL
;
2234 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2235 init_forms
= SCM_CDR (init_forms
);
2237 while (!SCM_NULLP (init_forms
));
2238 SCM_SETCDR (SCM_CAR (env
), init_values
);
2241 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2242 goto nontoplevel_begin
;
2245 case SCM_BIT8 (SCM_IM_LETSTAR
):
2248 SCM bindings
= SCM_CAR (x
);
2249 if (SCM_NULLP (bindings
))
2250 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2255 SCM name
= SCM_CAR (bindings
);
2256 SCM init
= SCM_CDR (bindings
);
2257 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2258 bindings
= SCM_CDR (init
);
2260 while (!SCM_NULLP (bindings
));
2264 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2265 goto nontoplevel_begin
;
2268 case SCM_BIT8 (SCM_IM_OR
):
2270 while (!SCM_NULLP (SCM_CDR (x
)))
2272 SCM val
= EVALCAR (x
, env
);
2273 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2278 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2282 case SCM_BIT8 (SCM_IM_LAMBDA
):
2283 RETURN (scm_closure (SCM_CDR (x
), env
));
2286 case SCM_BIT8 (SCM_IM_QUOTE
):
2287 RETURN (SCM_CADR (x
));
2290 case SCM_BIT8 (SCM_IM_SET_X
):
2294 SCM variable
= SCM_CAR (x
);
2295 if (SCM_ILOCP (variable
))
2296 location
= scm_ilookup (variable
, env
);
2297 else if (SCM_VARIABLEP (variable
))
2298 location
= SCM_VARIABLE_LOC (variable
);
2299 else /* (SCM_SYMBOLP (variable)) is known to be true */
2300 location
= scm_lookupcar (x
, env
, 1);
2302 *location
= EVALCAR (x
, env
);
2304 RETURN (SCM_UNSPECIFIED
);
2307 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2308 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2311 /* new syntactic forms go here. */
2312 case SCM_BIT8 (SCM_MAKISYM (0)):
2314 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2315 switch (SCM_ISYMNUM (proc
))
2319 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2321 proc
= EVALCAR (proc
, env
);
2322 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2323 if (SCM_CLOSUREP (proc
))
2325 PREP_APPLY (proc
, SCM_EOL
);
2326 arg1
= SCM_CDDR (x
);
2327 arg1
= EVALCAR (arg1
, env
);
2329 /* Go here to tail-call a closure. PROC is the closure
2330 and ARG1 is the list of arguments. Do not forget to
2333 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2335 debug
.info
->a
.args
= arg1
;
2337 if (scm_badargsp (formals
, arg1
))
2338 scm_wrong_num_args (proc
);
2340 /* Copy argument list */
2341 if (SCM_NULL_OR_NIL_P (arg1
))
2342 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2345 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2347 arg1
= SCM_CDR (arg1
);
2348 while (!SCM_NULL_OR_NIL_P (arg1
))
2350 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2351 SCM_SETCDR (tail
, new_tail
);
2353 arg1
= SCM_CDR (arg1
);
2355 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2358 x
= SCM_CLOSURE_BODY (proc
);
2359 goto nontoplevel_begin
;
2369 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2372 SCM val
= scm_make_continuation (&first
);
2380 proc
= scm_eval_car (proc
, env
);
2381 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2382 PREP_APPLY (proc
, scm_list_1 (arg1
));
2384 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2385 goto umwrongnumargs
;
2391 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2392 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2395 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2396 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2399 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2401 /* If not done yet, evaluate the operand forms. The result is a
2402 * list of arguments stored in arg1, which is used to perform the
2403 * function dispatch. */
2404 SCM operand_forms
= SCM_CADR (x
);
2405 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2406 if (SCM_ILOCP (operand_forms
))
2407 arg1
= *scm_ilookup (operand_forms
, env
);
2408 else if (SCM_VARIABLEP (operand_forms
))
2409 arg1
= SCM_VARIABLE_REF (operand_forms
);
2410 else if (!SCM_CONSP (operand_forms
))
2411 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2414 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2415 operand_forms
= SCM_CDR (operand_forms
);
2416 while (!SCM_NULLP (operand_forms
))
2418 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2419 SCM_SETCDR (tail
, new_tail
);
2421 operand_forms
= SCM_CDR (operand_forms
);
2426 /* The type dispatch code is duplicated below
2427 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2428 * cuts down execution time for type dispatch to 50%. */
2429 type_dispatch
: /* inputs: x, arg1 */
2430 /* Type dispatch means to determine from the types of the function
2431 * arguments (i. e. the 'signature' of the call), which method from
2432 * a generic function is to be called. This process of selecting
2433 * the right method takes some time. To speed it up, guile uses
2434 * caching: Together with the macro call to dispatch the signatures
2435 * of some previous calls to that generic function from the same
2436 * place are stored (in the code!) in a cache that we call the
2437 * 'method cache'. This is done since it is likely, that
2438 * consecutive calls to dispatch from that position in the code will
2439 * have the same signature. Thus, the type dispatch works as
2440 * follows: First, determine a hash value from the signature of the
2441 * actual arguments. Second, use this hash value as an index to
2442 * find that same signature in the method cache stored at this
2443 * position in the code. If found, you have also found the
2444 * corresponding method that belongs to that signature. If the
2445 * signature is not found in the method cache, you have to perform a
2446 * full search over all signatures stored with the generic
2449 unsigned long int specializers
;
2450 unsigned long int hash_value
;
2451 unsigned long int cache_end_pos
;
2452 unsigned long int mask
;
2456 SCM z
= SCM_CDDR (x
);
2457 SCM tmp
= SCM_CADR (z
);
2458 specializers
= SCM_INUM (SCM_CAR (z
));
2460 /* Compute a hash value for searching the method cache. There
2461 * are two variants for computing the hash value, a (rather)
2462 * complicated one, and a simple one. For the complicated one
2463 * explained below, tmp holds a number that is used in the
2465 if (SCM_INUMP (tmp
))
2467 /* Use the signature of the actual arguments to determine
2468 * the hash value. This is done as follows: Each class has
2469 * an array of random numbers, that are determined when the
2470 * class is created. The integer 'hashset' is an index into
2471 * that array of random numbers. Now, from all classes that
2472 * are part of the signature of the actual arguments, the
2473 * random numbers at index 'hashset' are taken and summed
2474 * up, giving the hash value. The value of 'hashset' is
2475 * stored at the call to dispatch. This allows to have
2476 * different 'formulas' for calculating the hash value at
2477 * different places where dispatch is called. This allows
2478 * to optimize the hash formula at every individual place
2479 * where dispatch is called, such that hopefully the hash
2480 * value that is computed will directly point to the right
2481 * method in the method cache. */
2482 unsigned long int hashset
= SCM_INUM (tmp
);
2483 unsigned long int counter
= specializers
+ 1;
2486 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2488 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2489 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2490 tmp_arg
= SCM_CDR (tmp_arg
);
2494 method_cache
= SCM_CADR (z
);
2495 mask
= SCM_INUM (SCM_CAR (z
));
2497 cache_end_pos
= hash_value
;
2501 /* This method of determining the hash value is much
2502 * simpler: Set the hash value to zero and just perform a
2503 * linear search through the method cache. */
2505 mask
= (unsigned long int) ((long) -1);
2507 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2512 /* Search the method cache for a method with a matching
2513 * signature. Start the search at position 'hash_value'. The
2514 * hashing implementation uses linear probing for conflict
2515 * resolution, that is, if the signature in question is not
2516 * found at the starting index in the hash table, the next table
2517 * entry is tried, and so on, until in the worst case the whole
2518 * cache has been searched, but still the signature has not been
2523 SCM args
= arg1
; /* list of arguments */
2524 z
= SCM_VELTS (method_cache
)[hash_value
];
2525 while (!SCM_NULLP (args
))
2527 /* More arguments than specifiers => CLASS != ENV */
2528 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2529 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2531 args
= SCM_CDR (args
);
2534 /* Fewer arguments than specifiers => CAR != ENV */
2535 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2538 hash_value
= (hash_value
+ 1) & mask
;
2539 } while (hash_value
!= cache_end_pos
);
2541 /* No appropriate method was found in the cache. */
2542 z
= scm_memoize_method (x
, arg1
);
2544 apply_cmethod
: /* inputs: z, arg1 */
2546 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2547 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2548 x
= SCM_CMETHOD_BODY (z
);
2549 goto nontoplevel_begin
;
2555 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2558 SCM instance
= EVALCAR (x
, env
);
2559 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2560 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2564 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2567 SCM instance
= EVALCAR (x
, env
);
2568 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2569 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2570 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2571 RETURN (SCM_UNSPECIFIED
);
2575 #ifdef SCM_ENABLE_ELISP
2577 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2579 SCM test_form
= SCM_CDR (x
);
2580 x
= SCM_CDR (test_form
);
2581 while (!SCM_NULL_OR_NIL_P (x
))
2583 SCM test_result
= EVALCAR (test_form
, env
);
2584 if (!(SCM_FALSEP (test_result
)
2585 || SCM_NULL_OR_NIL_P (test_result
)))
2587 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2588 RETURN (test_result
);
2589 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2594 test_form
= SCM_CDR (x
);
2595 x
= SCM_CDR (test_form
);
2599 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2603 #endif /* SCM_ENABLE_ELISP */
2605 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2607 SCM vars
, exps
, vals
;
2610 vars
= SCM_CAAR (x
);
2611 exps
= SCM_CDAR (x
);
2615 while (SCM_NIMP (exps
))
2617 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2618 exps
= SCM_CDR (exps
);
2621 scm_swap_bindings (vars
, vals
);
2622 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2624 /* Ignore all but the last evaluation result. */
2625 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2627 if (SCM_CONSP (SCM_CAR (x
)))
2628 SCM_CEVAL (SCM_CAR (x
), env
);
2630 proc
= EVALCAR (x
, env
);
2632 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2633 scm_swap_bindings (vars
, vals
);
2639 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2642 x
= EVALCAR (proc
, env
);
2643 proc
= SCM_CDR (proc
);
2644 proc
= EVALCAR (proc
, env
);
2645 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2646 if (SCM_VALUESP (arg1
))
2647 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2649 arg1
= scm_list_1 (arg1
);
2650 if (SCM_CLOSUREP (proc
))
2652 PREP_APPLY (proc
, arg1
);
2655 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2666 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2667 case scm_tc7_vector
:
2671 case scm_tc7_byvect
:
2678 #ifdef HAVE_LONG_LONGS
2679 case scm_tc7_llvect
:
2682 case scm_tc7_string
:
2684 case scm_tcs_closures
:
2688 case scm_tcs_struct
:
2691 case scm_tc7_variable
:
2692 RETURN (SCM_VARIABLE_REF(x
));
2694 case SCM_BIT8(SCM_ILOC00
):
2695 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2696 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2699 case scm_tcs_cons_nimcar
:
2700 if (SCM_SYMBOLP (SCM_CAR (x
)))
2702 SCM orig_sym
= SCM_CAR (x
);
2704 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2705 if (location
== NULL
)
2707 /* we have lost the race, start again. */
2715 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2719 if (SCM_MACROP (proc
))
2721 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2723 handle_a_macro
: /* inputs: x, env, proc */
2725 /* Set a flag during macro expansion so that macro
2726 application frames can be deleted from the backtrace. */
2727 SCM_SET_MACROEXP (debug
);
2729 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2730 scm_cons (env
, scm_listofnull
));
2733 SCM_CLEAR_MACROEXP (debug
);
2735 switch (SCM_MACRO_TYPE (proc
))
2738 if (scm_ilength (arg1
) <= 0)
2739 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2741 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2744 SCM_SETCAR (x
, SCM_CAR (arg1
));
2745 SCM_SETCDR (x
, SCM_CDR (arg1
));
2749 /* Prevent memoizing of debug info expression. */
2750 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2755 SCM_SETCAR (x
, SCM_CAR (arg1
));
2756 SCM_SETCDR (x
, SCM_CDR (arg1
));
2758 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2760 #if SCM_ENABLE_DEPRECATED == 1
2765 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2777 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2778 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2781 if (SCM_CLOSUREP (proc
))
2783 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2784 SCM args
= SCM_CDR (x
);
2785 while (!SCM_NULLP (formals
))
2787 if (!SCM_CONSP (formals
))
2790 goto umwrongnumargs
;
2791 formals
= SCM_CDR (formals
);
2792 args
= SCM_CDR (args
);
2794 if (!SCM_NULLP (args
))
2795 goto umwrongnumargs
;
2797 else if (SCM_MACROP (proc
))
2798 goto handle_a_macro
;
2802 evapply
: /* inputs: x, proc */
2803 PREP_APPLY (proc
, SCM_EOL
);
2804 if (SCM_NULLP (SCM_CDR (x
))) {
2807 switch (SCM_TYP7 (proc
))
2808 { /* no arguments given */
2809 case scm_tc7_subr_0
:
2810 RETURN (SCM_SUBRF (proc
) ());
2811 case scm_tc7_subr_1o
:
2812 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2814 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2815 case scm_tc7_rpsubr
:
2816 RETURN (SCM_BOOL_T
);
2818 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2820 if (!SCM_SMOB_APPLICABLE_P (proc
))
2822 RETURN (SCM_SMOB_APPLY_0 (proc
));
2825 proc
= SCM_CCLO_SUBR (proc
);
2827 debug
.info
->a
.proc
= proc
;
2828 debug
.info
->a
.args
= scm_list_1 (arg1
);
2832 proc
= SCM_PROCEDURE (proc
);
2834 debug
.info
->a
.proc
= proc
;
2836 if (!SCM_CLOSUREP (proc
))
2838 if (scm_badformalsp (proc
, 0))
2839 goto umwrongnumargs
;
2840 case scm_tcs_closures
:
2841 x
= SCM_CLOSURE_BODY (proc
);
2842 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2843 goto nontoplevel_begin
;
2844 case scm_tcs_struct
:
2845 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2847 x
= SCM_ENTITY_PROCEDURE (proc
);
2851 else if (!SCM_I_OPERATORP (proc
))
2856 proc
= (SCM_I_ENTITYP (proc
)
2857 ? SCM_ENTITY_PROCEDURE (proc
)
2858 : SCM_OPERATOR_PROCEDURE (proc
));
2860 debug
.info
->a
.proc
= proc
;
2861 debug
.info
->a
.args
= scm_list_1 (arg1
);
2863 if (SCM_NIMP (proc
))
2868 case scm_tc7_subr_1
:
2869 case scm_tc7_subr_2
:
2870 case scm_tc7_subr_2o
:
2872 case scm_tc7_subr_3
:
2873 case scm_tc7_lsubr_2
:
2876 scm_wrong_num_args (proc
);
2878 /* handle macros here */
2883 /* must handle macros by here */
2886 arg1
= EVALCAR (x
, env
);
2888 scm_wrong_num_args (proc
);
2890 debug
.info
->a
.args
= scm_list_1 (arg1
);
2898 evap1
: /* inputs: proc, arg1 */
2899 switch (SCM_TYP7 (proc
))
2900 { /* have one argument in arg1 */
2901 case scm_tc7_subr_2o
:
2902 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2903 case scm_tc7_subr_1
:
2904 case scm_tc7_subr_1o
:
2905 RETURN (SCM_SUBRF (proc
) (arg1
));
2907 if (SCM_SUBRF (proc
))
2909 if (SCM_INUMP (arg1
))
2911 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2913 else if (SCM_REALP (arg1
))
2915 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2918 else if (SCM_BIGP (arg1
))
2920 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2923 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2924 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2926 proc
= SCM_SNAME (proc
);
2928 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2929 while ('c' != *--chrs
)
2931 SCM_ASSERT (SCM_CONSP (arg1
),
2932 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2933 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2937 case scm_tc7_rpsubr
:
2938 RETURN (SCM_BOOL_T
);
2940 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2943 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2945 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2948 if (!SCM_SMOB_APPLICABLE_P (proc
))
2950 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2954 proc
= SCM_CCLO_SUBR (proc
);
2956 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2957 debug
.info
->a
.proc
= proc
;
2961 proc
= SCM_PROCEDURE (proc
);
2963 debug
.info
->a
.proc
= proc
;
2965 if (!SCM_CLOSUREP (proc
))
2967 if (scm_badformalsp (proc
, 1))
2968 goto umwrongnumargs
;
2969 case scm_tcs_closures
:
2971 x
= SCM_CLOSURE_BODY (proc
);
2973 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2975 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2977 goto nontoplevel_begin
;
2978 case scm_tcs_struct
:
2979 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2981 x
= SCM_ENTITY_PROCEDURE (proc
);
2983 arg1
= debug
.info
->a
.args
;
2985 arg1
= scm_list_1 (arg1
);
2989 else if (!SCM_I_OPERATORP (proc
))
2995 proc
= (SCM_I_ENTITYP (proc
)
2996 ? SCM_ENTITY_PROCEDURE (proc
)
2997 : SCM_OPERATOR_PROCEDURE (proc
));
2999 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3000 debug
.info
->a
.proc
= proc
;
3002 if (SCM_NIMP (proc
))
3007 case scm_tc7_subr_2
:
3008 case scm_tc7_subr_0
:
3009 case scm_tc7_subr_3
:
3010 case scm_tc7_lsubr_2
:
3011 scm_wrong_num_args (proc
);
3017 arg2
= EVALCAR (x
, env
);
3019 scm_wrong_num_args (proc
);
3021 { /* have two or more arguments */
3023 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3026 if (SCM_NULLP (x
)) {
3029 switch (SCM_TYP7 (proc
))
3030 { /* have two arguments */
3031 case scm_tc7_subr_2
:
3032 case scm_tc7_subr_2o
:
3033 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3036 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3038 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3040 case scm_tc7_lsubr_2
:
3041 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3042 case scm_tc7_rpsubr
:
3044 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3046 if (!SCM_SMOB_APPLICABLE_P (proc
))
3048 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3052 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3053 scm_cons (proc
, debug
.info
->a
.args
),
3056 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3057 scm_cons2 (proc
, arg1
,
3064 case scm_tcs_struct
:
3065 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3067 x
= SCM_ENTITY_PROCEDURE (proc
);
3069 arg1
= debug
.info
->a
.args
;
3071 arg1
= scm_list_2 (arg1
, arg2
);
3075 else if (!SCM_I_OPERATORP (proc
))
3081 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3082 ? SCM_ENTITY_PROCEDURE (proc
)
3083 : SCM_OPERATOR_PROCEDURE (proc
),
3084 scm_cons (proc
, debug
.info
->a
.args
),
3087 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3088 ? SCM_ENTITY_PROCEDURE (proc
)
3089 : SCM_OPERATOR_PROCEDURE (proc
),
3090 scm_cons2 (proc
, arg1
,
3098 case scm_tc7_subr_0
:
3100 case scm_tc7_subr_1o
:
3101 case scm_tc7_subr_1
:
3102 case scm_tc7_subr_3
:
3103 scm_wrong_num_args (proc
);
3107 proc
= SCM_PROCEDURE (proc
);
3109 debug
.info
->a
.proc
= proc
;
3111 if (!SCM_CLOSUREP (proc
))
3113 if (scm_badformalsp (proc
, 2))
3114 goto umwrongnumargs
;
3115 case scm_tcs_closures
:
3118 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3122 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3123 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3125 x
= SCM_CLOSURE_BODY (proc
);
3126 goto nontoplevel_begin
;
3130 scm_wrong_num_args (proc
);
3132 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3133 deval_args (x
, env
, proc
,
3134 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3138 switch (SCM_TYP7 (proc
))
3139 { /* have 3 or more arguments */
3141 case scm_tc7_subr_3
:
3142 if (!SCM_NULLP (SCM_CDR (x
)))
3143 scm_wrong_num_args (proc
);
3145 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3146 SCM_CADDR (debug
.info
->a
.args
)));
3148 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3149 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3152 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3153 arg2
= SCM_CDR (arg2
);
3155 while (SCM_NIMP (arg2
));
3157 case scm_tc7_rpsubr
:
3158 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3159 RETURN (SCM_BOOL_F
);
3160 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3163 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3164 RETURN (SCM_BOOL_F
);
3165 arg2
= SCM_CAR (arg1
);
3166 arg1
= SCM_CDR (arg1
);
3168 while (SCM_NIMP (arg1
));
3169 RETURN (SCM_BOOL_T
);
3170 case scm_tc7_lsubr_2
:
3171 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3172 SCM_CDDR (debug
.info
->a
.args
)));
3174 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3176 if (!SCM_SMOB_APPLICABLE_P (proc
))
3178 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3179 SCM_CDDR (debug
.info
->a
.args
)));
3183 proc
= SCM_PROCEDURE (proc
);
3184 debug
.info
->a
.proc
= proc
;
3185 if (!SCM_CLOSUREP (proc
))
3187 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3188 goto umwrongnumargs
;
3189 case scm_tcs_closures
:
3190 SCM_SET_ARGSREADY (debug
);
3191 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3194 x
= SCM_CLOSURE_BODY (proc
);
3195 goto nontoplevel_begin
;
3197 case scm_tc7_subr_3
:
3198 if (!SCM_NULLP (SCM_CDR (x
)))
3199 scm_wrong_num_args (proc
);
3201 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3203 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3206 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3209 while (SCM_NIMP (x
));
3211 case scm_tc7_rpsubr
:
3212 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3213 RETURN (SCM_BOOL_F
);
3216 arg1
= EVALCAR (x
, env
);
3217 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3218 RETURN (SCM_BOOL_F
);
3222 while (SCM_NIMP (x
));
3223 RETURN (SCM_BOOL_T
);
3224 case scm_tc7_lsubr_2
:
3225 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3227 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3229 scm_eval_args (x
, env
, proc
))));
3231 if (!SCM_SMOB_APPLICABLE_P (proc
))
3233 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3234 scm_eval_args (x
, env
, proc
)));
3238 proc
= SCM_PROCEDURE (proc
);
3239 if (!SCM_CLOSUREP (proc
))
3242 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3243 if (SCM_NULLP (formals
)
3244 || (SCM_CONSP (formals
)
3245 && (SCM_NULLP (SCM_CDR (formals
))
3246 || (SCM_CONSP (SCM_CDR (formals
))
3247 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3248 goto umwrongnumargs
;
3250 case scm_tcs_closures
:
3252 SCM_SET_ARGSREADY (debug
);
3254 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3257 scm_eval_args (x
, env
, proc
)),
3259 x
= SCM_CLOSURE_BODY (proc
);
3260 goto nontoplevel_begin
;
3262 case scm_tcs_struct
:
3263 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3266 arg1
= debug
.info
->a
.args
;
3268 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3270 x
= SCM_ENTITY_PROCEDURE (proc
);
3273 else if (!SCM_I_OPERATORP (proc
))
3277 case scm_tc7_subr_2
:
3278 case scm_tc7_subr_1o
:
3279 case scm_tc7_subr_2o
:
3280 case scm_tc7_subr_0
:
3282 case scm_tc7_subr_1
:
3283 scm_wrong_num_args (proc
);
3291 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3292 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3294 SCM_CLEAR_TRACED_FRAME (debug
);
3295 if (SCM_CHEAPTRAPS_P
)
3296 arg1
= scm_make_debugobj (&debug
);
3300 SCM val
= scm_make_continuation (&first
);
3311 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3315 scm_last_debug_frame
= debug
.prev
;
3321 /* SECTION: This code is compiled once.
3327 /* Simple procedure calls
3331 scm_call_0 (SCM proc
)
3333 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3337 scm_call_1 (SCM proc
, SCM arg1
)
3339 return scm_apply (proc
, arg1
, scm_listofnull
);
3343 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3345 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3349 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3351 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3355 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3357 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3358 scm_cons (arg4
, scm_listofnull
)));
3361 /* Simple procedure applies
3365 scm_apply_0 (SCM proc
, SCM args
)
3367 return scm_apply (proc
, args
, SCM_EOL
);
3371 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3373 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3377 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3379 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3383 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3385 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3389 /* This code processes the arguments to apply:
3391 (apply PROC ARG1 ... ARGS)
3393 Given a list (ARG1 ... ARGS), this function conses the ARG1
3394 ... arguments onto the front of ARGS, and returns the resulting
3395 list. Note that ARGS is a list; thus, the argument to this
3396 function is a list whose last element is a list.
3398 Apply calls this function, and applies PROC to the elements of the
3399 result. apply:nconc2last takes care of building the list of
3400 arguments, given (ARG1 ... ARGS).
3402 Rather than do new consing, apply:nconc2last destroys its argument.
3403 On that topic, this code came into my care with the following
3404 beautifully cryptic comment on that topic: "This will only screw
3405 you if you do (scm_apply scm_apply '( ... ))" If you know what
3406 they're referring to, send me a patch to this comment. */
3408 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3410 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3411 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3412 "@var{args}, and returns the resulting list. Note that\n"
3413 "@var{args} is a list; thus, the argument to this function is\n"
3414 "a list whose last element is a list.\n"
3415 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3416 "destroys its argument, so use with care.")
3417 #define FUNC_NAME s_scm_nconc2last
3420 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3422 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3423 SCM_NULL_OR_NIL_P, but not
3424 needed in 99.99% of cases,
3425 and it could seriously hurt
3426 performance. - Neil */
3427 lloc
= SCM_CDRLOC (*lloc
);
3428 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3429 *lloc
= SCM_CAR (*lloc
);
3437 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3438 * It is compiled twice.
3443 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3449 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3454 /* Apply a function to a list of arguments.
3456 This function is exported to the Scheme level as taking two
3457 required arguments and a tail argument, as if it were:
3458 (lambda (proc arg1 . args) ...)
3459 Thus, if you just have a list of arguments to pass to a procedure,
3460 pass the list as ARG1, and '() for ARGS. If you have some fixed
3461 args, pass the first as ARG1, then cons any remaining fixed args
3462 onto the front of your argument list, and pass that as ARGS. */
3465 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3467 #ifdef DEBUG_EXTENSIONS
3469 scm_t_debug_frame debug
;
3470 scm_t_debug_info debug_vect_body
;
3471 debug
.prev
= scm_last_debug_frame
;
3472 debug
.status
= SCM_APPLYFRAME
;
3473 debug
.vect
= &debug_vect_body
;
3474 debug
.vect
[0].a
.proc
= proc
;
3475 debug
.vect
[0].a
.args
= SCM_EOL
;
3476 scm_last_debug_frame
= &debug
;
3479 return scm_dapply (proc
, arg1
, args
);
3483 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3485 /* If ARGS is the empty list, then we're calling apply with only two
3486 arguments --- ARG1 is the list of arguments for PROC. Whatever
3487 the case, futz with things so that ARG1 is the first argument to
3488 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3491 Setting the debug apply frame args this way is pretty messy.
3492 Perhaps we should store arg1 and args directly in the frame as
3493 received, and let scm_frame_arguments unpack them, because that's
3494 a relatively rare operation. This works for now; if the Guile
3495 developer archives are still around, see Mikael's post of
3497 if (SCM_NULLP (args
))
3499 if (SCM_NULLP (arg1
))
3501 arg1
= SCM_UNDEFINED
;
3503 debug
.vect
[0].a
.args
= SCM_EOL
;
3509 debug
.vect
[0].a
.args
= arg1
;
3511 args
= SCM_CDR (arg1
);
3512 arg1
= SCM_CAR (arg1
);
3517 args
= scm_nconc2last (args
);
3519 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3523 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3526 if (SCM_CHEAPTRAPS_P
)
3527 tmp
= scm_make_debugobj (&debug
);
3532 tmp
= scm_make_continuation (&first
);
3537 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3544 switch (SCM_TYP7 (proc
))
3546 case scm_tc7_subr_2o
:
3547 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3548 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3549 case scm_tc7_subr_2
:
3550 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3551 scm_wrong_num_args (proc
);
3552 args
= SCM_CAR (args
);
3553 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3554 case scm_tc7_subr_0
:
3555 if (!SCM_UNBNDP (arg1
))
3556 scm_wrong_num_args (proc
);
3558 RETURN (SCM_SUBRF (proc
) ());
3559 case scm_tc7_subr_1
:
3560 if (SCM_UNBNDP (arg1
))
3561 scm_wrong_num_args (proc
);
3562 case scm_tc7_subr_1o
:
3563 if (!SCM_NULLP (args
))
3564 scm_wrong_num_args (proc
);
3566 RETURN (SCM_SUBRF (proc
) (arg1
));
3568 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3569 scm_wrong_num_args (proc
);
3570 if (SCM_SUBRF (proc
))
3572 if (SCM_INUMP (arg1
))
3574 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3576 else if (SCM_REALP (arg1
))
3578 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3581 else if (SCM_BIGP (arg1
))
3582 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3584 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3585 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3587 proc
= SCM_SNAME (proc
);
3589 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3590 while ('c' != *--chrs
)
3592 SCM_ASSERT (SCM_CONSP (arg1
),
3593 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3594 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3598 case scm_tc7_subr_3
:
3599 if (SCM_NULLP (args
)
3600 || SCM_NULLP (SCM_CDR (args
))
3601 || !SCM_NULLP (SCM_CDDR (args
)))
3602 scm_wrong_num_args (proc
);
3604 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3607 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3609 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3611 case scm_tc7_lsubr_2
:
3612 if (!SCM_CONSP (args
))
3613 scm_wrong_num_args (proc
);
3615 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3617 if (SCM_NULLP (args
))
3618 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3619 while (SCM_NIMP (args
))
3621 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3622 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3623 args
= SCM_CDR (args
);
3626 case scm_tc7_rpsubr
:
3627 if (SCM_NULLP (args
))
3628 RETURN (SCM_BOOL_T
);
3629 while (SCM_NIMP (args
))
3631 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3632 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3633 RETURN (SCM_BOOL_F
);
3634 arg1
= SCM_CAR (args
);
3635 args
= SCM_CDR (args
);
3637 RETURN (SCM_BOOL_T
);
3638 case scm_tcs_closures
:
3640 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3642 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3644 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3645 scm_wrong_num_args (proc
);
3647 /* Copy argument list */
3652 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3653 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3655 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3659 SCM_SETCDR (tl
, arg1
);
3662 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3663 proc
= SCM_CLOSURE_BODY (proc
);
3666 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3668 if (SCM_IMP (SCM_CAR (proc
)))
3670 if (SCM_ISYMP (SCM_CAR (proc
)))
3672 scm_rec_mutex_lock (&source_mutex
);
3673 /* check for race condition */
3674 if (SCM_ISYMP (SCM_CAR (proc
)))
3675 proc
= scm_m_expand_body (proc
, args
);
3676 scm_rec_mutex_unlock (&source_mutex
);
3680 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3683 SCM_CEVAL (SCM_CAR (proc
), args
);
3686 RETURN (EVALCAR (proc
, args
));
3688 if (!SCM_SMOB_APPLICABLE_P (proc
))
3690 if (SCM_UNBNDP (arg1
))
3691 RETURN (SCM_SMOB_APPLY_0 (proc
));
3692 else if (SCM_NULLP (args
))
3693 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3694 else if (SCM_NULLP (SCM_CDR (args
)))
3695 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3697 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3700 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3702 proc
= SCM_CCLO_SUBR (proc
);
3703 debug
.vect
[0].a
.proc
= proc
;
3704 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3706 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3708 proc
= SCM_CCLO_SUBR (proc
);
3712 proc
= SCM_PROCEDURE (proc
);
3714 debug
.vect
[0].a
.proc
= proc
;
3717 case scm_tcs_struct
:
3718 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3721 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3723 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3725 RETURN (scm_apply_generic (proc
, args
));
3727 else if (!SCM_I_OPERATORP (proc
))
3733 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3735 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3738 proc
= (SCM_I_ENTITYP (proc
)
3739 ? SCM_ENTITY_PROCEDURE (proc
)
3740 : SCM_OPERATOR_PROCEDURE (proc
));
3742 debug
.vect
[0].a
.proc
= proc
;
3743 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3745 if (SCM_NIMP (proc
))
3752 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3756 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3757 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3759 SCM_CLEAR_TRACED_FRAME (debug
);
3760 if (SCM_CHEAPTRAPS_P
)
3761 arg1
= scm_make_debugobj (&debug
);
3765 SCM val
= scm_make_continuation (&first
);
3776 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3780 scm_last_debug_frame
= debug
.prev
;
3786 /* SECTION: The rest of this file is only read once.
3793 * Trampolines make it possible to move procedure application dispatch
3794 * outside inner loops. The motivation was clean implementation of
3795 * efficient replacements of R5RS primitives in SRFI-1.
3797 * The semantics is clear: scm_trampoline_N returns an optimized
3798 * version of scm_call_N (or NULL if the procedure isn't applicable
3801 * Applying the optimization to map and for-each increased efficiency
3802 * noticeably. For example, (map abs ls) is now 8 times faster than
3807 call_subr0_0 (SCM proc
)
3809 return SCM_SUBRF (proc
) ();
3813 call_subr1o_0 (SCM proc
)
3815 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3819 call_lsubr_0 (SCM proc
)
3821 return SCM_SUBRF (proc
) (SCM_EOL
);
3825 scm_i_call_closure_0 (SCM proc
)
3827 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3828 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3834 scm_trampoline_0 (SCM proc
)
3840 switch (SCM_TYP7 (proc
))
3842 case scm_tc7_subr_0
:
3843 return call_subr0_0
;
3844 case scm_tc7_subr_1o
:
3845 return call_subr1o_0
;
3847 return call_lsubr_0
;
3848 case scm_tcs_closures
:
3850 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3851 if (SCM_NULLP (formals
) || SCM_SYMBOLP (formals
))
3852 return scm_i_call_closure_0
;
3856 case scm_tcs_struct
:
3857 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3858 return scm_call_generic_0
;
3859 else if (!SCM_I_OPERATORP (proc
))
3863 if (SCM_SMOB_APPLICABLE_P (proc
))
3864 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3869 case scm_tc7_rpsubr
:
3874 return 0; /* not applicable on one arg */
3879 call_subr1_1 (SCM proc
, SCM arg1
)
3881 return SCM_SUBRF (proc
) (arg1
);
3885 call_subr2o_1 (SCM proc
, SCM arg1
)
3887 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3891 call_lsubr_1 (SCM proc
, SCM arg1
)
3893 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3897 call_dsubr_1 (SCM proc
, SCM arg1
)
3899 if (SCM_INUMP (arg1
))
3901 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3903 else if (SCM_REALP (arg1
))
3905 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3908 else if (SCM_BIGP (arg1
))
3909 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3911 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3912 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3916 call_cxr_1 (SCM proc
, SCM arg1
)
3918 proc
= SCM_SNAME (proc
);
3920 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3921 while ('c' != *--chrs
)
3923 SCM_ASSERT (SCM_CONSP (arg1
),
3924 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3925 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3932 call_closure_1 (SCM proc
, SCM arg1
)
3934 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3935 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3941 scm_trampoline_1 (SCM proc
)
3947 switch (SCM_TYP7 (proc
))
3949 case scm_tc7_subr_1
:
3950 case scm_tc7_subr_1o
:
3951 return call_subr1_1
;
3952 case scm_tc7_subr_2o
:
3953 return call_subr2o_1
;
3955 return call_lsubr_1
;
3957 if (SCM_SUBRF (proc
))
3958 return call_dsubr_1
;
3961 case scm_tcs_closures
:
3963 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3964 if ((SCM_CONSP (formals
) && SCM_NULLP (SCM_CDR (formals
)))
3965 || SCM_SYMBOLP (formals
))
3966 return call_closure_1
;
3970 case scm_tcs_struct
:
3971 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3972 return scm_call_generic_1
;
3973 else if (!SCM_I_OPERATORP (proc
))
3977 if (SCM_SMOB_APPLICABLE_P (proc
))
3978 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3983 case scm_tc7_rpsubr
:
3988 return 0; /* not applicable on one arg */
3993 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3995 return SCM_SUBRF (proc
) (arg1
, arg2
);
3999 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4001 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4005 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4007 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4011 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4013 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
4014 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4015 scm_list_2 (arg1
, arg2
),
4020 scm_trampoline_2 (SCM proc
)
4026 switch (SCM_TYP7 (proc
))
4028 case scm_tc7_subr_2
:
4029 case scm_tc7_subr_2o
:
4030 case scm_tc7_rpsubr
:
4032 return call_subr2_2
;
4033 case scm_tc7_lsubr_2
:
4034 return call_lsubr2_2
;
4036 return call_lsubr_2
;
4037 case scm_tcs_closures
:
4039 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4040 if (!SCM_CONSP (formals
)
4041 || (SCM_CONSP (SCM_CDR (formals
))
4042 && SCM_NULLP (SCM_CDDR (formals
))))
4043 return call_closure_2
;
4047 case scm_tcs_struct
:
4048 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4049 return scm_call_generic_2
;
4050 else if (!SCM_I_OPERATORP (proc
))
4054 if (SCM_SMOB_APPLICABLE_P (proc
))
4055 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4063 return 0; /* not applicable on two args */
4067 /* Typechecking for multi-argument MAP and FOR-EACH.
4069 Verify that each element of the vector ARGV, except for the first,
4070 is a proper list whose length is LEN. Attribute errors to WHO,
4071 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4073 check_map_args (SCM argv
,
4080 SCM
const *ve
= SCM_VELTS (argv
);
4083 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4085 long elt_len
= scm_ilength (ve
[i
]);
4090 scm_apply_generic (gf
, scm_cons (proc
, args
));
4092 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4096 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4099 scm_remember_upto_here_1 (argv
);
4103 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4105 /* Note: Currently, scm_map applies PROC to the argument list(s)
4106 sequentially, starting with the first element(s). This is used in
4107 evalext.c where the Scheme procedure `map-in-order', which guarantees
4108 sequential behaviour, is implemented using scm_map. If the
4109 behaviour changes, we need to update `map-in-order'.
4113 scm_map (SCM proc
, SCM arg1
, SCM args
)
4114 #define FUNC_NAME s_map
4119 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4121 len
= scm_ilength (arg1
);
4122 SCM_GASSERTn (len
>= 0,
4123 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4124 SCM_VALIDATE_REST_ARGUMENT (args
);
4125 if (SCM_NULLP (args
))
4127 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4128 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4129 while (SCM_NIMP (arg1
))
4131 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4132 pres
= SCM_CDRLOC (*pres
);
4133 arg1
= SCM_CDR (arg1
);
4137 if (SCM_NULLP (SCM_CDR (args
)))
4139 SCM arg2
= SCM_CAR (args
);
4140 int len2
= scm_ilength (arg2
);
4141 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4143 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4144 SCM_GASSERTn (len2
>= 0,
4145 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4147 SCM_OUT_OF_RANGE (3, arg2
);
4148 while (SCM_NIMP (arg1
))
4150 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4151 pres
= SCM_CDRLOC (*pres
);
4152 arg1
= SCM_CDR (arg1
);
4153 arg2
= SCM_CDR (arg2
);
4157 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4158 ve
= SCM_VELTS (args
);
4159 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4163 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4165 if (SCM_IMP (ve
[i
]))
4167 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4168 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4170 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4171 pres
= SCM_CDRLOC (*pres
);
4177 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4180 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4181 #define FUNC_NAME s_for_each
4183 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4185 len
= scm_ilength (arg1
);
4186 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4187 SCM_ARG2
, s_for_each
);
4188 SCM_VALIDATE_REST_ARGUMENT (args
);
4189 if (SCM_NULLP (args
))
4191 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4192 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4193 while (SCM_NIMP (arg1
))
4195 call (proc
, SCM_CAR (arg1
));
4196 arg1
= SCM_CDR (arg1
);
4198 return SCM_UNSPECIFIED
;
4200 if (SCM_NULLP (SCM_CDR (args
)))
4202 SCM arg2
= SCM_CAR (args
);
4203 int len2
= scm_ilength (arg2
);
4204 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4205 SCM_GASSERTn (call
, g_for_each
,
4206 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4207 SCM_GASSERTn (len2
>= 0, g_for_each
,
4208 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4210 SCM_OUT_OF_RANGE (3, arg2
);
4211 while (SCM_NIMP (arg1
))
4213 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4214 arg1
= SCM_CDR (arg1
);
4215 arg2
= SCM_CDR (arg2
);
4217 return SCM_UNSPECIFIED
;
4219 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4220 ve
= SCM_VELTS (args
);
4221 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4225 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4227 if (SCM_IMP (ve
[i
]))
4228 return SCM_UNSPECIFIED
;
4229 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4230 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4232 scm_apply (proc
, arg1
, SCM_EOL
);
4239 scm_closure (SCM code
, SCM env
)
4242 SCM closcar
= scm_cons (code
, SCM_EOL
);
4243 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4244 scm_remember_upto_here (closcar
);
4249 scm_t_bits scm_tc16_promise
;
4252 scm_makprom (SCM code
)
4254 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4256 scm_make_rec_mutex ());
4260 promise_free (SCM promise
)
4262 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4267 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4269 int writingp
= SCM_WRITINGP (pstate
);
4270 scm_puts ("#<promise ", port
);
4271 SCM_SET_WRITINGP (pstate
, 1);
4272 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4273 SCM_SET_WRITINGP (pstate
, writingp
);
4274 scm_putc ('>', port
);
4278 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4280 "If the promise @var{x} has not been computed yet, compute and\n"
4281 "return @var{x}, otherwise just return the previously computed\n"
4283 #define FUNC_NAME s_scm_force
4285 SCM_VALIDATE_SMOB (1, promise
, promise
);
4286 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4287 if (!SCM_PROMISE_COMPUTED_P (promise
))
4289 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4290 if (!SCM_PROMISE_COMPUTED_P (promise
))
4292 SCM_SET_PROMISE_DATA (promise
, ans
);
4293 SCM_SET_PROMISE_COMPUTED (promise
);
4296 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4297 return SCM_PROMISE_DATA (promise
);
4302 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4304 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4305 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4306 #define FUNC_NAME s_scm_promise_p
4308 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4313 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4314 (SCM xorig
, SCM x
, SCM y
),
4315 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4316 "Any source properties associated with @var{xorig} are also associated\n"
4317 "with the new pair.")
4318 #define FUNC_NAME s_scm_cons_source
4321 z
= scm_cons (x
, y
);
4322 /* Copy source properties possibly associated with xorig. */
4323 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4325 scm_whash_insert (scm_source_whash
, z
, p
);
4331 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4333 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4334 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4335 "contents of both pairs and vectors (since both cons cells and vector\n"
4336 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4337 "any other object.")
4338 #define FUNC_NAME s_scm_copy_tree
4343 if (SCM_VECTORP (obj
))
4345 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4346 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4348 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4351 if (!SCM_CONSP (obj
))
4353 ans
= tl
= scm_cons_source (obj
,
4354 scm_copy_tree (SCM_CAR (obj
)),
4356 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4358 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4362 SCM_SETCDR (tl
, obj
);
4368 /* We have three levels of EVAL here:
4370 - scm_i_eval (exp, env)
4372 evaluates EXP in environment ENV. ENV is a lexical environment
4373 structure as used by the actual tree code evaluator. When ENV is
4374 a top-level environment, then changes to the current module are
4375 tracked by updating ENV so that it continues to be in sync with
4378 - scm_primitive_eval (exp)
4380 evaluates EXP in the top-level environment as determined by the
4381 current module. This is done by constructing a suitable
4382 environment and calling scm_i_eval. Thus, changes to the
4383 top-level module are tracked normally.
4385 - scm_eval (exp, mod)
4387 evaluates EXP while MOD is the current module. This is done by
4388 setting the current module to MOD, invoking scm_primitive_eval on
4389 EXP, and then restoring the current module to the value it had
4390 previously. That is, while EXP is evaluated, changes to the
4391 current module are tracked, but these changes do not persist when
4394 For each level of evals, there are two variants, distinguished by a
4395 _x suffix: the ordinary variant does not modify EXP while the _x
4396 variant can destructively modify EXP into something completely
4397 unintelligible. A Scheme data structure passed as EXP to one of the
4398 _x variants should not ever be used again for anything. So when in
4399 doubt, use the ordinary variant.
4404 scm_i_eval_x (SCM exp
, SCM env
)
4406 return SCM_XEVAL (exp
, env
);
4410 scm_i_eval (SCM exp
, SCM env
)
4412 exp
= scm_copy_tree (exp
);
4413 return SCM_XEVAL (exp
, env
);
4417 scm_primitive_eval_x (SCM exp
)
4420 SCM transformer
= scm_current_module_transformer ();
4421 if (SCM_NIMP (transformer
))
4422 exp
= scm_call_1 (transformer
, exp
);
4423 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4424 return scm_i_eval_x (exp
, env
);
4427 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4429 "Evaluate @var{exp} in the top-level environment specified by\n"
4430 "the current module.")
4431 #define FUNC_NAME s_scm_primitive_eval
4434 SCM transformer
= scm_current_module_transformer ();
4435 if (SCM_NIMP (transformer
))
4436 exp
= scm_call_1 (transformer
, exp
);
4437 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4438 return scm_i_eval (exp
, env
);
4442 /* Eval does not take the second arg optionally. This is intentional
4443 * in order to be R5RS compatible, and to prepare for the new module
4444 * system, where we would like to make the choice of evaluation
4445 * environment explicit. */
4448 change_environment (void *data
)
4450 SCM pair
= SCM_PACK (data
);
4451 SCM new_module
= SCM_CAR (pair
);
4452 SCM old_module
= scm_current_module ();
4453 SCM_SETCDR (pair
, old_module
);
4454 scm_set_current_module (new_module
);
4459 restore_environment (void *data
)
4461 SCM pair
= SCM_PACK (data
);
4462 SCM old_module
= SCM_CDR (pair
);
4463 SCM new_module
= scm_current_module ();
4464 SCM_SETCAR (pair
, new_module
);
4465 scm_set_current_module (old_module
);
4469 inner_eval_x (void *data
)
4471 return scm_primitive_eval_x (SCM_PACK(data
));
4475 scm_eval_x (SCM exp
, SCM module
)
4476 #define FUNC_NAME "eval!"
4478 SCM_VALIDATE_MODULE (2, module
);
4480 return scm_internal_dynamic_wind
4481 (change_environment
, inner_eval_x
, restore_environment
,
4482 (void *) SCM_UNPACK (exp
),
4483 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4488 inner_eval (void *data
)
4490 return scm_primitive_eval (SCM_PACK(data
));
4493 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4494 (SCM exp
, SCM module
),
4495 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4496 "in the top-level environment specified by @var{module}.\n"
4497 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4498 "@var{module} is made the current module. The current module\n"
4499 "is reset to its previous value when @var{eval} returns.")
4500 #define FUNC_NAME s_scm_eval
4502 SCM_VALIDATE_MODULE (2, module
);
4504 return scm_internal_dynamic_wind
4505 (change_environment
, inner_eval
, restore_environment
,
4506 (void *) SCM_UNPACK (exp
),
4507 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4512 /* At this point, scm_deval and scm_dapply are generated.
4515 #ifdef DEBUG_EXTENSIONS
4525 scm_init_opts (scm_evaluator_traps
,
4526 scm_evaluator_trap_table
,
4527 SCM_N_EVALUATOR_TRAPS
);
4528 scm_init_opts (scm_eval_options_interface
,
4530 SCM_N_EVAL_OPTIONS
);
4532 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4533 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4534 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4535 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4537 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4538 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4539 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4540 scm_listofnull
= scm_list_1 (SCM_EOL
);
4542 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4547 #include "libguile/eval.x"
4549 scm_add_feature ("delay");