1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This file is read twice in order to produce debugging versions of
21 * scm_ceval and scm_apply. These functions, scm_deval and
22 * scm_dapply, are produced when we define the preprocessor macro
23 * DEVAL. The file is divided into sections which are treated
24 * differently with respect to DEVAL. The heads of these sections are
25 * marked with the string "SECTION:".
28 /* SECTION: This code is compiled once.
35 #include "libguile/__scm.h"
39 /* AIX requires this to be the first thing in the file. The #pragma
40 directive is indented so pre-ANSI compilers will ignore it, rather
49 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/debug.h"
58 #include "libguile/dynwind.h"
59 #include "libguile/alist.h"
60 #include "libguile/eq.h"
61 #include "libguile/continuations.h"
62 #include "libguile/futures.h"
63 #include "libguile/throw.h"
64 #include "libguile/smob.h"
65 #include "libguile/macros.h"
66 #include "libguile/procprop.h"
67 #include "libguile/hashtab.h"
68 #include "libguile/hash.h"
69 #include "libguile/srcprop.h"
70 #include "libguile/stackchk.h"
71 #include "libguile/objects.h"
72 #include "libguile/async.h"
73 #include "libguile/feature.h"
74 #include "libguile/modules.h"
75 #include "libguile/ports.h"
76 #include "libguile/root.h"
77 #include "libguile/vectors.h"
78 #include "libguile/fluids.h"
79 #include "libguile/goops.h"
80 #include "libguile/values.h"
82 #include "libguile/validate.h"
83 #include "libguile/eval.h"
84 #include "libguile/lang.h"
88 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
90 if (SCM_EQ_P ((x), SCM_EOL)) \
91 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
96 /* The evaluator contains a plethora of EVAL symbols.
97 * This is an attempt at explanation.
99 * The following macros should be used in code which is read twice
100 * (where the choice of evaluator is hard soldered):
102 * SCM_CEVAL is the symbol used within one evaluator to call itself.
103 * Originally, it is defined to scm_ceval, but is redefined to
104 * scm_deval during the second pass.
106 * SCM_EVALIM is used when it is known that the expression is an
107 * immediate. (This macro never calls an evaluator.)
109 * EVALCAR evaluates the car of an expression.
111 * The following macros should be used in code which is read once
112 * (where the choice of evaluator is dynamic):
114 * SCM_XEVAL takes care of immediates without calling an evaluator. It
115 * then calls scm_ceval *or* scm_deval, depending on the debugging
118 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
119 * depending on the debugging mode.
121 * The main motivation for keeping this plethora is efficiency
122 * together with maintainability (=> locality of code).
125 #define SCM_CEVAL scm_ceval
127 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
128 ? SCM_EVALIM (SCM_CAR (x), env) \
129 : (SCM_SYMBOLP (SCM_CAR (x)) \
130 ? *scm_lookupcar (x, env, 1) \
131 : SCM_CEVAL (SCM_CAR (x), env)))
133 SCM_REC_MUTEX (source_mutex
);
136 scm_ilookup (SCM iloc
, SCM env
)
138 register long ir
= SCM_IFRAME (iloc
);
139 register SCM er
= env
;
140 for (; 0 != ir
; --ir
)
143 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
145 if (SCM_ICDRP (iloc
))
146 return SCM_CDRLOC (er
);
147 return SCM_CARLOC (SCM_CDR (er
));
150 /* The Lookup Car Race
153 Memoization of variables and special forms is done while executing
154 the code for the first time. As long as there is only one thread
155 everything is fine, but as soon as two threads execute the same
156 code concurrently `for the first time' they can come into conflict.
158 This memoization includes rewriting variable references into more
159 efficient forms and expanding macros. Furthermore, macro expansion
160 includes `compiling' special forms like `let', `cond', etc. into
161 tree-code instructions.
163 There shouldn't normally be a problem with memoizing local and
164 global variable references (into ilocs and variables), because all
165 threads will mutate the code in *exactly* the same way and (if I
166 read the C code correctly) it is not possible to observe a half-way
167 mutated cons cell. The lookup procedure can handle this
168 transparently without any critical sections.
170 It is different with macro expansion, because macro expansion
171 happens outside of the lookup procedure and can't be
172 undone. Therefore the lookup procedure can't cope with it. It has
173 to indicate failure when it detects a lost race and hope that the
174 caller can handle it. Luckily, it turns out that this is the case.
176 An example to illustrate this: Suppose that the following form will
177 be memoized concurrently by two threads
181 Let's first examine the lookup of X in the body. The first thread
182 decides that it has to find the symbol "x" in the environment and
183 starts to scan it. Then the other thread takes over and actually
184 overtakes the first. It looks up "x" and substitutes an
185 appropriate iloc for it. Now the first thread continues and
186 completes its lookup. It comes to exactly the same conclusions as
187 the second one and could - without much ado - just overwrite the
188 iloc with the same iloc.
190 But let's see what will happen when the race occurs while looking
191 up the symbol "let" at the start of the form. It could happen that
192 the second thread interrupts the lookup of the first thread and not
193 only substitutes a variable for it but goes right ahead and
194 replaces it with the compiled form (#@let* (x 12) x). Now, when
195 the first thread completes its lookup, it would replace the #@let*
196 with a variable containing the "let" binding, effectively reverting
197 the form to (let (x 12) x). This is wrong. It has to detect that
198 it has lost the race and the evaluator has to reconsider the
199 changed form completely.
201 This race condition could be resolved with some kind of traffic
202 light (like mutexes) around scm_lookupcar, but I think that it is
203 best to avoid them in this case. They would serialize memoization
204 completely and because lookup involves calling arbitrary Scheme
205 code (via the lookup-thunk), threads could be blocked for an
206 arbitrary amount of time or even deadlock. But with the current
207 solution a lot of unnecessary work is potentially done. */
209 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
210 return NULL to indicate a failed lookup due to some race conditions
211 between threads. This only happens when VLOC is the first cell of
212 a special form that will eventually be memoized (like `let', etc.)
213 In that case the whole lookup is bogus and the caller has to
214 reconsider the complete special form.
216 SCM_LOOKUPCAR is still there, of course. It just calls
217 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
218 should only be called when it is known that VLOC is not the first
219 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
220 for NULL. I think I've found the only places where this
223 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
226 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
229 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
230 register SCM iloc
= SCM_ILOC00
;
231 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
233 if (!SCM_CONSP (SCM_CAR (env
)))
235 al
= SCM_CARLOC (env
);
236 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
240 if (SCM_EQ_P (fl
, var
))
242 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
244 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
245 return SCM_CDRLOC (*al
);
250 al
= SCM_CDRLOC (*al
);
251 if (SCM_EQ_P (SCM_CAR (fl
), var
))
253 if (SCM_UNBNDP (SCM_CAR (*al
)))
258 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
260 SCM_SETCAR (vloc
, iloc
);
261 return SCM_CARLOC (*al
);
263 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
265 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
268 SCM top_thunk
, real_var
;
271 top_thunk
= SCM_CAR (env
); /* env now refers to a
272 top level env thunk */
276 top_thunk
= SCM_BOOL_F
;
277 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
278 if (SCM_FALSEP (real_var
))
281 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
287 scm_error (scm_unbound_variable_key
, NULL
,
288 "Unbound variable: ~S",
289 scm_list_1 (var
), SCM_BOOL_F
);
291 scm_misc_error (NULL
, "Damaged environment: ~S",
296 /* A variable could not be found, but we shall
297 not throw an error. */
298 static SCM undef_object
= SCM_UNDEFINED
;
299 return &undef_object
;
303 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
305 /* Some other thread has changed the very cell we are working
306 on. In effect, it must have done our job or messed it up
309 var
= SCM_CAR (vloc
);
310 if (SCM_VARIABLEP (var
))
311 return SCM_VARIABLE_LOC (var
);
312 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
313 return scm_ilookup (var
, genv
);
314 /* We can't cope with anything else than variables and ilocs. When
315 a special form has been memoized (i.e. `let' into `#@let') we
316 return NULL and expect the calling function to do the right
317 thing. For the evaluator, this means going back and redoing
318 the dispatch on the car of the form. */
322 SCM_SETCAR (vloc
, real_var
);
323 return SCM_VARIABLE_LOC (real_var
);
328 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
330 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
336 #define unmemocar scm_unmemocar
338 SCM_SYMBOL (sym_three_question_marks
, "???");
341 scm_unmemocar (SCM form
, SCM env
)
343 if (!SCM_CONSP (form
))
347 SCM c
= SCM_CAR (form
);
348 if (SCM_VARIABLEP (c
))
350 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
351 if (SCM_FALSEP (sym
))
352 sym
= sym_three_question_marks
;
353 SCM_SETCAR (form
, sym
);
355 else if (SCM_ILOCP (c
))
357 unsigned long int ir
;
359 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
361 env
= SCM_CAAR (env
);
362 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
364 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
372 scm_eval_car (SCM pair
, SCM env
)
374 return SCM_XEVALCAR (pair
, env
);
379 * The following rewrite expressions and
380 * some memoized forms have different syntax
383 const char scm_s_expression
[] = "missing or extra expression";
384 const char scm_s_test
[] = "bad test";
385 const char scm_s_body
[] = "bad body";
386 const char scm_s_bindings
[] = "bad bindings";
387 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
388 const char scm_s_variable
[] = "bad variable";
389 const char scm_s_clauses
[] = "bad or missing clauses";
390 const char scm_s_formals
[] = "bad formals";
391 const char scm_s_duplicate_formals
[] = "duplicate formals";
392 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
394 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
395 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
396 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
397 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
398 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
400 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
401 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
402 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
403 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
406 /* Check that the body denoted by XORIG is valid and rewrite it into
407 its internal form. The internal form of a body is just the body
408 itself, but prefixed with an ISYM that denotes to what kind of
409 outer construct this body belongs. A lambda body starts with
410 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
411 etc. The one exception is a body that belongs to a letrec that has
412 been formed by rewriting internal defines: it starts with
415 /* XXX - Besides controlling the rewriting of internal defines, the
416 additional ISYM could be used for improved error messages.
417 This is not done yet. */
420 scm_m_body (SCM op
, SCM xorig
, const char *what
)
422 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
424 /* Don't add another ISYM if one is present already. */
425 if (SCM_ISYMP (SCM_CAR (xorig
)))
428 /* Retain possible doc string. */
429 if (!SCM_CONSP (SCM_CAR (xorig
)))
431 if (!SCM_NULLP (SCM_CDR (xorig
)))
432 return scm_cons (SCM_CAR (xorig
),
433 scm_m_body (op
, SCM_CDR (xorig
), what
));
437 return scm_cons (op
, xorig
);
441 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
442 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
445 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
447 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
448 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
452 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
453 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
456 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
458 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
459 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
463 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
464 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
467 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
469 long len
= scm_ilength (SCM_CDR (xorig
));
470 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
471 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
475 /* Will go into the RnRS module when Guile is factorized.
476 SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */
477 static const char s_set_x
[] = "set!";
478 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
481 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
483 SCM x
= SCM_CDR (xorig
);
484 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, s_set_x
);
485 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, s_set_x
);
486 return scm_cons (SCM_IM_SET_X
, x
);
490 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
491 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
494 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
496 long len
= scm_ilength (SCM_CDR (xorig
));
497 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
499 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
505 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
506 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
509 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
511 long len
= scm_ilength (SCM_CDR (xorig
));
512 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
514 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
520 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
521 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
524 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
527 SCM cdrx
= SCM_CDR (xorig
);
528 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
529 clauses
= SCM_CDR (cdrx
);
530 while (!SCM_NULLP (clauses
))
532 SCM clause
= SCM_CAR (clauses
);
533 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
534 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
535 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
536 && SCM_NULLP (SCM_CDR (clauses
))),
537 scm_s_clauses
, s_case
);
538 clauses
= SCM_CDR (clauses
);
540 return scm_cons (SCM_IM_CASE
, cdrx
);
544 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
545 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
548 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
550 SCM cdrx
= SCM_CDR (xorig
);
552 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
553 while (!SCM_NULLP (clauses
))
555 SCM clause
= SCM_CAR (clauses
);
556 long len
= scm_ilength (clause
);
557 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
558 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
560 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
561 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
563 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
565 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
566 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
568 clauses
= SCM_CDR (clauses
);
570 return scm_cons (SCM_IM_COND
, cdrx
);
574 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
575 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
577 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
578 * cdr of the last cons. (Thus, LIST is not required to be a proper
579 * list and OBJ can also be found in the improper ending.) */
581 scm_c_improper_memq (SCM obj
, SCM list
)
583 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
585 if (SCM_EQ_P (SCM_CAR (list
), obj
))
588 return SCM_EQ_P (list
, obj
);
592 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
595 SCM x
= SCM_CDR (xorig
);
597 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
599 formals
= SCM_CAR (x
);
600 while (SCM_CONSP (formals
))
602 SCM formal
= SCM_CAR (formals
);
603 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
604 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
605 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
606 formals
= SCM_CDR (formals
);
608 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
609 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
611 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
612 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
616 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
617 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
619 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
620 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
622 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
625 SCM x
= SCM_CDR (xorig
);
629 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
631 bindings
= SCM_CAR (x
);
632 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
633 while (!SCM_NULLP (bindings
))
635 SCM binding
= SCM_CAR (bindings
);
636 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
637 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
638 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
639 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
640 bindings
= SCM_CDR (bindings
);
643 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
644 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
648 /* DO gets the most radically altered syntax. The order of the vars is
649 * reversed here. In contrast, the order of the inits and steps is reversed
650 * during the evaluation:
652 (do ((<var1> <init1> <step1>)
660 (#@do (varn ... var2 var1)
661 (<init1> <init2> ... <initn>)
664 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
667 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
668 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
671 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
674 SCM x
= SCM_CDR (xorig
);
677 SCM
*initloc
= &inits
;
679 SCM
*steploc
= &steps
;
680 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
681 bindings
= SCM_CAR (x
);
682 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
683 while (!SCM_NULLP (bindings
))
685 SCM binding
= SCM_CAR (bindings
);
686 long len
= scm_ilength (binding
);
687 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
689 SCM name
= SCM_CAR (binding
);
690 SCM init
= SCM_CADR (binding
);
691 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
692 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
693 vars
= scm_cons (name
, vars
);
694 *initloc
= scm_list_1 (init
);
695 initloc
= SCM_CDRLOC (*initloc
);
696 *steploc
= scm_list_1 (step
);
697 steploc
= SCM_CDRLOC (*steploc
);
698 bindings
= SCM_CDR (bindings
);
702 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
703 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
704 x
= scm_cons2 (vars
, inits
, x
);
705 return scm_cons (SCM_IM_DO
, x
);
709 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
710 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
712 /* Internal function to handle a quasiquotation: 'form' is the parameter in
713 * the call (quasiquotation form), 'env' is the environment where unquoted
714 * expressions will be evaluated, and 'depth' is the current quasiquotation
715 * nesting level and is known to be greater than zero. */
717 iqq (SCM form
, SCM env
, unsigned long int depth
)
719 if (SCM_CONSP (form
))
721 SCM tmp
= SCM_CAR (form
);
722 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
724 SCM args
= SCM_CDR (form
);
725 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
726 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
728 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
730 SCM args
= SCM_CDR (form
);
731 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
733 return scm_eval_car (args
, env
);
735 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
737 else if (SCM_CONSP (tmp
)
738 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
740 SCM args
= SCM_CDR (tmp
);
741 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
744 SCM list
= scm_eval_car (args
, env
);
745 SCM rest
= SCM_CDR (form
);
746 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
747 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
750 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
751 iqq (SCM_CDR (form
), env
, depth
));
754 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
755 iqq (SCM_CDR (form
), env
, depth
));
757 else if (SCM_VECTORP (form
))
759 size_t i
= SCM_VECTOR_LENGTH (form
);
760 SCM
const *const data
= SCM_VELTS (form
);
763 tmp
= scm_cons (data
[--i
], tmp
);
764 scm_remember_upto_here_1 (form
);
765 return scm_vector (iqq (tmp
, env
, depth
));
772 scm_m_quasiquote (SCM xorig
, SCM env
)
774 SCM x
= SCM_CDR (xorig
);
775 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
776 return iqq (SCM_CAR (x
), env
, 1);
780 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
781 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
783 /* Promises are implemented as closures with an empty parameter list. Thus,
784 * (delay <expression>) is transformed into (#@delay '() <expression>), where
785 * the empty list represents the empty parameter list. This representation
786 * allows for easy creation of the closure during evaluation. */
788 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
790 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
791 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
795 SCM_SYNTAX (s_gset_x
, "set!", scm_makmmacro
, scm_m_generalized_set_x
);
796 SCM_SYMBOL (scm_sym_setter
, "setter");
799 scm_m_generalized_set_x (SCM xorig
, SCM env SCM_UNUSED
)
801 SCM x
= SCM_CDR (xorig
);
802 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, s_set_x
);
803 if (SCM_SYMBOLP (SCM_CAR (x
)))
804 return scm_cons (SCM_IM_SET_X
, x
);
805 else if (SCM_CONSP (SCM_CAR (x
)))
806 return scm_cons (scm_list_2 (scm_sym_setter
, SCM_CAAR (x
)),
807 scm_append (scm_list_2 (SCM_CDAR (x
), SCM_CDR (x
))));
809 scm_misc_error (s_set_x
, scm_s_variable
, SCM_EOL
);
813 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
814 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
816 /* Like promises, futures are implemented as closures with an empty
817 * parameter list. Thus, (future <expression>) is transformed into
818 * (#@future '() <expression>), where the empty list represents the
819 * empty parameter list. This representation allows for easy creation
820 * of the closure during evaluation. */
822 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
824 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
825 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
829 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
830 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
832 /* Guile provides an extension to R5RS' define syntax to represent function
833 * currying in a compact way. With this extension, it is allowed to write
834 * (define <nested-variable> <body>), where <nested-variable> has of one of
835 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
836 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
837 * should be either a sequence of zero or more variables, or a sequence of one
838 * or more variables followed by a space-delimited period and another
839 * variable. Each level of argument nesting wraps the <body> within another
840 * lambda expression. For example, the following forms are allowed, each one
841 * followed by an equivalent, more explicit implementation.
843 * (define ((a b . c) . d) <body>) is equivalent to
844 * (define a (lambda (b . c) (lambda d <body>)))
846 * (define (((a) b) c . d) <body>) is equivalent to
847 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
849 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
850 * module that does not implement this extension. */
852 scm_m_define (SCM x
, SCM env
)
856 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
859 while (SCM_CONSP (name
))
861 /* This while loop realizes function currying by variable nesting. */
862 SCM formals
= SCM_CDR (name
);
863 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
864 name
= SCM_CAR (name
);
866 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
867 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
868 if (SCM_TOP_LEVEL (env
))
871 x
= scm_eval_car (x
, env
);
872 if (SCM_REC_PROCNAMES_P
)
875 while (SCM_MACROP (tmp
))
876 tmp
= SCM_MACRO_CODE (tmp
);
877 if (SCM_CLOSUREP (tmp
)
878 /* Only the first definition determines the name. */
879 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
880 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
882 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
883 SCM_VARIABLE_SET (var
, x
);
884 return SCM_UNSPECIFIED
;
887 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
891 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
892 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
893 * reversed here, the list of inits gets reversed during evaluation. */
895 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
901 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
905 SCM binding
= SCM_CAR (bindings
);
906 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
907 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
908 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
909 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
910 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
911 *initloc
= scm_list_1 (SCM_CADR (binding
));
912 initloc
= SCM_CDRLOC (*initloc
);
913 bindings
= SCM_CDR (bindings
);
915 while (!SCM_NULLP (bindings
));
921 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
922 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
925 scm_m_letrec (SCM xorig
, SCM env
)
927 SCM x
= SCM_CDR (xorig
);
928 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
930 if (SCM_NULLP (SCM_CAR (x
)))
932 /* null binding, let* faster */
933 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
934 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
938 SCM rvars
, inits
, body
;
939 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
940 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
941 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
946 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
947 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
950 scm_m_let (SCM xorig
, SCM env
)
952 SCM x
= SCM_CDR (xorig
);
955 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
958 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
960 /* null or single binding, let* is faster */
962 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
963 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
965 else if (SCM_CONSP (temp
))
969 SCM rvars
, inits
, body
;
970 transform_bindings (bindings
, &rvars
, &inits
, "let");
971 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
972 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
976 /* named let: Transform (let name ((var init) ...) body ...) into
977 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
983 SCM
*initloc
= &inits
;
986 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
988 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
989 bindings
= SCM_CAR (x
);
990 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
991 while (!SCM_NULLP (bindings
))
992 { /* vars and inits both in order */
993 SCM binding
= SCM_CAR (bindings
);
994 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
995 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
996 *varloc
= scm_list_1 (SCM_CAR (binding
));
997 varloc
= SCM_CDRLOC (*varloc
);
998 *initloc
= scm_list_1 (SCM_CADR (binding
));
999 initloc
= SCM_CDRLOC (*initloc
);
1000 bindings
= SCM_CDR (bindings
);
1004 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1005 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1006 SCM rvar
= scm_list_1 (name
);
1007 SCM init
= scm_list_1 (lambda_form
);
1008 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1009 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1010 return scm_cons (letrec
, inits
);
1016 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1017 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1018 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1021 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1023 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1024 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1028 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1029 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1033 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1035 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1036 scm_s_expression
, s_atcall_cc
);
1037 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1040 #if SCM_ENABLE_ELISP
1042 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1045 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1047 long len
= scm_ilength (SCM_CDR (xorig
));
1048 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1049 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1052 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1055 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1057 SCM x
= SCM_CDR (xorig
), var
;
1058 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1059 var
= scm_symbol_fref (SCM_CAR (x
));
1060 /* Passing the symbol name as the `subr' arg here isn't really
1061 right, but without it it can be very difficult to work out from
1062 the error message which function definition was missing. In any
1063 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1064 something equivalent to (signal void-function (list SYM)) in
1066 SCM_ASSYNT (SCM_VARIABLEP (var
),
1067 "Symbol's function definition is void",
1068 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1069 /* Support `defalias'. */
1070 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1072 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1073 SCM_ASSYNT (SCM_VARIABLEP (var
),
1074 "Symbol's function definition is void",
1075 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1077 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1078 former allows for automatically picking up redefinitions of the
1079 corresponding symbol. */
1080 SCM_SETCAR (x
, var
);
1081 /* If the variable contains a procedure, leave the
1082 `transformer-macro' in place so that the procedure's arguments
1083 get properly transformed, and change the initial @fop to
1085 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1087 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1090 /* Otherwise (the variable contains a macro), the arguments should
1091 not be transformed, so cut the `transformer-macro' out and return
1092 the resulting expression starting with the variable. */
1093 SCM_SETCDR (x
, SCM_CDADR (x
));
1097 #endif /* SCM_ENABLE_ELISP */
1099 /* (@bind ((var exp) ...) body ...)
1101 This will assign the values of the `exp's to the global variables
1102 named by `var's (symbols, not evaluated), creating them if they
1103 don't exist, executes body, and then restores the previous values of
1104 the `var's. Additionally, whenever control leaves body, the values
1105 of the `var's are saved and restored when control returns. It is an
1106 error when a symbol appears more than once among the `var's.
1107 All `exp's are evaluated before any `var' is set.
1109 Think of this as `let' for dynamic scope.
1111 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1113 XXX - also implement `@bind*'.
1116 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1119 scm_m_atbind (SCM xorig
, SCM env
)
1121 SCM x
= SCM_CDR (xorig
);
1122 SCM top_level
= scm_env_top_level (env
);
1123 SCM vars
= SCM_EOL
, var
;
1126 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1129 while (SCM_NIMP (x
))
1132 SCM sym_exp
= SCM_CAR (x
);
1133 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1134 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1136 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1137 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1138 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1139 /* The first call to scm_sym2var will look beyond the current
1140 module, while the second call wont. */
1141 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1142 if (SCM_FALSEP (var
))
1143 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1144 vars
= scm_cons (var
, vars
);
1145 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1147 return scm_cons (SCM_IM_BIND
,
1148 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1152 SCM_SYNTAX (s_atslot_ref
, "@slot-ref", scm_makmmacro
, scm_m_atslot_ref
);
1155 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1156 #define FUNC_NAME s_atslot_ref
1158 SCM x
= SCM_CDR (xorig
);
1159 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1160 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1161 return scm_cons (SCM_IM_SLOT_REF
, x
);
1166 SCM_SYNTAX (s_atslot_set_x
, "@slot-set!", scm_makmmacro
, scm_m_atslot_set_x
);
1169 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1170 #define FUNC_NAME s_atslot_set_x
1172 SCM x
= SCM_CDR (xorig
);
1173 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1174 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1175 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1180 SCM_SYNTAX (s_atdispatch
, "@dispatch", scm_makmmacro
, scm_m_atdispatch
);
1182 SCM_SYMBOL (sym_atdispatch
, s_atdispatch
);
1185 scm_m_atdispatch (SCM xorig
, SCM env
)
1186 #define FUNC_NAME s_atdispatch
1188 SCM args
, n
, v
, gf
, x
= SCM_CDR (xorig
);
1189 SCM_ASSYNT (scm_ilength (x
) == 4, scm_s_expression
, FUNC_NAME
);
1191 if (!SCM_CONSP (args
) && !SCM_SYMBOLP (args
))
1192 SCM_WRONG_TYPE_ARG (SCM_ARG1
, args
);
1194 n
= SCM_XEVALCAR (x
, env
);
1195 SCM_VALIDATE_INUM (SCM_ARG2
, n
);
1196 SCM_ASSERT_RANGE (0, n
, SCM_INUM (n
) >= 1);
1198 v
= SCM_XEVALCAR (x
, env
);
1199 SCM_VALIDATE_VECTOR (SCM_ARG3
, v
);
1201 gf
= SCM_XEVALCAR (x
, env
);
1202 SCM_VALIDATE_PUREGENERIC (SCM_ARG4
, gf
);
1203 return scm_list_5 (SCM_IM_DISPATCH
, args
, n
, v
, gf
);
1208 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1209 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1212 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1214 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1215 scm_s_expression
, s_at_call_with_values
);
1216 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1220 scm_m_expand_body (SCM xorig
, SCM env
)
1222 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1223 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1225 while (SCM_NIMP (x
))
1227 SCM form
= SCM_CAR (x
);
1228 if (!SCM_CONSP (form
))
1230 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1233 form
= scm_macroexp (scm_cons_source (form
,
1238 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1240 defs
= scm_cons (SCM_CDR (form
), defs
);
1243 else if (!SCM_IMP (defs
))
1247 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1249 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1253 x
= scm_cons (form
, SCM_CDR (x
));
1258 if (!SCM_NULLP (defs
))
1260 SCM rvars
, inits
, body
, letrec
;
1261 transform_bindings (defs
, &rvars
, &inits
, what
);
1262 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1263 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1264 SCM_SETCAR (xorig
, letrec
);
1265 SCM_SETCDR (xorig
, SCM_EOL
);
1269 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1270 SCM_SETCAR (xorig
, SCM_CAR (x
));
1271 SCM_SETCDR (xorig
, SCM_CDR (x
));
1278 scm_macroexp (SCM x
, SCM env
)
1280 SCM res
, proc
, orig_sym
;
1282 /* Don't bother to produce error messages here. We get them when we
1283 eventually execute the code for real. */
1286 orig_sym
= SCM_CAR (x
);
1287 if (!SCM_SYMBOLP (orig_sym
))
1291 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1292 if (proc_ptr
== NULL
)
1294 /* We have lost the race. */
1300 /* Only handle memoizing macros. `Acros' and `macros' are really
1301 special forms and should not be evaluated here. */
1303 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1306 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1307 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1309 if (scm_ilength (res
) <= 0)
1310 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1313 SCM_SETCAR (x
, SCM_CAR (res
));
1314 SCM_SETCDR (x
, SCM_CDR (res
));
1320 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1322 /* A function object to implement "apply" for non-closure functions. */
1324 /* An endless list consisting of #<undefined> objects: */
1325 static SCM undefineds
;
1327 /* scm_unmemocopy takes a memoized expression together with its
1328 * environment and rewrites it to its original form. Thus, it is the
1329 * inversion of the rewrite rules above. The procedure is not
1330 * optimized for speed. It's used in scm_iprin1 when printing the
1331 * code of a closure, in scm_procedure_source, in display_frame when
1332 * generating the source for a stackframe in a backtrace, and in
1333 * display_expression.
1335 * Unmemoizing is not a reliable process. You cannot in general
1336 * expect to get the original source back.
1338 * However, GOOPS currently relies on this for method compilation.
1339 * This ought to change.
1343 build_binding_list (SCM names
, SCM inits
)
1345 SCM bindings
= SCM_EOL
;
1346 while (!SCM_NULLP (names
))
1348 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1349 bindings
= scm_cons (binding
, bindings
);
1350 names
= SCM_CDR (names
);
1351 inits
= SCM_CDR (inits
);
1357 unmemocopy (SCM x
, SCM env
)
1363 p
= scm_whash_lookup (scm_source_whash
, x
);
1364 switch (SCM_ITAG7 (SCM_CAR (x
)))
1366 case SCM_BIT7 (SCM_IM_AND
):
1367 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1369 case SCM_BIT7 (SCM_IM_BEGIN
):
1370 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1372 case SCM_BIT7 (SCM_IM_CASE
):
1373 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1375 case SCM_BIT7 (SCM_IM_COND
):
1376 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1378 case SCM_BIT7 (SCM_IM_DO
):
1380 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1381 * where nx is the name of a local variable, ix is an initializer for
1382 * the local variable, test is the test clause of the do loop, body is
1383 * the body of the do loop and sx are the step clauses for the local
1385 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1388 names
= SCM_CAR (x
);
1390 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1391 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1393 test
= unmemocopy (SCM_CAR (x
), env
);
1395 memoized_body
= SCM_CAR (x
);
1397 steps
= scm_reverse (unmemocopy (x
, env
));
1399 /* build transformed binding list */
1401 while (!SCM_NULLP (names
))
1403 SCM name
= SCM_CAR (names
);
1404 SCM init
= SCM_CAR (inits
);
1405 SCM step
= SCM_CAR (steps
);
1406 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1408 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1410 names
= SCM_CDR (names
);
1411 inits
= SCM_CDR (inits
);
1412 steps
= SCM_CDR (steps
);
1414 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1415 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1417 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1420 case SCM_BIT7 (SCM_IM_IF
):
1421 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1423 case SCM_BIT7 (SCM_IM_LET
):
1425 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1426 * where nx is the name of a local variable, ix is an initializer for
1427 * the local variable and by are the body clauses. */
1428 SCM names
, inits
, bindings
;
1431 names
= SCM_CAR (x
);
1433 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1434 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1436 bindings
= build_binding_list (names
, inits
);
1437 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1438 ls
= scm_cons (scm_sym_let
, z
);
1441 case SCM_BIT7 (SCM_IM_LETREC
):
1443 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1444 * where nx is the name of a local variable, ix is an initializer for
1445 * the local variable and by are the body clauses. */
1446 SCM names
, inits
, bindings
;
1449 names
= SCM_CAR (x
);
1450 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1452 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1454 bindings
= build_binding_list (names
, inits
);
1455 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1456 ls
= scm_cons (scm_sym_letrec
, z
);
1459 case SCM_BIT7 (SCM_IM_LETSTAR
):
1467 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1470 y
= z
= scm_acons (SCM_CAR (b
),
1472 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1474 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1478 SCM_SETCDR (y
, SCM_EOL
);
1479 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1480 ls
= scm_cons (scm_sym_let
, z
);
1485 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1487 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1490 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1493 while (SCM_NIMP (b
));
1494 SCM_SETCDR (z
, SCM_EOL
);
1496 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1497 ls
= scm_cons (scm_sym_letstar
, z
);
1500 case SCM_BIT7 (SCM_IM_OR
):
1501 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1503 case SCM_BIT7 (SCM_IM_LAMBDA
):
1505 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1506 ls
= scm_cons (scm_sym_lambda
, z
);
1507 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1509 case SCM_BIT7 (SCM_IM_QUOTE
):
1510 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1512 case SCM_BIT7 (SCM_IM_SET_X
):
1513 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1515 case SCM_BIT7 (SCM_IM_DEFINE
):
1520 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1521 ls
= scm_cons (scm_sym_define
, z
);
1522 if (!SCM_NULLP (env
))
1523 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1528 case SCM_BIT7 (SCM_MAKISYM (0)):
1532 switch (SCM_ISYMNUM (z
))
1534 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1535 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1537 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1538 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1540 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1541 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1544 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1545 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1548 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1549 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1552 /* appease the Sun compiler god: */ ;
1556 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1562 while (SCM_CONSP (x
))
1564 SCM form
= SCM_CAR (x
);
1565 if (!SCM_ISYMP (form
))
1567 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1568 SCM_SETCDR (z
, unmemocar (copy
, env
));
1574 if (!SCM_FALSEP (p
))
1575 scm_whash_insert (scm_source_whash
, ls
, p
);
1581 scm_unmemocopy (SCM x
, SCM env
)
1583 if (!SCM_NULLP (env
))
1584 /* Make a copy of the lowest frame to protect it from
1585 modifications by SCM_IM_DEFINE */
1586 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1588 return unmemocopy (x
, env
);
1593 scm_badargsp (SCM formals
, SCM args
)
1595 while (!SCM_NULLP (formals
))
1597 if (!SCM_CONSP (formals
))
1599 if (SCM_NULLP (args
))
1601 formals
= SCM_CDR (formals
);
1602 args
= SCM_CDR (args
);
1604 return !SCM_NULLP (args
) ? 1 : 0;
1609 scm_badformalsp (SCM closure
, int n
)
1611 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1612 while (!SCM_NULLP (formals
))
1614 if (!SCM_CONSP (formals
))
1619 formals
= SCM_CDR (formals
);
1626 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1628 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1629 while (SCM_CONSP (l
))
1631 res
= EVALCAR (l
, env
);
1633 *lloc
= scm_list_1 (res
);
1634 lloc
= SCM_CDRLOC (*lloc
);
1638 scm_wrong_num_args (proc
);
1644 scm_eval_body (SCM code
, SCM env
)
1648 next
= SCM_CDR (code
);
1649 while (!SCM_NULLP (next
))
1651 if (SCM_IMP (SCM_CAR (code
)))
1653 if (SCM_ISYMP (SCM_CAR (code
)))
1655 scm_rec_mutex_lock (&source_mutex
);
1656 /* check for race condition */
1657 if (SCM_ISYMP (SCM_CAR (code
)))
1658 code
= scm_m_expand_body (code
, env
);
1659 scm_rec_mutex_unlock (&source_mutex
);
1664 SCM_XEVAL (SCM_CAR (code
), env
);
1666 next
= SCM_CDR (code
);
1668 return SCM_XEVALCAR (code
, env
);
1674 /* SECTION: This code is specific for the debugging support. One
1675 * branch is read when DEVAL isn't defined, the other when DEVAL is
1681 #define SCM_APPLY scm_apply
1682 #define PREP_APPLY(proc, args)
1684 #define RETURN(x) do { return x; } while (0)
1685 #ifdef STACK_CHECKING
1686 #ifndef NO_CEVAL_STACK_CHECKING
1687 #define EVAL_STACK_CHECKING
1694 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1696 #define SCM_APPLY scm_dapply
1698 #define PREP_APPLY(p, l) \
1699 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1701 #define ENTER_APPLY \
1703 SCM_SET_ARGSREADY (debug);\
1704 if (scm_check_apply_p && SCM_TRAPS_P)\
1705 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1707 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1708 SCM_SET_TRACED_FRAME (debug); \
1710 if (SCM_CHEAPTRAPS_P)\
1712 tmp = scm_make_debugobj (&debug);\
1713 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1718 tmp = scm_make_continuation (&first);\
1720 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1726 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1727 #ifdef STACK_CHECKING
1728 #ifndef EVAL_STACK_CHECKING
1729 #define EVAL_STACK_CHECKING
1733 /* scm_ceval_ptr points to the currently selected evaluator.
1734 * *fixme*: Although efficiency is important here, this state variable
1735 * should probably not be a global. It should be related to the
1740 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1742 /* scm_last_debug_frame contains a pointer to the last debugging
1743 * information stack frame. It is accessed very often from the
1744 * debugging evaluator, so it should probably not be indirectly
1745 * addressed. Better to save and restore it from the current root at
1749 /* scm_debug_eframe_size is the number of slots available for pseudo
1750 * stack frames at each real stack frame.
1753 long scm_debug_eframe_size
;
1755 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1757 long scm_eval_stack
;
1759 scm_t_option scm_eval_opts
[] = {
1760 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1763 scm_t_option scm_debug_opts
[] = {
1764 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1765 "*Flyweight representation of the stack at traps." },
1766 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1767 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1768 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1769 "Record procedure names at definition." },
1770 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1771 "Display backtrace in anti-chronological order." },
1772 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1773 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1774 { SCM_OPTION_INTEGER
, "frames", 3,
1775 "Maximum number of tail-recursive frames in backtrace." },
1776 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1777 "Maximal number of stored backtrace frames." },
1778 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1779 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1780 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1781 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1782 { 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."}
1785 scm_t_option scm_evaluator_trap_table
[] = {
1786 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1787 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1788 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1789 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1790 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1791 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1792 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1795 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1797 "Option interface for the evaluation options. Instead of using\n"
1798 "this procedure directly, use the procedures @code{eval-enable},\n"
1799 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1800 #define FUNC_NAME s_scm_eval_options_interface
1804 ans
= scm_options (setting
,
1808 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1815 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1817 "Option interface for the evaluator trap options.")
1818 #define FUNC_NAME s_scm_evaluator_traps
1822 ans
= scm_options (setting
,
1823 scm_evaluator_trap_table
,
1824 SCM_N_EVALUATOR_TRAPS
,
1826 SCM_RESET_DEBUG_MODE
;
1834 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1836 SCM
*results
= lloc
, res
;
1837 while (SCM_CONSP (l
))
1839 res
= EVALCAR (l
, env
);
1841 *lloc
= scm_list_1 (res
);
1842 lloc
= SCM_CDRLOC (*lloc
);
1846 scm_wrong_num_args (proc
);
1853 /* SECTION: This code is compiled twice.
1857 /* Update the toplevel environment frame ENV so that it refers to the
1858 * current module. */
1859 #define UPDATE_TOPLEVEL_ENV(env) \
1861 SCM p = scm_current_module_lookup_closure (); \
1862 if (p != SCM_CAR (env)) \
1863 env = scm_top_level_env (p); \
1867 /* This is the evaluator. Like any real monster, it has three heads:
1869 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1870 * version. Both are implemented using a common code base, using the
1871 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1872 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1873 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1874 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1875 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1876 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1877 * are enclosed within #ifdef DEVAL ... #endif.
1879 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1880 * take two input parameters, x and env: x is a single expression to be
1881 * evalutated. env is the environment in which bindings are searched.
1883 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1884 * is a single expression, it is necessarily in a tail position. If x is just
1885 * a call to another function like in the expression (foo exp1 exp2 ...), the
1886 * realization of that call therefore _must_not_ increase stack usage (the
1887 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1888 * making extensive use of 'goto' statements within the evaluator: The gotos
1889 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1890 * that SCM_CEVAL was already using. If, however, x represents some form that
1891 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1892 * then recursive calls to SCM_CEVAL are performed for all but the last
1893 * expression of that sequence. */
1897 scm_ceval (SCM x
, SCM env
)
1903 scm_deval (SCM x
, SCM env
)
1908 SCM_CEVAL (SCM x
, SCM env
)
1912 scm_t_debug_frame debug
;
1913 scm_t_debug_info
*debug_info_end
;
1914 debug
.prev
= scm_last_debug_frame
;
1917 * The debug.vect contains twice as much scm_t_debug_info frames as the
1918 * user has specified with (debug-set! frames <n>).
1920 * Even frames are eval frames, odd frames are apply frames.
1922 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1923 * sizeof (scm_t_debug_info
));
1924 debug
.info
= debug
.vect
;
1925 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1926 scm_last_debug_frame
= &debug
;
1928 #ifdef EVAL_STACK_CHECKING
1929 if (scm_stack_checking_enabled_p
1930 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1933 debug
.info
->e
.exp
= x
;
1934 debug
.info
->e
.env
= env
;
1936 scm_report_stack_overflow ();
1946 SCM_CLEAR_ARGSREADY (debug
);
1947 if (SCM_OVERFLOWP (debug
))
1950 * In theory, this should be the only place where it is necessary to
1951 * check for space in debug.vect since both eval frames and
1952 * available space are even.
1954 * For this to be the case, however, it is necessary that primitive
1955 * special forms which jump back to `loop', `begin' or some similar
1956 * label call PREP_APPLY.
1958 else if (++debug
.info
>= debug_info_end
)
1960 SCM_SET_OVERFLOW (debug
);
1965 debug
.info
->e
.exp
= x
;
1966 debug
.info
->e
.env
= env
;
1967 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1969 if (SCM_ENTER_FRAME_P
1970 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1973 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1974 SCM_SET_TAILREC (debug
);
1975 if (SCM_CHEAPTRAPS_P
)
1976 stackrep
= scm_make_debugobj (&debug
);
1980 SCM val
= scm_make_continuation (&first
);
1990 /* This gives the possibility for the debugger to
1991 modify the source expression before evaluation. */
1996 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1997 scm_sym_enter_frame
,
2000 scm_unmemocopy (x
, env
));
2007 switch (SCM_TYP7 (x
))
2009 case scm_tc7_symbol
:
2010 /* Only happens when called at top level. */
2011 x
= scm_cons (x
, SCM_UNDEFINED
);
2012 RETURN (*scm_lookupcar (x
, env
, 1));
2014 case SCM_BIT7 (SCM_IM_AND
):
2016 while (!SCM_NULLP (SCM_CDR (x
)))
2018 SCM test_result
= EVALCAR (x
, env
);
2019 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2020 RETURN (SCM_BOOL_F
);
2024 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2027 case SCM_BIT7 (SCM_IM_BEGIN
):
2030 RETURN (SCM_UNSPECIFIED
);
2032 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2035 /* If we are on toplevel with a lookup closure, we need to sync
2036 with the current module. */
2037 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2039 UPDATE_TOPLEVEL_ENV (env
);
2040 while (!SCM_NULLP (SCM_CDR (x
)))
2043 UPDATE_TOPLEVEL_ENV (env
);
2049 goto nontoplevel_begin
;
2052 while (!SCM_NULLP (SCM_CDR (x
)))
2054 SCM form
= SCM_CAR (x
);
2057 if (SCM_ISYMP (form
))
2059 scm_rec_mutex_lock (&source_mutex
);
2060 /* check for race condition */
2061 if (SCM_ISYMP (SCM_CAR (x
)))
2062 x
= scm_m_expand_body (x
, env
);
2063 scm_rec_mutex_unlock (&source_mutex
);
2064 goto nontoplevel_begin
;
2067 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2070 SCM_CEVAL (form
, env
);
2076 /* scm_eval last form in list */
2077 SCM last_form
= SCM_CAR (x
);
2079 if (SCM_CONSP (last_form
))
2081 /* This is by far the most frequent case. */
2083 goto loop
; /* tail recurse */
2085 else if (SCM_IMP (last_form
))
2086 RETURN (SCM_EVALIM (last_form
, env
));
2087 else if (SCM_VARIABLEP (last_form
))
2088 RETURN (SCM_VARIABLE_REF (last_form
));
2089 else if (SCM_SYMBOLP (last_form
))
2090 RETURN (*scm_lookupcar (x
, env
, 1));
2096 case SCM_BIT7 (SCM_IM_CASE
):
2099 SCM key
= EVALCAR (x
, env
);
2101 while (!SCM_NULLP (x
))
2103 SCM clause
= SCM_CAR (x
);
2104 SCM labels
= SCM_CAR (clause
);
2105 if (SCM_EQ_P (labels
, scm_sym_else
))
2107 x
= SCM_CDR (clause
);
2108 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2111 while (!SCM_NULLP (labels
))
2113 SCM label
= SCM_CAR (labels
);
2114 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2116 x
= SCM_CDR (clause
);
2117 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2120 labels
= SCM_CDR (labels
);
2125 RETURN (SCM_UNSPECIFIED
);
2128 case SCM_BIT7 (SCM_IM_COND
):
2130 while (!SCM_NULLP (x
))
2132 SCM clause
= SCM_CAR (x
);
2133 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2135 x
= SCM_CDR (clause
);
2136 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2141 arg1
= EVALCAR (clause
, env
);
2142 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2144 x
= SCM_CDR (clause
);
2147 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2149 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2155 proc
= EVALCAR (proc
, env
);
2156 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2157 PREP_APPLY (proc
, scm_list_1 (arg1
));
2159 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2160 goto umwrongnumargs
;
2168 RETURN (SCM_UNSPECIFIED
);
2171 case SCM_BIT7 (SCM_IM_DO
):
2174 /* Compute the initialization values and the initial environment. */
2175 SCM init_forms
= SCM_CADR (x
);
2176 SCM init_values
= SCM_EOL
;
2177 while (!SCM_NULLP (init_forms
))
2179 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2180 init_forms
= SCM_CDR (init_forms
);
2182 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2186 SCM test_form
= SCM_CAR (x
);
2187 SCM body_forms
= SCM_CADR (x
);
2188 SCM step_forms
= SCM_CDDR (x
);
2190 SCM test_result
= EVALCAR (test_form
, env
);
2192 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2195 /* Evaluate body forms. */
2197 for (temp_forms
= body_forms
;
2198 !SCM_NULLP (temp_forms
);
2199 temp_forms
= SCM_CDR (temp_forms
))
2201 SCM form
= SCM_CAR (temp_forms
);
2202 /* Dirk:FIXME: We only need to eval forms, that may have a
2203 * side effect here. This is only true for forms that start
2204 * with a pair. All others are just constants. However,
2205 * since in the common case there is no constant expression
2206 * in a body of a do form, we just check for immediates here
2207 * and have SCM_CEVAL take care of other cases. In the long
2208 * run it would make sense to get rid of this test and have
2209 * the macro transformer of 'do' eliminate all forms that
2210 * have no sideeffect. */
2211 if (!SCM_IMP (form
))
2212 SCM_CEVAL (form
, env
);
2217 /* Evaluate the step expressions. */
2219 SCM step_values
= SCM_EOL
;
2220 for (temp_forms
= step_forms
;
2221 !SCM_NULLP (temp_forms
);
2222 temp_forms
= SCM_CDR (temp_forms
))
2224 SCM value
= EVALCAR (temp_forms
, env
);
2225 step_values
= scm_cons (value
, step_values
);
2227 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2232 test_result
= EVALCAR (test_form
, env
);
2237 RETURN (SCM_UNSPECIFIED
);
2238 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2239 goto nontoplevel_begin
;
2242 case SCM_BIT7 (SCM_IM_IF
):
2245 SCM test_result
= EVALCAR (x
, env
);
2246 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2252 RETURN (SCM_UNSPECIFIED
);
2255 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2259 case SCM_BIT7 (SCM_IM_LET
):
2262 SCM init_forms
= SCM_CADR (x
);
2263 SCM init_values
= SCM_EOL
;
2266 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2267 init_forms
= SCM_CDR (init_forms
);
2269 while (!SCM_NULLP (init_forms
));
2270 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2273 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2274 goto nontoplevel_begin
;
2277 case SCM_BIT7 (SCM_IM_LETREC
):
2279 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2282 SCM init_forms
= SCM_CAR (x
);
2283 SCM init_values
= SCM_EOL
;
2286 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2287 init_forms
= SCM_CDR (init_forms
);
2289 while (!SCM_NULLP (init_forms
));
2290 SCM_SETCDR (SCM_CAR (env
), init_values
);
2293 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2294 goto nontoplevel_begin
;
2297 case SCM_BIT7 (SCM_IM_LETSTAR
):
2300 SCM bindings
= SCM_CAR (x
);
2301 if (SCM_NULLP (bindings
))
2302 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2307 SCM name
= SCM_CAR (bindings
);
2308 SCM init
= SCM_CDR (bindings
);
2309 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2310 bindings
= SCM_CDR (init
);
2312 while (!SCM_NULLP (bindings
));
2316 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2317 goto nontoplevel_begin
;
2320 case SCM_BIT7 (SCM_IM_OR
):
2322 while (!SCM_NULLP (SCM_CDR (x
)))
2324 SCM val
= EVALCAR (x
, env
);
2325 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2330 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2334 case SCM_BIT7 (SCM_IM_LAMBDA
):
2335 RETURN (scm_closure (SCM_CDR (x
), env
));
2338 case SCM_BIT7 (SCM_IM_QUOTE
):
2339 RETURN (SCM_CADR (x
));
2342 case SCM_BIT7 (SCM_IM_SET_X
):
2346 SCM variable
= SCM_CAR (x
);
2347 if (SCM_ILOCP (variable
))
2348 location
= scm_ilookup (variable
, env
);
2349 else if (SCM_VARIABLEP (variable
))
2350 location
= SCM_VARIABLE_LOC (variable
);
2351 else /* (SCM_SYMBOLP (variable)) is known to be true */
2352 location
= scm_lookupcar (x
, env
, 1);
2354 *location
= EVALCAR (x
, env
);
2356 RETURN (SCM_UNSPECIFIED
);
2359 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2360 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2363 /* new syntactic forms go here. */
2364 case SCM_BIT7 (SCM_MAKISYM (0)):
2366 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2367 switch (SCM_ISYMNUM (proc
))
2371 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2373 proc
= EVALCAR (proc
, env
);
2374 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2375 if (SCM_CLOSUREP (proc
))
2377 PREP_APPLY (proc
, SCM_EOL
);
2378 arg1
= SCM_CDDR (x
);
2379 arg1
= EVALCAR (arg1
, env
);
2381 /* Go here to tail-call a closure. PROC is the closure
2382 and ARG1 is the list of arguments. Do not forget to
2385 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2387 debug
.info
->a
.args
= arg1
;
2389 if (scm_badargsp (formals
, arg1
))
2390 scm_wrong_num_args (proc
);
2392 /* Copy argument list */
2393 if (SCM_NULL_OR_NIL_P (arg1
))
2394 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2397 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2399 arg1
= SCM_CDR (arg1
);
2400 while (!SCM_NULL_OR_NIL_P (arg1
))
2402 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2403 SCM_SETCDR (tail
, new_tail
);
2405 arg1
= SCM_CDR (arg1
);
2407 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2410 x
= SCM_CLOSURE_BODY (proc
);
2411 goto nontoplevel_begin
;
2421 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2424 SCM val
= scm_make_continuation (&first
);
2432 proc
= scm_eval_car (proc
, env
);
2433 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2434 PREP_APPLY (proc
, scm_list_1 (arg1
));
2436 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2437 goto umwrongnumargs
;
2443 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2444 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2447 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2448 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2451 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2453 /* If not done yet, evaluate the operand forms. The result is a
2454 * list of arguments stored in arg1, which is used to perform the
2455 * function dispatch. */
2456 SCM operand_forms
= SCM_CADR (x
);
2457 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2458 if (SCM_ILOCP (operand_forms
))
2459 arg1
= *scm_ilookup (operand_forms
, env
);
2460 else if (SCM_VARIABLEP (operand_forms
))
2461 arg1
= SCM_VARIABLE_REF (operand_forms
);
2462 else if (!SCM_CONSP (operand_forms
))
2463 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2466 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2467 operand_forms
= SCM_CDR (operand_forms
);
2468 while (!SCM_NULLP (operand_forms
))
2470 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2471 SCM_SETCDR (tail
, new_tail
);
2473 operand_forms
= SCM_CDR (operand_forms
);
2478 /* The type dispatch code is duplicated below
2479 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2480 * cuts down execution time for type dispatch to 50%. */
2481 type_dispatch
: /* inputs: x, arg1 */
2482 /* Type dispatch means to determine from the types of the function
2483 * arguments (i. e. the 'signature' of the call), which method from
2484 * a generic function is to be called. This process of selecting
2485 * the right method takes some time. To speed it up, guile uses
2486 * caching: Together with the macro call to dispatch the signatures
2487 * of some previous calls to that generic function from the same
2488 * place are stored (in the code!) in a cache that we call the
2489 * 'method cache'. This is done since it is likely, that
2490 * consecutive calls to dispatch from that position in the code will
2491 * have the same signature. Thus, the type dispatch works as
2492 * follows: First, determine a hash value from the signature of the
2493 * actual arguments. Second, use this hash value as an index to
2494 * find that same signature in the method cache stored at this
2495 * position in the code. If found, you have also found the
2496 * corresponding method that belongs to that signature. If the
2497 * signature is not found in the method cache, you have to perform a
2498 * full search over all signatures stored with the generic
2501 unsigned long int specializers
;
2502 unsigned long int hash_value
;
2503 unsigned long int cache_end_pos
;
2504 unsigned long int mask
;
2508 SCM z
= SCM_CDDR (x
);
2509 SCM tmp
= SCM_CADR (z
);
2510 specializers
= SCM_INUM (SCM_CAR (z
));
2512 /* Compute a hash value for searching the method cache. There
2513 * are two variants for computing the hash value, a (rather)
2514 * complicated one, and a simple one. For the complicated one
2515 * explained below, tmp holds a number that is used in the
2517 if (SCM_INUMP (tmp
))
2519 /* Use the signature of the actual arguments to determine
2520 * the hash value. This is done as follows: Each class has
2521 * an array of random numbers, that are determined when the
2522 * class is created. The integer 'hashset' is an index into
2523 * that array of random numbers. Now, from all classes that
2524 * are part of the signature of the actual arguments, the
2525 * random numbers at index 'hashset' are taken and summed
2526 * up, giving the hash value. The value of 'hashset' is
2527 * stored at the call to dispatch. This allows to have
2528 * different 'formulas' for calculating the hash value at
2529 * different places where dispatch is called. This allows
2530 * to optimize the hash formula at every individual place
2531 * where dispatch is called, such that hopefully the hash
2532 * value that is computed will directly point to the right
2533 * method in the method cache. */
2534 unsigned long int hashset
= SCM_INUM (tmp
);
2535 unsigned long int counter
= specializers
+ 1;
2538 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2540 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2541 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2542 tmp_arg
= SCM_CDR (tmp_arg
);
2546 method_cache
= SCM_CADR (z
);
2547 mask
= SCM_INUM (SCM_CAR (z
));
2549 cache_end_pos
= hash_value
;
2553 /* This method of determining the hash value is much
2554 * simpler: Set the hash value to zero and just perform a
2555 * linear search through the method cache. */
2557 mask
= (unsigned long int) ((long) -1);
2559 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2564 /* Search the method cache for a method with a matching
2565 * signature. Start the search at position 'hash_value'. The
2566 * hashing implementation uses linear probing for conflict
2567 * resolution, that is, if the signature in question is not
2568 * found at the starting index in the hash table, the next table
2569 * entry is tried, and so on, until in the worst case the whole
2570 * cache has been searched, but still the signature has not been
2575 SCM args
= arg1
; /* list of arguments */
2576 z
= SCM_VELTS (method_cache
)[hash_value
];
2577 while (!SCM_NULLP (args
))
2579 /* More arguments than specifiers => CLASS != ENV */
2580 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2581 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2583 args
= SCM_CDR (args
);
2586 /* Fewer arguments than specifiers => CAR != ENV */
2587 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2590 hash_value
= (hash_value
+ 1) & mask
;
2591 } while (hash_value
!= cache_end_pos
);
2593 /* No appropriate method was found in the cache. */
2594 z
= scm_memoize_method (x
, arg1
);
2596 apply_cmethod
: /* inputs: z, arg1 */
2598 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2599 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2600 x
= SCM_CMETHOD_BODY (z
);
2601 goto nontoplevel_begin
;
2607 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2610 SCM instance
= EVALCAR (x
, env
);
2611 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2612 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2616 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2619 SCM instance
= EVALCAR (x
, env
);
2620 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2621 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2622 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2623 RETURN (SCM_UNSPECIFIED
);
2627 #if SCM_ENABLE_ELISP
2629 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2631 SCM test_form
= SCM_CDR (x
);
2632 x
= SCM_CDR (test_form
);
2633 while (!SCM_NULL_OR_NIL_P (x
))
2635 SCM test_result
= EVALCAR (test_form
, env
);
2636 if (!(SCM_FALSEP (test_result
)
2637 || SCM_NULL_OR_NIL_P (test_result
)))
2639 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2640 RETURN (test_result
);
2641 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2646 test_form
= SCM_CDR (x
);
2647 x
= SCM_CDR (test_form
);
2651 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2655 #endif /* SCM_ENABLE_ELISP */
2657 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2659 SCM vars
, exps
, vals
;
2662 vars
= SCM_CAAR (x
);
2663 exps
= SCM_CDAR (x
);
2667 while (SCM_NIMP (exps
))
2669 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2670 exps
= SCM_CDR (exps
);
2673 scm_swap_bindings (vars
, vals
);
2674 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2676 /* Ignore all but the last evaluation result. */
2677 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2679 if (SCM_CONSP (SCM_CAR (x
)))
2680 SCM_CEVAL (SCM_CAR (x
), env
);
2682 proc
= EVALCAR (x
, env
);
2684 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2685 scm_swap_bindings (vars
, vals
);
2691 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2694 x
= EVALCAR (proc
, env
);
2695 proc
= SCM_CDR (proc
);
2696 proc
= EVALCAR (proc
, env
);
2697 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2698 if (SCM_VALUESP (arg1
))
2699 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2701 arg1
= scm_list_1 (arg1
);
2702 if (SCM_CLOSUREP (proc
))
2704 PREP_APPLY (proc
, arg1
);
2707 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2718 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2719 case scm_tc7_vector
:
2723 case scm_tc7_byvect
:
2730 #if SCM_SIZEOF_LONG_LONG != 0
2731 case scm_tc7_llvect
:
2734 case scm_tc7_string
:
2736 case scm_tcs_closures
:
2740 case scm_tcs_struct
:
2743 case scm_tc7_variable
:
2744 RETURN (SCM_VARIABLE_REF(x
));
2746 case SCM_BIT7 (SCM_ILOC00
):
2747 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2748 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2751 case scm_tcs_cons_nimcar
:
2752 if (SCM_SYMBOLP (SCM_CAR (x
)))
2754 SCM orig_sym
= SCM_CAR (x
);
2756 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2757 if (location
== NULL
)
2759 /* we have lost the race, start again. */
2767 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2771 if (SCM_MACROP (proc
))
2773 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2775 handle_a_macro
: /* inputs: x, env, proc */
2777 /* Set a flag during macro expansion so that macro
2778 application frames can be deleted from the backtrace. */
2779 SCM_SET_MACROEXP (debug
);
2781 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2782 scm_cons (env
, scm_listofnull
));
2785 SCM_CLEAR_MACROEXP (debug
);
2787 switch (SCM_MACRO_TYPE (proc
))
2790 if (scm_ilength (arg1
) <= 0)
2791 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2793 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2796 SCM_SETCAR (x
, SCM_CAR (arg1
));
2797 SCM_SETCDR (x
, SCM_CDR (arg1
));
2801 /* Prevent memoizing of debug info expression. */
2802 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2807 SCM_SETCAR (x
, SCM_CAR (arg1
));
2808 SCM_SETCDR (x
, SCM_CDR (arg1
));
2810 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2812 #if SCM_ENABLE_DEPRECATED == 1
2817 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2829 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2830 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2833 if (SCM_CLOSUREP (proc
))
2835 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2836 SCM args
= SCM_CDR (x
);
2837 while (!SCM_NULLP (formals
))
2839 if (!SCM_CONSP (formals
))
2842 goto umwrongnumargs
;
2843 formals
= SCM_CDR (formals
);
2844 args
= SCM_CDR (args
);
2846 if (!SCM_NULLP (args
))
2847 goto umwrongnumargs
;
2849 else if (SCM_MACROP (proc
))
2850 goto handle_a_macro
;
2854 evapply
: /* inputs: x, proc */
2855 PREP_APPLY (proc
, SCM_EOL
);
2856 if (SCM_NULLP (SCM_CDR (x
))) {
2859 switch (SCM_TYP7 (proc
))
2860 { /* no arguments given */
2861 case scm_tc7_subr_0
:
2862 RETURN (SCM_SUBRF (proc
) ());
2863 case scm_tc7_subr_1o
:
2864 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2866 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2867 case scm_tc7_rpsubr
:
2868 RETURN (SCM_BOOL_T
);
2870 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2872 if (!SCM_SMOB_APPLICABLE_P (proc
))
2874 RETURN (SCM_SMOB_APPLY_0 (proc
));
2877 proc
= SCM_CCLO_SUBR (proc
);
2879 debug
.info
->a
.proc
= proc
;
2880 debug
.info
->a
.args
= scm_list_1 (arg1
);
2884 proc
= SCM_PROCEDURE (proc
);
2886 debug
.info
->a
.proc
= proc
;
2888 if (!SCM_CLOSUREP (proc
))
2890 if (scm_badformalsp (proc
, 0))
2891 goto umwrongnumargs
;
2892 case scm_tcs_closures
:
2893 x
= SCM_CLOSURE_BODY (proc
);
2894 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2897 goto nontoplevel_begin
;
2898 case scm_tcs_struct
:
2899 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2901 x
= SCM_ENTITY_PROCEDURE (proc
);
2905 else if (!SCM_I_OPERATORP (proc
))
2910 proc
= (SCM_I_ENTITYP (proc
)
2911 ? SCM_ENTITY_PROCEDURE (proc
)
2912 : SCM_OPERATOR_PROCEDURE (proc
));
2914 debug
.info
->a
.proc
= proc
;
2915 debug
.info
->a
.args
= scm_list_1 (arg1
);
2917 if (SCM_NIMP (proc
))
2922 case scm_tc7_subr_1
:
2923 case scm_tc7_subr_2
:
2924 case scm_tc7_subr_2o
:
2926 case scm_tc7_subr_3
:
2927 case scm_tc7_lsubr_2
:
2930 scm_wrong_num_args (proc
);
2932 /* handle macros here */
2937 /* must handle macros by here */
2940 arg1
= EVALCAR (x
, env
);
2942 scm_wrong_num_args (proc
);
2944 debug
.info
->a
.args
= scm_list_1 (arg1
);
2952 evap1
: /* inputs: proc, arg1 */
2953 switch (SCM_TYP7 (proc
))
2954 { /* have one argument in arg1 */
2955 case scm_tc7_subr_2o
:
2956 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2957 case scm_tc7_subr_1
:
2958 case scm_tc7_subr_1o
:
2959 RETURN (SCM_SUBRF (proc
) (arg1
));
2961 if (SCM_SUBRF (proc
))
2963 if (SCM_INUMP (arg1
))
2965 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2967 else if (SCM_REALP (arg1
))
2969 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2971 else if (SCM_BIGP (arg1
))
2973 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2975 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2976 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2978 proc
= SCM_SNAME (proc
);
2980 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2981 while ('c' != *--chrs
)
2983 SCM_ASSERT (SCM_CONSP (arg1
),
2984 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2985 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2989 case scm_tc7_rpsubr
:
2990 RETURN (SCM_BOOL_T
);
2992 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2995 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2997 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3000 if (!SCM_SMOB_APPLICABLE_P (proc
))
3002 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3006 proc
= SCM_CCLO_SUBR (proc
);
3008 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3009 debug
.info
->a
.proc
= proc
;
3013 proc
= SCM_PROCEDURE (proc
);
3015 debug
.info
->a
.proc
= proc
;
3017 if (!SCM_CLOSUREP (proc
))
3019 if (scm_badformalsp (proc
, 1))
3020 goto umwrongnumargs
;
3021 case scm_tcs_closures
:
3023 x
= SCM_CLOSURE_BODY (proc
);
3025 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3029 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3033 goto nontoplevel_begin
;
3034 case scm_tcs_struct
:
3035 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3037 x
= SCM_ENTITY_PROCEDURE (proc
);
3039 arg1
= debug
.info
->a
.args
;
3041 arg1
= scm_list_1 (arg1
);
3045 else if (!SCM_I_OPERATORP (proc
))
3051 proc
= (SCM_I_ENTITYP (proc
)
3052 ? SCM_ENTITY_PROCEDURE (proc
)
3053 : SCM_OPERATOR_PROCEDURE (proc
));
3055 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3056 debug
.info
->a
.proc
= proc
;
3058 if (SCM_NIMP (proc
))
3063 case scm_tc7_subr_2
:
3064 case scm_tc7_subr_0
:
3065 case scm_tc7_subr_3
:
3066 case scm_tc7_lsubr_2
:
3067 scm_wrong_num_args (proc
);
3073 arg2
= EVALCAR (x
, env
);
3075 scm_wrong_num_args (proc
);
3077 { /* have two or more arguments */
3079 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3082 if (SCM_NULLP (x
)) {
3085 switch (SCM_TYP7 (proc
))
3086 { /* have two arguments */
3087 case scm_tc7_subr_2
:
3088 case scm_tc7_subr_2o
:
3089 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3092 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3094 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3096 case scm_tc7_lsubr_2
:
3097 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3098 case scm_tc7_rpsubr
:
3100 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3102 if (!SCM_SMOB_APPLICABLE_P (proc
))
3104 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3108 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3109 scm_cons (proc
, debug
.info
->a
.args
),
3112 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3113 scm_cons2 (proc
, arg1
,
3120 case scm_tcs_struct
:
3121 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3123 x
= SCM_ENTITY_PROCEDURE (proc
);
3125 arg1
= debug
.info
->a
.args
;
3127 arg1
= scm_list_2 (arg1
, arg2
);
3131 else if (!SCM_I_OPERATORP (proc
))
3137 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3138 ? SCM_ENTITY_PROCEDURE (proc
)
3139 : SCM_OPERATOR_PROCEDURE (proc
),
3140 scm_cons (proc
, debug
.info
->a
.args
),
3143 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3144 ? SCM_ENTITY_PROCEDURE (proc
)
3145 : SCM_OPERATOR_PROCEDURE (proc
),
3146 scm_cons2 (proc
, arg1
,
3154 case scm_tc7_subr_0
:
3156 case scm_tc7_subr_1o
:
3157 case scm_tc7_subr_1
:
3158 case scm_tc7_subr_3
:
3159 scm_wrong_num_args (proc
);
3163 proc
= SCM_PROCEDURE (proc
);
3165 debug
.info
->a
.proc
= proc
;
3167 if (!SCM_CLOSUREP (proc
))
3169 if (scm_badformalsp (proc
, 2))
3170 goto umwrongnumargs
;
3171 case scm_tcs_closures
:
3174 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3178 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3179 scm_list_2 (arg1
, arg2
),
3182 x
= SCM_CLOSURE_BODY (proc
);
3183 goto nontoplevel_begin
;
3187 scm_wrong_num_args (proc
);
3189 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3190 deval_args (x
, env
, proc
,
3191 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3195 switch (SCM_TYP7 (proc
))
3196 { /* have 3 or more arguments */
3198 case scm_tc7_subr_3
:
3199 if (!SCM_NULLP (SCM_CDR (x
)))
3200 scm_wrong_num_args (proc
);
3202 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3203 SCM_CADDR (debug
.info
->a
.args
)));
3205 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3206 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3209 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3210 arg2
= SCM_CDR (arg2
);
3212 while (SCM_NIMP (arg2
));
3214 case scm_tc7_rpsubr
:
3215 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3216 RETURN (SCM_BOOL_F
);
3217 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3220 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3221 RETURN (SCM_BOOL_F
);
3222 arg2
= SCM_CAR (arg1
);
3223 arg1
= SCM_CDR (arg1
);
3225 while (SCM_NIMP (arg1
));
3226 RETURN (SCM_BOOL_T
);
3227 case scm_tc7_lsubr_2
:
3228 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3229 SCM_CDDR (debug
.info
->a
.args
)));
3231 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3233 if (!SCM_SMOB_APPLICABLE_P (proc
))
3235 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3236 SCM_CDDR (debug
.info
->a
.args
)));
3240 proc
= SCM_PROCEDURE (proc
);
3241 debug
.info
->a
.proc
= proc
;
3242 if (!SCM_CLOSUREP (proc
))
3244 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3245 goto umwrongnumargs
;
3246 case scm_tcs_closures
:
3247 SCM_SET_ARGSREADY (debug
);
3248 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3251 x
= SCM_CLOSURE_BODY (proc
);
3252 goto nontoplevel_begin
;
3254 case scm_tc7_subr_3
:
3255 if (!SCM_NULLP (SCM_CDR (x
)))
3256 scm_wrong_num_args (proc
);
3258 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3260 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3263 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3266 while (SCM_NIMP (x
));
3268 case scm_tc7_rpsubr
:
3269 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3270 RETURN (SCM_BOOL_F
);
3273 arg1
= EVALCAR (x
, env
);
3274 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3275 RETURN (SCM_BOOL_F
);
3279 while (SCM_NIMP (x
));
3280 RETURN (SCM_BOOL_T
);
3281 case scm_tc7_lsubr_2
:
3282 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3284 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3286 scm_eval_args (x
, env
, proc
))));
3288 if (!SCM_SMOB_APPLICABLE_P (proc
))
3290 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3291 scm_eval_args (x
, env
, proc
)));
3295 proc
= SCM_PROCEDURE (proc
);
3296 if (!SCM_CLOSUREP (proc
))
3299 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3300 if (SCM_NULLP (formals
)
3301 || (SCM_CONSP (formals
)
3302 && (SCM_NULLP (SCM_CDR (formals
))
3303 || (SCM_CONSP (SCM_CDR (formals
))
3304 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3305 goto umwrongnumargs
;
3307 case scm_tcs_closures
:
3309 SCM_SET_ARGSREADY (debug
);
3311 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3314 scm_eval_args (x
, env
, proc
)),
3316 x
= SCM_CLOSURE_BODY (proc
);
3317 goto nontoplevel_begin
;
3319 case scm_tcs_struct
:
3320 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3323 arg1
= debug
.info
->a
.args
;
3325 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3327 x
= SCM_ENTITY_PROCEDURE (proc
);
3330 else if (!SCM_I_OPERATORP (proc
))
3334 case scm_tc7_subr_2
:
3335 case scm_tc7_subr_1o
:
3336 case scm_tc7_subr_2o
:
3337 case scm_tc7_subr_0
:
3339 case scm_tc7_subr_1
:
3340 scm_wrong_num_args (proc
);
3348 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3349 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3351 SCM_CLEAR_TRACED_FRAME (debug
);
3352 if (SCM_CHEAPTRAPS_P
)
3353 arg1
= scm_make_debugobj (&debug
);
3357 SCM val
= scm_make_continuation (&first
);
3368 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3372 scm_last_debug_frame
= debug
.prev
;
3378 /* SECTION: This code is compiled once.
3385 /* Simple procedure calls
3389 scm_call_0 (SCM proc
)
3391 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3395 scm_call_1 (SCM proc
, SCM arg1
)
3397 return scm_apply (proc
, arg1
, scm_listofnull
);
3401 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3403 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3407 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3409 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3413 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3415 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3416 scm_cons (arg4
, scm_listofnull
)));
3419 /* Simple procedure applies
3423 scm_apply_0 (SCM proc
, SCM args
)
3425 return scm_apply (proc
, args
, SCM_EOL
);
3429 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3431 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3435 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3437 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3441 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3443 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3447 /* This code processes the arguments to apply:
3449 (apply PROC ARG1 ... ARGS)
3451 Given a list (ARG1 ... ARGS), this function conses the ARG1
3452 ... arguments onto the front of ARGS, and returns the resulting
3453 list. Note that ARGS is a list; thus, the argument to this
3454 function is a list whose last element is a list.
3456 Apply calls this function, and applies PROC to the elements of the
3457 result. apply:nconc2last takes care of building the list of
3458 arguments, given (ARG1 ... ARGS).
3460 Rather than do new consing, apply:nconc2last destroys its argument.
3461 On that topic, this code came into my care with the following
3462 beautifully cryptic comment on that topic: "This will only screw
3463 you if you do (scm_apply scm_apply '( ... ))" If you know what
3464 they're referring to, send me a patch to this comment. */
3466 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3468 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3469 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3470 "@var{args}, and returns the resulting list. Note that\n"
3471 "@var{args} is a list; thus, the argument to this function is\n"
3472 "a list whose last element is a list.\n"
3473 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3474 "destroys its argument, so use with care.")
3475 #define FUNC_NAME s_scm_nconc2last
3478 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3480 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3481 SCM_NULL_OR_NIL_P, but not
3482 needed in 99.99% of cases,
3483 and it could seriously hurt
3484 performance. - Neil */
3485 lloc
= SCM_CDRLOC (*lloc
);
3486 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3487 *lloc
= SCM_CAR (*lloc
);
3495 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3496 * It is compiled twice.
3501 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3507 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3512 /* Apply a function to a list of arguments.
3514 This function is exported to the Scheme level as taking two
3515 required arguments and a tail argument, as if it were:
3516 (lambda (proc arg1 . args) ...)
3517 Thus, if you just have a list of arguments to pass to a procedure,
3518 pass the list as ARG1, and '() for ARGS. If you have some fixed
3519 args, pass the first as ARG1, then cons any remaining fixed args
3520 onto the front of your argument list, and pass that as ARGS. */
3523 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3526 scm_t_debug_frame debug
;
3527 scm_t_debug_info debug_vect_body
;
3528 debug
.prev
= scm_last_debug_frame
;
3529 debug
.status
= SCM_APPLYFRAME
;
3530 debug
.vect
= &debug_vect_body
;
3531 debug
.vect
[0].a
.proc
= proc
;
3532 debug
.vect
[0].a
.args
= SCM_EOL
;
3533 scm_last_debug_frame
= &debug
;
3536 return scm_dapply (proc
, arg1
, args
);
3539 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3541 /* If ARGS is the empty list, then we're calling apply with only two
3542 arguments --- ARG1 is the list of arguments for PROC. Whatever
3543 the case, futz with things so that ARG1 is the first argument to
3544 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3547 Setting the debug apply frame args this way is pretty messy.
3548 Perhaps we should store arg1 and args directly in the frame as
3549 received, and let scm_frame_arguments unpack them, because that's
3550 a relatively rare operation. This works for now; if the Guile
3551 developer archives are still around, see Mikael's post of
3553 if (SCM_NULLP (args
))
3555 if (SCM_NULLP (arg1
))
3557 arg1
= SCM_UNDEFINED
;
3559 debug
.vect
[0].a
.args
= SCM_EOL
;
3565 debug
.vect
[0].a
.args
= arg1
;
3567 args
= SCM_CDR (arg1
);
3568 arg1
= SCM_CAR (arg1
);
3573 args
= scm_nconc2last (args
);
3575 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3579 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3582 if (SCM_CHEAPTRAPS_P
)
3583 tmp
= scm_make_debugobj (&debug
);
3588 tmp
= scm_make_continuation (&first
);
3593 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3600 switch (SCM_TYP7 (proc
))
3602 case scm_tc7_subr_2o
:
3603 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3604 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3605 case scm_tc7_subr_2
:
3606 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3607 scm_wrong_num_args (proc
);
3608 args
= SCM_CAR (args
);
3609 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3610 case scm_tc7_subr_0
:
3611 if (!SCM_UNBNDP (arg1
))
3612 scm_wrong_num_args (proc
);
3614 RETURN (SCM_SUBRF (proc
) ());
3615 case scm_tc7_subr_1
:
3616 if (SCM_UNBNDP (arg1
))
3617 scm_wrong_num_args (proc
);
3618 case scm_tc7_subr_1o
:
3619 if (!SCM_NULLP (args
))
3620 scm_wrong_num_args (proc
);
3622 RETURN (SCM_SUBRF (proc
) (arg1
));
3624 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3625 scm_wrong_num_args (proc
);
3626 if (SCM_SUBRF (proc
))
3628 if (SCM_INUMP (arg1
))
3630 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3632 else if (SCM_REALP (arg1
))
3634 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3636 else if (SCM_BIGP (arg1
))
3637 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3638 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3639 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3641 proc
= SCM_SNAME (proc
);
3643 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3644 while ('c' != *--chrs
)
3646 SCM_ASSERT (SCM_CONSP (arg1
),
3647 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3648 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3652 case scm_tc7_subr_3
:
3653 if (SCM_NULLP (args
)
3654 || SCM_NULLP (SCM_CDR (args
))
3655 || !SCM_NULLP (SCM_CDDR (args
)))
3656 scm_wrong_num_args (proc
);
3658 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3661 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3663 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3665 case scm_tc7_lsubr_2
:
3666 if (!SCM_CONSP (args
))
3667 scm_wrong_num_args (proc
);
3669 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3671 if (SCM_NULLP (args
))
3672 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3673 while (SCM_NIMP (args
))
3675 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3676 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3677 args
= SCM_CDR (args
);
3680 case scm_tc7_rpsubr
:
3681 if (SCM_NULLP (args
))
3682 RETURN (SCM_BOOL_T
);
3683 while (SCM_NIMP (args
))
3685 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3686 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3687 RETURN (SCM_BOOL_F
);
3688 arg1
= SCM_CAR (args
);
3689 args
= SCM_CDR (args
);
3691 RETURN (SCM_BOOL_T
);
3692 case scm_tcs_closures
:
3694 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3696 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3698 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3699 scm_wrong_num_args (proc
);
3701 /* Copy argument list */
3706 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3707 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
3709 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
3712 SCM_SETCDR (tl
, arg1
);
3715 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3718 proc
= SCM_CLOSURE_BODY (proc
);
3720 arg1
= SCM_CDR (proc
);
3721 while (!SCM_NULLP (arg1
))
3723 if (SCM_IMP (SCM_CAR (proc
)))
3725 if (SCM_ISYMP (SCM_CAR (proc
)))
3727 scm_rec_mutex_lock (&source_mutex
);
3728 /* check for race condition */
3729 if (SCM_ISYMP (SCM_CAR (proc
)))
3730 proc
= scm_m_expand_body (proc
, args
);
3731 scm_rec_mutex_unlock (&source_mutex
);
3735 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3738 SCM_CEVAL (SCM_CAR (proc
), args
);
3740 arg1
= SCM_CDR (proc
);
3742 RETURN (EVALCAR (proc
, args
));
3744 if (!SCM_SMOB_APPLICABLE_P (proc
))
3746 if (SCM_UNBNDP (arg1
))
3747 RETURN (SCM_SMOB_APPLY_0 (proc
));
3748 else if (SCM_NULLP (args
))
3749 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3750 else if (SCM_NULLP (SCM_CDR (args
)))
3751 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3753 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3756 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3758 proc
= SCM_CCLO_SUBR (proc
);
3759 debug
.vect
[0].a
.proc
= proc
;
3760 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3762 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3764 proc
= SCM_CCLO_SUBR (proc
);
3768 proc
= SCM_PROCEDURE (proc
);
3770 debug
.vect
[0].a
.proc
= proc
;
3773 case scm_tcs_struct
:
3774 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3777 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3779 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3781 RETURN (scm_apply_generic (proc
, args
));
3783 else if (!SCM_I_OPERATORP (proc
))
3789 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3791 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3794 proc
= (SCM_I_ENTITYP (proc
)
3795 ? SCM_ENTITY_PROCEDURE (proc
)
3796 : SCM_OPERATOR_PROCEDURE (proc
));
3798 debug
.vect
[0].a
.proc
= proc
;
3799 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3801 if (SCM_NIMP (proc
))
3808 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3812 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3813 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3815 SCM_CLEAR_TRACED_FRAME (debug
);
3816 if (SCM_CHEAPTRAPS_P
)
3817 arg1
= scm_make_debugobj (&debug
);
3821 SCM val
= scm_make_continuation (&first
);
3832 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3836 scm_last_debug_frame
= debug
.prev
;
3842 /* SECTION: The rest of this file is only read once.
3849 * Trampolines make it possible to move procedure application dispatch
3850 * outside inner loops. The motivation was clean implementation of
3851 * efficient replacements of R5RS primitives in SRFI-1.
3853 * The semantics is clear: scm_trampoline_N returns an optimized
3854 * version of scm_call_N (or NULL if the procedure isn't applicable
3857 * Applying the optimization to map and for-each increased efficiency
3858 * noticeably. For example, (map abs ls) is now 8 times faster than
3863 call_subr0_0 (SCM proc
)
3865 return SCM_SUBRF (proc
) ();
3869 call_subr1o_0 (SCM proc
)
3871 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3875 call_lsubr_0 (SCM proc
)
3877 return SCM_SUBRF (proc
) (SCM_EOL
);
3881 scm_i_call_closure_0 (SCM proc
)
3883 const SCM env
= SCM_ENV (proc
);
3884 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3885 const SCM new_env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, env
);
3886 const SCM body
= SCM_CLOSURE_BODY (proc
);
3887 const SCM result
= scm_eval_body (body
, new_env
);
3892 scm_trampoline_0 (SCM proc
)
3898 switch (SCM_TYP7 (proc
))
3900 case scm_tc7_subr_0
:
3901 return call_subr0_0
;
3902 case scm_tc7_subr_1o
:
3903 return call_subr1o_0
;
3905 return call_lsubr_0
;
3906 case scm_tcs_closures
:
3908 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3909 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3910 return scm_i_call_closure_0
;
3914 case scm_tcs_struct
:
3915 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3916 return scm_call_generic_0
;
3917 else if (!SCM_I_OPERATORP (proc
))
3921 if (SCM_SMOB_APPLICABLE_P (proc
))
3922 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3926 case scm_tc7_rpsubr
:
3931 return NULL
; /* not applicable on one arg */
3936 call_subr1_1 (SCM proc
, SCM arg1
)
3938 return SCM_SUBRF (proc
) (arg1
);
3942 call_subr2o_1 (SCM proc
, SCM arg1
)
3944 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3948 call_lsubr_1 (SCM proc
, SCM arg1
)
3950 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3954 call_dsubr_1 (SCM proc
, SCM arg1
)
3956 if (SCM_INUMP (arg1
))
3958 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3960 else if (SCM_REALP (arg1
))
3962 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3964 else if (SCM_BIGP (arg1
))
3965 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3966 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3967 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3971 call_cxr_1 (SCM proc
, SCM arg1
)
3973 proc
= SCM_SNAME (proc
);
3975 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3976 while ('c' != *--chrs
)
3978 SCM_ASSERT (SCM_CONSP (arg1
),
3979 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3980 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3987 call_closure_1 (SCM proc
, SCM arg1
)
3989 const SCM env
= SCM_ENV (proc
);
3990 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3991 const SCM args
= scm_list_1 (arg1
);
3992 const SCM new_env
= SCM_EXTEND_ENV (formals
, args
, env
);
3993 const SCM body
= SCM_CLOSURE_BODY (proc
);
3994 const SCM result
= scm_eval_body (body
, new_env
);
3999 scm_trampoline_1 (SCM proc
)
4005 switch (SCM_TYP7 (proc
))
4007 case scm_tc7_subr_1
:
4008 case scm_tc7_subr_1o
:
4009 return call_subr1_1
;
4010 case scm_tc7_subr_2o
:
4011 return call_subr2o_1
;
4013 return call_lsubr_1
;
4015 if (SCM_SUBRF (proc
))
4016 return call_dsubr_1
;
4019 case scm_tcs_closures
:
4021 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4022 if (!SCM_NULLP (formals
)
4023 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4024 return call_closure_1
;
4028 case scm_tcs_struct
:
4029 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4030 return scm_call_generic_1
;
4031 else if (!SCM_I_OPERATORP (proc
))
4035 if (SCM_SMOB_APPLICABLE_P (proc
))
4036 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4040 case scm_tc7_rpsubr
:
4045 return NULL
; /* not applicable on one arg */
4050 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4052 return SCM_SUBRF (proc
) (arg1
, arg2
);
4056 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4058 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4062 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4064 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4068 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4070 const SCM env
= SCM_ENV (proc
);
4071 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4072 const SCM args
= scm_list_2 (arg1
, arg2
);
4073 const SCM new_env
= SCM_EXTEND_ENV (formals
, args
, env
);
4074 const SCM body
= SCM_CLOSURE_BODY (proc
);
4075 const SCM result
= scm_eval_body (body
, new_env
);
4080 scm_trampoline_2 (SCM proc
)
4086 switch (SCM_TYP7 (proc
))
4088 case scm_tc7_subr_2
:
4089 case scm_tc7_subr_2o
:
4090 case scm_tc7_rpsubr
:
4092 return call_subr2_2
;
4093 case scm_tc7_lsubr_2
:
4094 return call_lsubr2_2
;
4096 return call_lsubr_2
;
4097 case scm_tcs_closures
:
4099 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4100 if (!SCM_NULLP (formals
)
4101 && (!SCM_CONSP (formals
)
4102 || (!SCM_NULLP (SCM_CDR (formals
))
4103 && (!SCM_CONSP (SCM_CDR (formals
))
4104 || !SCM_CONSP (SCM_CDDR (formals
))))))
4105 return call_closure_2
;
4109 case scm_tcs_struct
:
4110 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4111 return scm_call_generic_2
;
4112 else if (!SCM_I_OPERATORP (proc
))
4116 if (SCM_SMOB_APPLICABLE_P (proc
))
4117 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4124 return NULL
; /* not applicable on two args */
4128 /* Typechecking for multi-argument MAP and FOR-EACH.
4130 Verify that each element of the vector ARGV, except for the first,
4131 is a proper list whose length is LEN. Attribute errors to WHO,
4132 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4134 check_map_args (SCM argv
,
4141 SCM
const *ve
= SCM_VELTS (argv
);
4144 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4146 long elt_len
= scm_ilength (ve
[i
]);
4151 scm_apply_generic (gf
, scm_cons (proc
, args
));
4153 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4157 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4160 scm_remember_upto_here_1 (argv
);
4164 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4166 /* Note: Currently, scm_map applies PROC to the argument list(s)
4167 sequentially, starting with the first element(s). This is used in
4168 evalext.c where the Scheme procedure `map-in-order', which guarantees
4169 sequential behaviour, is implemented using scm_map. If the
4170 behaviour changes, we need to update `map-in-order'.
4174 scm_map (SCM proc
, SCM arg1
, SCM args
)
4175 #define FUNC_NAME s_map
4180 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4182 len
= scm_ilength (arg1
);
4183 SCM_GASSERTn (len
>= 0,
4184 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4185 SCM_VALIDATE_REST_ARGUMENT (args
);
4186 if (SCM_NULLP (args
))
4188 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4189 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4190 while (SCM_NIMP (arg1
))
4192 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4193 pres
= SCM_CDRLOC (*pres
);
4194 arg1
= SCM_CDR (arg1
);
4198 if (SCM_NULLP (SCM_CDR (args
)))
4200 SCM arg2
= SCM_CAR (args
);
4201 int len2
= scm_ilength (arg2
);
4202 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4204 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4205 SCM_GASSERTn (len2
>= 0,
4206 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4208 SCM_OUT_OF_RANGE (3, arg2
);
4209 while (SCM_NIMP (arg1
))
4211 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4212 pres
= SCM_CDRLOC (*pres
);
4213 arg1
= SCM_CDR (arg1
);
4214 arg2
= SCM_CDR (arg2
);
4218 arg1
= scm_cons (arg1
, args
);
4219 args
= scm_vector (arg1
);
4220 ve
= SCM_VELTS (args
);
4221 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4225 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4227 if (SCM_IMP (ve
[i
]))
4229 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4230 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4232 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4233 pres
= SCM_CDRLOC (*pres
);
4239 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4242 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4243 #define FUNC_NAME s_for_each
4245 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4247 len
= scm_ilength (arg1
);
4248 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4249 SCM_ARG2
, s_for_each
);
4250 SCM_VALIDATE_REST_ARGUMENT (args
);
4251 if (SCM_NULLP (args
))
4253 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4254 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4255 while (SCM_NIMP (arg1
))
4257 call (proc
, SCM_CAR (arg1
));
4258 arg1
= SCM_CDR (arg1
);
4260 return SCM_UNSPECIFIED
;
4262 if (SCM_NULLP (SCM_CDR (args
)))
4264 SCM arg2
= SCM_CAR (args
);
4265 int len2
= scm_ilength (arg2
);
4266 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4267 SCM_GASSERTn (call
, g_for_each
,
4268 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4269 SCM_GASSERTn (len2
>= 0, g_for_each
,
4270 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4272 SCM_OUT_OF_RANGE (3, arg2
);
4273 while (SCM_NIMP (arg1
))
4275 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4276 arg1
= SCM_CDR (arg1
);
4277 arg2
= SCM_CDR (arg2
);
4279 return SCM_UNSPECIFIED
;
4281 arg1
= scm_cons (arg1
, args
);
4282 args
= scm_vector (arg1
);
4283 ve
= SCM_VELTS (args
);
4284 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4288 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4290 if (SCM_IMP (ve
[i
]))
4291 return SCM_UNSPECIFIED
;
4292 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4293 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4295 scm_apply (proc
, arg1
, SCM_EOL
);
4302 scm_closure (SCM code
, SCM env
)
4305 SCM closcar
= scm_cons (code
, SCM_EOL
);
4306 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4307 scm_remember_upto_here (closcar
);
4312 scm_t_bits scm_tc16_promise
;
4315 scm_makprom (SCM code
)
4317 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4319 scm_make_rec_mutex ());
4323 promise_free (SCM promise
)
4325 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4330 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4332 int writingp
= SCM_WRITINGP (pstate
);
4333 scm_puts ("#<promise ", port
);
4334 SCM_SET_WRITINGP (pstate
, 1);
4335 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4336 SCM_SET_WRITINGP (pstate
, writingp
);
4337 scm_putc ('>', port
);
4341 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4343 "If the promise @var{x} has not been computed yet, compute and\n"
4344 "return @var{x}, otherwise just return the previously computed\n"
4346 #define FUNC_NAME s_scm_force
4348 SCM_VALIDATE_SMOB (1, promise
, promise
);
4349 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4350 if (!SCM_PROMISE_COMPUTED_P (promise
))
4352 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4353 if (!SCM_PROMISE_COMPUTED_P (promise
))
4355 SCM_SET_PROMISE_DATA (promise
, ans
);
4356 SCM_SET_PROMISE_COMPUTED (promise
);
4359 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4360 return SCM_PROMISE_DATA (promise
);
4365 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4367 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4368 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4369 #define FUNC_NAME s_scm_promise_p
4371 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4376 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4377 (SCM xorig
, SCM x
, SCM y
),
4378 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4379 "Any source properties associated with @var{xorig} are also associated\n"
4380 "with the new pair.")
4381 #define FUNC_NAME s_scm_cons_source
4384 z
= scm_cons (x
, y
);
4385 /* Copy source properties possibly associated with xorig. */
4386 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4388 scm_whash_insert (scm_source_whash
, z
, p
);
4394 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4396 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4397 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4398 "contents of both pairs and vectors (since both cons cells and vector\n"
4399 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4400 "any other object.")
4401 #define FUNC_NAME s_scm_copy_tree
4406 if (SCM_VECTORP (obj
))
4408 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4409 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4411 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4414 if (!SCM_CONSP (obj
))
4416 ans
= tl
= scm_cons_source (obj
,
4417 scm_copy_tree (SCM_CAR (obj
)),
4419 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4421 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4425 SCM_SETCDR (tl
, obj
);
4431 /* We have three levels of EVAL here:
4433 - scm_i_eval (exp, env)
4435 evaluates EXP in environment ENV. ENV is a lexical environment
4436 structure as used by the actual tree code evaluator. When ENV is
4437 a top-level environment, then changes to the current module are
4438 tracked by updating ENV so that it continues to be in sync with
4441 - scm_primitive_eval (exp)
4443 evaluates EXP in the top-level environment as determined by the
4444 current module. This is done by constructing a suitable
4445 environment and calling scm_i_eval. Thus, changes to the
4446 top-level module are tracked normally.
4448 - scm_eval (exp, mod)
4450 evaluates EXP while MOD is the current module. This is done by
4451 setting the current module to MOD, invoking scm_primitive_eval on
4452 EXP, and then restoring the current module to the value it had
4453 previously. That is, while EXP is evaluated, changes to the
4454 current module are tracked, but these changes do not persist when
4457 For each level of evals, there are two variants, distinguished by a
4458 _x suffix: the ordinary variant does not modify EXP while the _x
4459 variant can destructively modify EXP into something completely
4460 unintelligible. A Scheme data structure passed as EXP to one of the
4461 _x variants should not ever be used again for anything. So when in
4462 doubt, use the ordinary variant.
4467 scm_i_eval_x (SCM exp
, SCM env
)
4469 return SCM_XEVAL (exp
, env
);
4473 scm_i_eval (SCM exp
, SCM env
)
4475 exp
= scm_copy_tree (exp
);
4476 return SCM_XEVAL (exp
, env
);
4480 scm_primitive_eval_x (SCM exp
)
4483 SCM transformer
= scm_current_module_transformer ();
4484 if (SCM_NIMP (transformer
))
4485 exp
= scm_call_1 (transformer
, exp
);
4486 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4487 return scm_i_eval_x (exp
, env
);
4490 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4492 "Evaluate @var{exp} in the top-level environment specified by\n"
4493 "the current module.")
4494 #define FUNC_NAME s_scm_primitive_eval
4497 SCM transformer
= scm_current_module_transformer ();
4498 if (SCM_NIMP (transformer
))
4499 exp
= scm_call_1 (transformer
, exp
);
4500 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4501 return scm_i_eval (exp
, env
);
4505 /* Eval does not take the second arg optionally. This is intentional
4506 * in order to be R5RS compatible, and to prepare for the new module
4507 * system, where we would like to make the choice of evaluation
4508 * environment explicit. */
4511 change_environment (void *data
)
4513 SCM pair
= SCM_PACK (data
);
4514 SCM new_module
= SCM_CAR (pair
);
4515 SCM old_module
= scm_current_module ();
4516 SCM_SETCDR (pair
, old_module
);
4517 scm_set_current_module (new_module
);
4522 restore_environment (void *data
)
4524 SCM pair
= SCM_PACK (data
);
4525 SCM old_module
= SCM_CDR (pair
);
4526 SCM new_module
= scm_current_module ();
4527 SCM_SETCAR (pair
, new_module
);
4528 scm_set_current_module (old_module
);
4532 inner_eval_x (void *data
)
4534 return scm_primitive_eval_x (SCM_PACK(data
));
4538 scm_eval_x (SCM exp
, SCM module
)
4539 #define FUNC_NAME "eval!"
4541 SCM_VALIDATE_MODULE (2, module
);
4543 return scm_internal_dynamic_wind
4544 (change_environment
, inner_eval_x
, restore_environment
,
4545 (void *) SCM_UNPACK (exp
),
4546 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4551 inner_eval (void *data
)
4553 return scm_primitive_eval (SCM_PACK(data
));
4556 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4557 (SCM exp
, SCM module
),
4558 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4559 "in the top-level environment specified by @var{module}.\n"
4560 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4561 "@var{module} is made the current module. The current module\n"
4562 "is reset to its previous value when @var{eval} returns.")
4563 #define FUNC_NAME s_scm_eval
4565 SCM_VALIDATE_MODULE (2, module
);
4567 return scm_internal_dynamic_wind
4568 (change_environment
, inner_eval
, restore_environment
,
4569 (void *) SCM_UNPACK (exp
),
4570 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4575 /* At this point, scm_deval and scm_dapply are generated.
4585 scm_init_opts (scm_evaluator_traps
,
4586 scm_evaluator_trap_table
,
4587 SCM_N_EVALUATOR_TRAPS
);
4588 scm_init_opts (scm_eval_options_interface
,
4590 SCM_N_EVAL_OPTIONS
);
4592 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4593 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4594 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4595 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4597 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4598 SCM_SETCDR (undefineds
, undefineds
);
4599 scm_permanent_object (undefineds
);
4601 scm_listofnull
= scm_list_1 (SCM_EOL
);
4603 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4604 scm_permanent_object (f_apply
);
4606 #include "libguile/eval.x"
4608 scm_add_feature ("delay");