1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 /* This file is read twice in order to produce debugging versions of
45 * scm_ceval and scm_apply. These functions, scm_deval and
46 * scm_dapply, are produced when we define the preprocessor macro
47 * DEVAL. The file is divided into sections which are treated
48 * differently with respect to DEVAL. The heads of these sections are
49 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
57 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
58 #include "libguile/scmconfig.h"
60 /* AIX requires this to be the first thing in the file. The #pragma
61 directive is indented so pre-ANSI compilers will ignore it, rather
70 # ifndef alloca /* predefined by HP cc +Olibcalls */
77 #include "libguile/_scm.h"
78 #include "libguile/debug.h"
79 #include "libguile/dynwind.h"
80 #include "libguile/alist.h"
81 #include "libguile/eq.h"
82 #include "libguile/continuations.h"
83 #include "libguile/throw.h"
84 #include "libguile/smob.h"
85 #include "libguile/macros.h"
86 #include "libguile/procprop.h"
87 #include "libguile/hashtab.h"
88 #include "libguile/hash.h"
89 #include "libguile/srcprop.h"
90 #include "libguile/stackchk.h"
91 #include "libguile/objects.h"
92 #include "libguile/async.h"
93 #include "libguile/feature.h"
94 #include "libguile/modules.h"
95 #include "libguile/ports.h"
96 #include "libguile/root.h"
97 #include "libguile/vectors.h"
98 #include "libguile/fluids.h"
99 #include "libguile/goops.h"
100 #include "libguile/values.h"
102 #include "libguile/validate.h"
103 #include "libguile/eval.h"
104 #include "libguile/lang.h"
108 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
110 if (SCM_EQ_P ((x), SCM_EOL)) \
111 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
116 /* The evaluator contains a plethora of EVAL symbols.
117 * This is an attempt at explanation.
119 * The following macros should be used in code which is read twice
120 * (where the choice of evaluator is hard soldered):
122 * SCM_CEVAL is the symbol used within one evaluator to call itself.
123 * Originally, it is defined to scm_ceval, but is redefined to
124 * scm_deval during the second pass.
126 * SCM_EVALIM is used when it is known that the expression is an
127 * immediate. (This macro never calls an evaluator.)
129 * EVALCAR evaluates the car of an expression.
131 * The following macros should be used in code which is read once
132 * (where the choice of evaluator is dynamic):
134 * SCM_XEVAL takes care of immediates without calling an evaluator. It
135 * then calls scm_ceval *or* scm_deval, depending on the debugging
138 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
139 * depending on the debugging mode.
141 * The main motivation for keeping this plethora is efficiency
142 * together with maintainability (=> locality of code).
145 #define SCM_CEVAL scm_ceval
147 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
148 ? SCM_EVALIM (SCM_CAR (x), env) \
149 : (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env)))
153 #define EXTEND_ENV SCM_EXTEND_ENV
155 SCM_REC_MUTEX (source_mutex
);
158 scm_ilookup (SCM iloc
, SCM env
)
160 register long ir
= SCM_IFRAME (iloc
);
161 register SCM er
= env
;
162 for (; 0 != ir
; --ir
)
165 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
167 if (SCM_ICDRP (iloc
))
168 return SCM_CDRLOC (er
);
169 return SCM_CARLOC (SCM_CDR (er
));
172 /* The Lookup Car Race
175 Memoization of variables and special forms is done while executing
176 the code for the first time. As long as there is only one thread
177 everything is fine, but as soon as two threads execute the same
178 code concurrently `for the first time' they can come into conflict.
180 This memoization includes rewriting variable references into more
181 efficient forms and expanding macros. Furthermore, macro expansion
182 includes `compiling' special forms like `let', `cond', etc. into
183 tree-code instructions.
185 There shouldn't normally be a problem with memoizing local and
186 global variable references (into ilocs and variables), because all
187 threads will mutate the code in *exactly* the same way and (if I
188 read the C code correctly) it is not possible to observe a half-way
189 mutated cons cell. The lookup procedure can handle this
190 transparently without any critical sections.
192 It is different with macro expansion, because macro expansion
193 happens outside of the lookup procedure and can't be
194 undone. Therefore the lookup procedure can't cope with it. It has
195 to indicate failure when it detects a lost race and hope that the
196 caller can handle it. Luckily, it turns out that this is the case.
198 An example to illustrate this: Suppose that the following form will
199 be memoized concurrently by two threads
203 Let's first examine the lookup of X in the body. The first thread
204 decides that it has to find the symbol "x" in the environment and
205 starts to scan it. Then the other thread takes over and actually
206 overtakes the first. It looks up "x" and substitutes an
207 appropriate iloc for it. Now the first thread continues and
208 completes its lookup. It comes to exactly the same conclusions as
209 the second one and could - without much ado - just overwrite the
210 iloc with the same iloc.
212 But let's see what will happen when the race occurs while looking
213 up the symbol "let" at the start of the form. It could happen that
214 the second thread interrupts the lookup of the first thread and not
215 only substitutes a variable for it but goes right ahead and
216 replaces it with the compiled form (#@let* (x 12) x). Now, when
217 the first thread completes its lookup, it would replace the #@let*
218 with a variable containing the "let" binding, effectively reverting
219 the form to (let (x 12) x). This is wrong. It has to detect that
220 it has lost the race and the evaluator has to reconsider the
221 changed form completely.
223 This race condition could be resolved with some kind of traffic
224 light (like mutexes) around scm_lookupcar, but I think that it is
225 best to avoid them in this case. They would serialize memoization
226 completely and because lookup involves calling arbitrary Scheme
227 code (via the lookup-thunk), threads could be blocked for an
228 arbitrary amount of time or even deadlock. But with the current
229 solution a lot of unnecessary work is potentially done. */
231 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
232 return NULL to indicate a failed lookup due to some race conditions
233 between threads. This only happens when VLOC is the first cell of
234 a special form that will eventually be memoized (like `let', etc.)
235 In that case the whole lookup is bogus and the caller has to
236 reconsider the complete special form.
238 SCM_LOOKUPCAR is still there, of course. It just calls
239 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
240 should only be called when it is known that VLOC is not the first
241 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
242 for NULL. I think I've found the only places where this
245 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
248 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
251 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
252 register SCM iloc
= SCM_ILOC00
;
253 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
255 if (!SCM_CONSP (SCM_CAR (env
)))
257 al
= SCM_CARLOC (env
);
258 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
262 if (SCM_EQ_P (fl
, var
))
264 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
266 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
267 return SCM_CDRLOC (*al
);
272 al
= SCM_CDRLOC (*al
);
273 if (SCM_EQ_P (SCM_CAR (fl
), var
))
275 if (SCM_UNBNDP (SCM_CAR (*al
)))
280 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
282 SCM_SETCAR (vloc
, iloc
);
283 return SCM_CARLOC (*al
);
285 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
287 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
290 SCM top_thunk
, real_var
;
293 top_thunk
= SCM_CAR (env
); /* env now refers to a
294 top level env thunk */
298 top_thunk
= SCM_BOOL_F
;
299 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
300 if (SCM_FALSEP (real_var
))
303 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
309 scm_error (scm_unbound_variable_key
, NULL
,
310 "Unbound variable: ~S",
311 scm_list_1 (var
), SCM_BOOL_F
);
313 scm_misc_error (NULL
, "Damaged environment: ~S",
318 /* A variable could not be found, but we shall
319 not throw an error. */
320 static SCM undef_object
= SCM_UNDEFINED
;
321 return &undef_object
;
325 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
327 /* Some other thread has changed the very cell we are working
328 on. In effect, it must have done our job or messed it up
331 var
= SCM_CAR (vloc
);
332 if (SCM_VARIABLEP (var
))
333 return SCM_VARIABLE_LOC (var
);
334 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
335 return scm_ilookup (var
, genv
);
336 /* We can't cope with anything else than variables and ilocs. When
337 a special form has been memoized (i.e. `let' into `#@let') we
338 return NULL and expect the calling function to do the right
339 thing. For the evaluator, this means going back and redoing
340 the dispatch on the car of the form. */
344 SCM_SETCAR (vloc
, real_var
);
345 return SCM_VARIABLE_LOC (real_var
);
350 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
352 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
358 #define unmemocar scm_unmemocar
360 SCM_SYMBOL (sym_three_question_marks
, "???");
363 scm_unmemocar (SCM form
, SCM env
)
365 if (!SCM_CONSP (form
))
369 SCM c
= SCM_CAR (form
);
370 if (SCM_VARIABLEP (c
))
372 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
373 if (SCM_FALSEP (sym
))
374 sym
= sym_three_question_marks
;
375 SCM_SETCAR (form
, sym
);
377 else if (SCM_ILOCP (c
))
379 unsigned long int ir
;
381 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
383 env
= SCM_CAAR (env
);
384 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
386 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
394 scm_eval_car (SCM pair
, SCM env
)
396 return SCM_XEVALCAR (pair
, env
);
401 * The following rewrite expressions and
402 * some memoized forms have different syntax
405 const char scm_s_expression
[] = "missing or extra expression";
406 const char scm_s_test
[] = "bad test";
407 const char scm_s_body
[] = "bad body";
408 const char scm_s_bindings
[] = "bad bindings";
409 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
410 const char scm_s_variable
[] = "bad variable";
411 const char scm_s_clauses
[] = "bad or missing clauses";
412 const char scm_s_formals
[] = "bad formals";
413 const char scm_s_duplicate_formals
[] = "duplicate formals";
414 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
416 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
417 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
418 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
419 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
420 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
424 #ifdef DEBUG_EXTENSIONS
425 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
426 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
427 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
428 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
432 /* Check that the body denoted by XORIG is valid and rewrite it into
433 its internal form. The internal form of a body is just the body
434 itself, but prefixed with an ISYM that denotes to what kind of
435 outer construct this body belongs. A lambda body starts with
436 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
437 etc. The one exception is a body that belongs to a letrec that has
438 been formed by rewriting internal defines: it starts with
441 /* XXX - Besides controlling the rewriting of internal defines, the
442 additional ISYM could be used for improved error messages.
443 This is not done yet. */
446 scm_m_body (SCM op
, SCM xorig
, const char *what
)
448 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
450 /* Don't add another ISYM if one is present already. */
451 if (SCM_ISYMP (SCM_CAR (xorig
)))
454 /* Retain possible doc string. */
455 if (!SCM_CONSP (SCM_CAR (xorig
)))
457 if (!SCM_NULLP (SCM_CDR (xorig
)))
458 return scm_cons (SCM_CAR (xorig
),
459 scm_m_body (op
, SCM_CDR (xorig
), what
));
463 return scm_cons (op
, xorig
);
467 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
468 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
471 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
473 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
474 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
478 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
479 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
482 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
484 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
485 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
489 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
490 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
493 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
495 long len
= scm_ilength (SCM_CDR (xorig
));
496 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
497 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
501 /* Will go into the RnRS module when Guile is factorized.
502 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
503 const char scm_s_set_x
[] = "set!";
504 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
507 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
509 SCM x
= SCM_CDR (xorig
);
510 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
511 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
512 return scm_cons (SCM_IM_SET_X
, x
);
516 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
517 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
520 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
522 long len
= scm_ilength (SCM_CDR (xorig
));
523 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
525 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
531 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
532 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
535 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
537 long len
= scm_ilength (SCM_CDR (xorig
));
538 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
540 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
546 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
547 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
550 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
553 SCM cdrx
= SCM_CDR (xorig
);
554 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
555 clauses
= SCM_CDR (cdrx
);
556 while (!SCM_NULLP (clauses
))
558 SCM clause
= SCM_CAR (clauses
);
559 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
560 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
561 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
562 && SCM_NULLP (SCM_CDR (clauses
))),
563 scm_s_clauses
, s_case
);
564 clauses
= SCM_CDR (clauses
);
566 return scm_cons (SCM_IM_CASE
, cdrx
);
570 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
571 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
574 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
576 SCM cdrx
= SCM_CDR (xorig
);
578 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
579 while (!SCM_NULLP (clauses
))
581 SCM clause
= SCM_CAR (clauses
);
582 long len
= scm_ilength (clause
);
583 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
584 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
586 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
587 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
589 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
591 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
592 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
594 clauses
= SCM_CDR (clauses
);
596 return scm_cons (SCM_IM_COND
, cdrx
);
600 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
601 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
603 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
604 * cdr of the last cons. (Thus, LIST is not required to be a proper
605 * list and OBJ can also be found in the improper ending.) */
607 scm_c_improper_memq (SCM obj
, SCM list
)
609 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
611 if (SCM_EQ_P (SCM_CAR (list
), obj
))
614 return SCM_EQ_P (list
, obj
);
618 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
621 SCM x
= SCM_CDR (xorig
);
623 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
625 formals
= SCM_CAR (x
);
626 while (SCM_CONSP (formals
))
628 SCM formal
= SCM_CAR (formals
);
629 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
630 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
631 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
632 formals
= SCM_CDR (formals
);
634 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
635 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
637 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
638 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
642 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
643 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
645 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
646 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
648 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
651 SCM x
= SCM_CDR (xorig
);
655 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
657 bindings
= SCM_CAR (x
);
658 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
659 while (!SCM_NULLP (bindings
))
661 SCM binding
= SCM_CAR (bindings
);
662 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
663 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
664 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
665 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
666 bindings
= SCM_CDR (bindings
);
669 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
670 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
674 /* DO gets the most radically altered syntax. The order of the vars is
675 * reversed here. In contrast, the order of the inits and steps is reversed
676 * during the evaluation:
678 (do ((<var1> <init1> <step1>)
686 (#@do (varn ... var2 var1)
687 (<init1> <init2> ... <initn>)
690 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
693 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
694 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
697 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
700 SCM x
= SCM_CDR (xorig
);
703 SCM
*initloc
= &inits
;
705 SCM
*steploc
= &steps
;
706 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
707 bindings
= SCM_CAR (x
);
708 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
709 while (!SCM_NULLP (bindings
))
711 SCM binding
= SCM_CAR (bindings
);
712 long len
= scm_ilength (binding
);
713 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
715 SCM name
= SCM_CAR (binding
);
716 SCM init
= SCM_CADR (binding
);
717 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
718 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
719 vars
= scm_cons (name
, vars
);
720 *initloc
= scm_list_1 (init
);
721 initloc
= SCM_CDRLOC (*initloc
);
722 *steploc
= scm_list_1 (step
);
723 steploc
= SCM_CDRLOC (*steploc
);
724 bindings
= SCM_CDR (bindings
);
728 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
729 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
730 x
= scm_cons2 (vars
, inits
, x
);
731 return scm_cons (SCM_IM_DO
, x
);
735 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
736 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
738 /* Internal function to handle a quasiquotation: 'form' is the parameter in
739 * the call (quasiquotation form), 'env' is the environment where unquoted
740 * expressions will be evaluated, and 'depth' is the current quasiquotation
741 * nesting level and is known to be greater than zero. */
743 iqq (SCM form
, SCM env
, unsigned long int depth
)
745 if (SCM_CONSP (form
))
747 SCM tmp
= SCM_CAR (form
);
748 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
750 SCM args
= SCM_CDR (form
);
751 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
752 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
754 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
756 SCM args
= SCM_CDR (form
);
757 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
759 return scm_eval_car (args
, env
);
761 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
763 else if (SCM_CONSP (tmp
)
764 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
766 SCM args
= SCM_CDR (tmp
);
767 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
770 SCM list
= scm_eval_car (args
, env
);
771 SCM rest
= SCM_CDR (form
);
772 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
773 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
776 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
777 iqq (SCM_CDR (form
), env
, depth
));
780 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
781 iqq (SCM_CDR (form
), env
, depth
));
783 else if (SCM_VECTORP (form
))
785 size_t i
= SCM_VECTOR_LENGTH (form
);
786 SCM
const *data
= SCM_VELTS (form
);
789 tmp
= scm_cons (data
[--i
], tmp
);
790 scm_remember_upto_here_1 (form
);
791 return scm_vector (iqq (tmp
, env
, depth
));
798 scm_m_quasiquote (SCM xorig
, SCM env
)
800 SCM x
= SCM_CDR (xorig
);
801 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
802 return iqq (SCM_CAR (x
), env
, 1);
806 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
807 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
809 /* Promises are implemented as closures with an empty parameter list. Thus,
810 * (delay <expression>) is transformed into (#@delay '() <expression>), where
811 * the empty list represents the empty parameter list. This representation
812 * allows for easy creation of the closure during evaluation. */
814 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
816 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
817 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
821 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
822 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
824 /* Like promises, futures are implemented as closures with an empty
825 * parameter list. Thus, (future <expression>) is transformed into
826 * (#@future '() <expression>), where the empty list represents the
827 * empty parameter list. This representation allows for easy creation
828 * of the closure during evaluation. */
830 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
832 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
833 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
837 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
838 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
840 /* Guile provides an extension to R5RS' define syntax to represent function
841 * currying in a compact way. With this extension, it is allowed to write
842 * (define <nested-variable> <body>), where <nested-variable> has of one of
843 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
844 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
845 * should be either a sequence of zero or more variables, or a sequence of one
846 * or more variables followed by a space-delimited period and another
847 * variable. Each level of argument nesting wraps the <body> within another
848 * lambda expression. For example, the following forms are allowed, each one
849 * followed by an equivalent, more explicit implementation.
851 * (define ((a b . c) . d) <body>) is equivalent to
852 * (define a (lambda (b . c) (lambda d <body>)))
854 * (define (((a) b) c . d) <body>) is equivalent to
855 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
857 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
858 * module that does not implement this extension. */
860 scm_m_define (SCM x
, SCM env
)
864 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
867 while (SCM_CONSP (name
))
869 /* This while loop realizes function currying by variable nesting. */
870 SCM formals
= SCM_CDR (name
);
871 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
872 name
= SCM_CAR (name
);
874 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
875 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
876 if (SCM_TOP_LEVEL (env
))
879 x
= scm_eval_car (x
, env
);
880 if (SCM_REC_PROCNAMES_P
)
883 while (SCM_MACROP (tmp
))
884 tmp
= SCM_MACRO_CODE (tmp
);
885 if (SCM_CLOSUREP (tmp
)
886 /* Only the first definition determines the name. */
887 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
888 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
890 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
891 SCM_VARIABLE_SET (var
, x
);
892 return SCM_UNSPECIFIED
;
895 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
899 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
900 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
901 * reversed here, the list of inits gets reversed during evaluation. */
903 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
909 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
913 SCM binding
= SCM_CAR (bindings
);
914 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
915 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
916 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
917 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
918 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
919 *initloc
= scm_list_1 (SCM_CADR (binding
));
920 initloc
= SCM_CDRLOC (*initloc
);
921 bindings
= SCM_CDR (bindings
);
923 while (!SCM_NULLP (bindings
));
929 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
930 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
933 scm_m_letrec (SCM xorig
, SCM env
)
935 SCM x
= SCM_CDR (xorig
);
936 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
938 if (SCM_NULLP (SCM_CAR (x
)))
940 /* null binding, let* faster */
941 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
942 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
946 SCM rvars
, inits
, body
;
947 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
948 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
949 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
954 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
955 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
958 scm_m_let (SCM xorig
, SCM env
)
960 SCM x
= SCM_CDR (xorig
);
963 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
966 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
968 /* null or single binding, let* is faster */
970 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
971 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
973 else if (SCM_CONSP (temp
))
977 SCM rvars
, inits
, body
;
978 transform_bindings (bindings
, &rvars
, &inits
, "let");
979 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
980 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
984 /* named let: Transform (let name ((var init) ...) body ...) into
985 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
991 SCM
*initloc
= &inits
;
994 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
996 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
997 bindings
= SCM_CAR (x
);
998 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
999 while (!SCM_NULLP (bindings
))
1000 { /* vars and inits both in order */
1001 SCM binding
= SCM_CAR (bindings
);
1002 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1003 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1004 *varloc
= scm_list_1 (SCM_CAR (binding
));
1005 varloc
= SCM_CDRLOC (*varloc
);
1006 *initloc
= scm_list_1 (SCM_CADR (binding
));
1007 initloc
= SCM_CDRLOC (*initloc
);
1008 bindings
= SCM_CDR (bindings
);
1012 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1013 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1014 SCM rvar
= scm_list_1 (name
);
1015 SCM init
= scm_list_1 (lambda_form
);
1016 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1017 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1018 return scm_cons (letrec
, inits
);
1024 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1025 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1026 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1029 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1031 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1032 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1036 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1037 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1041 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1043 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1044 scm_s_expression
, s_atcall_cc
);
1045 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1048 #ifdef SCM_ENABLE_ELISP
1050 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1053 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1055 long len
= scm_ilength (SCM_CDR (xorig
));
1056 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1057 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1060 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1063 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1065 SCM x
= SCM_CDR (xorig
), var
;
1066 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1067 var
= scm_symbol_fref (SCM_CAR (x
));
1068 /* Passing the symbol name as the `subr' arg here isn't really
1069 right, but without it it can be very difficult to work out from
1070 the error message which function definition was missing. In any
1071 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1072 something equivalent to (signal void-function (list SYM)) in
1074 SCM_ASSYNT (SCM_VARIABLEP (var
),
1075 "Symbol's function definition is void",
1076 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1077 /* Support `defalias'. */
1078 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1080 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1081 SCM_ASSYNT (SCM_VARIABLEP (var
),
1082 "Symbol's function definition is void",
1083 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1085 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1086 former allows for automatically picking up redefinitions of the
1087 corresponding symbol. */
1088 SCM_SETCAR (x
, var
);
1089 /* If the variable contains a procedure, leave the
1090 `transformer-macro' in place so that the procedure's arguments
1091 get properly transformed, and change the initial @fop to
1093 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1095 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1098 /* Otherwise (the variable contains a macro), the arguments should
1099 not be transformed, so cut the `transformer-macro' out and return
1100 the resulting expression starting with the variable. */
1101 SCM_SETCDR (x
, SCM_CDADR (x
));
1105 #endif /* SCM_ENABLE_ELISP */
1107 /* (@bind ((var exp) ...) body ...)
1109 This will assign the values of the `exp's to the global variables
1110 named by `var's (symbols, not evaluated), creating them if they
1111 don't exist, executes body, and then restores the previous values of
1112 the `var's. Additionally, whenever control leaves body, the values
1113 of the `var's are saved and restored when control returns. It is an
1114 error when a symbol appears more than once among the `var's.
1115 All `exp's are evaluated before any `var' is set.
1117 Think of this as `let' for dynamic scope.
1119 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1121 XXX - also implement `@bind*'.
1124 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1127 scm_m_atbind (SCM xorig
, SCM env
)
1129 SCM x
= SCM_CDR (xorig
);
1130 SCM top_level
= scm_env_top_level (env
);
1131 SCM vars
= SCM_EOL
, var
;
1134 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1137 while (SCM_NIMP (x
))
1140 SCM sym_exp
= SCM_CAR (x
);
1141 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1142 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1144 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1145 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1146 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1147 /* The first call to scm_sym2var will look beyond the current
1148 module, while the second call wont. */
1149 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1150 if (SCM_FALSEP (var
))
1151 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1152 vars
= scm_cons (var
, vars
);
1153 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1155 return scm_cons (SCM_IM_BIND
,
1156 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1160 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1161 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1164 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1166 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1167 scm_s_expression
, s_at_call_with_values
);
1168 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1172 scm_m_expand_body (SCM xorig
, SCM env
)
1174 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1175 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1177 while (SCM_NIMP (x
))
1179 SCM form
= SCM_CAR (x
);
1180 if (!SCM_CONSP (form
))
1182 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1185 form
= scm_macroexp (scm_cons_source (form
,
1190 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1192 defs
= scm_cons (SCM_CDR (form
), defs
);
1195 else if (!SCM_IMP (defs
))
1199 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1201 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1205 x
= scm_cons (form
, SCM_CDR (x
));
1210 if (!SCM_NULLP (defs
))
1212 SCM rvars
, inits
, body
, letrec
;
1213 transform_bindings (defs
, &rvars
, &inits
, what
);
1214 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1215 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1216 SCM_SETCAR (xorig
, letrec
);
1217 SCM_SETCDR (xorig
, SCM_EOL
);
1221 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1222 SCM_SETCAR (xorig
, SCM_CAR (x
));
1223 SCM_SETCDR (xorig
, SCM_CDR (x
));
1230 scm_macroexp (SCM x
, SCM env
)
1232 SCM res
, proc
, orig_sym
;
1234 /* Don't bother to produce error messages here. We get them when we
1235 eventually execute the code for real. */
1238 orig_sym
= SCM_CAR (x
);
1239 if (!SCM_SYMBOLP (orig_sym
))
1243 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1244 if (proc_ptr
== NULL
)
1246 /* We have lost the race. */
1252 /* Only handle memoizing macros. `Acros' and `macros' are really
1253 special forms and should not be evaluated here. */
1255 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1258 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1259 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1261 if (scm_ilength (res
) <= 0)
1262 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1265 SCM_SETCAR (x
, SCM_CAR (res
));
1266 SCM_SETCDR (x
, SCM_CDR (res
));
1272 /* scm_unmemocopy takes a memoized expression together with its
1273 * environment and rewrites it to its original form. Thus, it is the
1274 * inversion of the rewrite rules above. The procedure is not
1275 * optimized for speed. It's used in scm_iprin1 when printing the
1276 * code of a closure, in scm_procedure_source, in display_frame when
1277 * generating the source for a stackframe in a backtrace, and in
1278 * display_expression.
1280 * Unmemoizing is not a reliable process. You cannot in general
1281 * expect to get the original source back.
1283 * However, GOOPS currently relies on this for method compilation.
1284 * This ought to change.
1287 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1290 build_binding_list (SCM names
, SCM inits
)
1292 SCM bindings
= SCM_EOL
;
1293 while (!SCM_NULLP (names
))
1295 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1296 bindings
= scm_cons (binding
, bindings
);
1297 names
= SCM_CDR (names
);
1298 inits
= SCM_CDR (inits
);
1304 unmemocopy (SCM x
, SCM env
)
1307 #ifdef DEBUG_EXTENSIONS
1312 #ifdef DEBUG_EXTENSIONS
1313 p
= scm_whash_lookup (scm_source_whash
, x
);
1315 switch (SCM_ITAG7 (SCM_CAR (x
)))
1317 case SCM_BIT8(SCM_IM_AND
):
1318 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1320 case SCM_BIT8(SCM_IM_BEGIN
):
1321 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1323 case SCM_BIT8(SCM_IM_CASE
):
1324 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1326 case SCM_BIT8(SCM_IM_COND
):
1327 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1329 case SCM_BIT8 (SCM_IM_DO
):
1331 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1332 * where nx is the name of a local variable, ix is an initializer for
1333 * the local variable, test is the test clause of the do loop, body is
1334 * the body of the do loop and sx are the step clauses for the local
1336 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1339 names
= SCM_CAR (x
);
1341 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1342 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1344 test
= unmemocopy (SCM_CAR (x
), env
);
1346 memoized_body
= SCM_CAR (x
);
1348 steps
= scm_reverse (unmemocopy (x
, env
));
1350 /* build transformed binding list */
1352 while (!SCM_NULLP (names
))
1354 SCM name
= SCM_CAR (names
);
1355 SCM init
= SCM_CAR (inits
);
1356 SCM step
= SCM_CAR (steps
);
1357 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1359 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1361 names
= SCM_CDR (names
);
1362 inits
= SCM_CDR (inits
);
1363 steps
= SCM_CDR (steps
);
1365 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1366 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1368 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1371 case SCM_BIT8(SCM_IM_IF
):
1372 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1374 case SCM_BIT8 (SCM_IM_LET
):
1376 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1377 * where nx is the name of a local variable, ix is an initializer for
1378 * the local variable and by are the body clauses. */
1379 SCM names
, inits
, bindings
;
1382 names
= SCM_CAR (x
);
1384 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1385 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1387 bindings
= build_binding_list (names
, inits
);
1388 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1389 ls
= scm_cons (scm_sym_let
, z
);
1392 case SCM_BIT8 (SCM_IM_LETREC
):
1394 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1395 * where nx is the name of a local variable, ix is an initializer for
1396 * the local variable and by are the body clauses. */
1397 SCM names
, inits
, bindings
;
1400 names
= SCM_CAR (x
);
1401 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1403 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1405 bindings
= build_binding_list (names
, inits
);
1406 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1407 ls
= scm_cons (scm_sym_letrec
, z
);
1410 case SCM_BIT8(SCM_IM_LETSTAR
):
1418 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1421 y
= z
= scm_acons (SCM_CAR (b
),
1423 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1425 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1429 SCM_SETCDR (y
, SCM_EOL
);
1430 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1435 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1437 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1440 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1443 while (SCM_NIMP (b
));
1444 SCM_SETCDR (z
, SCM_EOL
);
1446 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1449 case SCM_BIT8(SCM_IM_OR
):
1450 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1452 case SCM_BIT8(SCM_IM_LAMBDA
):
1454 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1455 ls
= scm_cons (scm_sym_lambda
, z
);
1456 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1458 case SCM_BIT8(SCM_IM_QUOTE
):
1459 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1461 case SCM_BIT8(SCM_IM_SET_X
):
1462 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1464 case SCM_BIT8(SCM_IM_DEFINE
):
1469 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1470 ls
= scm_cons (scm_sym_define
, z
);
1471 if (!SCM_NULLP (env
))
1472 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1477 case SCM_BIT8(SCM_MAKISYM (0)):
1481 switch (SCM_ISYMNUM (z
))
1483 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1484 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1486 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1487 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1489 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1490 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1493 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1494 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1497 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1498 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1501 /* appease the Sun compiler god: */ ;
1505 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1511 while (SCM_CONSP (x
))
1513 SCM form
= SCM_CAR (x
);
1514 if (!SCM_ISYMP (form
))
1516 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1517 SCM_SETCDR (z
, unmemocar (copy
, env
));
1523 #ifdef DEBUG_EXTENSIONS
1524 if (!SCM_FALSEP (p
))
1525 scm_whash_insert (scm_source_whash
, ls
, p
);
1532 scm_unmemocopy (SCM x
, SCM env
)
1534 if (!SCM_NULLP (env
))
1535 /* Make a copy of the lowest frame to protect it from
1536 modifications by SCM_IM_DEFINE */
1537 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1539 return unmemocopy (x
, env
);
1544 scm_badargsp (SCM formals
, SCM args
)
1546 while (!SCM_NULLP (formals
))
1548 if (!SCM_CONSP (formals
))
1550 if (SCM_NULLP (args
))
1552 formals
= SCM_CDR (formals
);
1553 args
= SCM_CDR (args
);
1555 return !SCM_NULLP (args
) ? 1 : 0;
1560 scm_badformalsp (SCM closure
, int n
)
1562 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1563 while (!SCM_NULLP (formals
))
1565 if (!SCM_CONSP (formals
))
1570 formals
= SCM_CDR (formals
);
1577 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1579 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1580 while (SCM_CONSP (l
))
1582 res
= EVALCAR (l
, env
);
1584 *lloc
= scm_list_1 (res
);
1585 lloc
= SCM_CDRLOC (*lloc
);
1589 scm_wrong_num_args (proc
);
1594 scm_eval_body (SCM code
, SCM env
)
1598 next
= SCM_CDR (code
);
1599 while (!SCM_NULLP (next
))
1601 if (SCM_IMP (SCM_CAR (code
)))
1603 if (SCM_ISYMP (SCM_CAR (code
)))
1605 scm_rec_mutex_lock (&source_mutex
);
1606 /* check for race condition */
1607 if (SCM_ISYMP (SCM_CAR (code
)))
1608 code
= scm_m_expand_body (code
, env
);
1609 scm_rec_mutex_unlock (&source_mutex
);
1614 SCM_XEVAL (SCM_CAR (code
), env
);
1616 next
= SCM_CDR (code
);
1618 return SCM_XEVALCAR (code
, env
);
1625 /* SECTION: This code is specific for the debugging support. One
1626 * branch is read when DEVAL isn't defined, the other when DEVAL is
1632 #define SCM_APPLY scm_apply
1633 #define PREP_APPLY(proc, args)
1635 #define RETURN(x) do { return x; } while (0)
1636 #ifdef STACK_CHECKING
1637 #ifndef NO_CEVAL_STACK_CHECKING
1638 #define EVAL_STACK_CHECKING
1645 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1647 #define SCM_APPLY scm_dapply
1649 #define PREP_APPLY(p, l) \
1650 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1652 #define ENTER_APPLY \
1654 SCM_SET_ARGSREADY (debug);\
1655 if (scm_check_apply_p && SCM_TRAPS_P)\
1656 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1658 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1659 SCM_SET_TRACED_FRAME (debug); \
1661 if (SCM_CHEAPTRAPS_P)\
1663 tmp = scm_make_debugobj (&debug);\
1664 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1669 tmp = scm_make_continuation (&first);\
1671 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1677 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1678 #ifdef STACK_CHECKING
1679 #ifndef EVAL_STACK_CHECKING
1680 #define EVAL_STACK_CHECKING
1684 /* scm_ceval_ptr points to the currently selected evaluator.
1685 * *fixme*: Although efficiency is important here, this state variable
1686 * should probably not be a global. It should be related to the
1691 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1693 /* scm_last_debug_frame contains a pointer to the last debugging
1694 * information stack frame. It is accessed very often from the
1695 * debugging evaluator, so it should probably not be indirectly
1696 * addressed. Better to save and restore it from the current root at
1700 /* scm_debug_eframe_size is the number of slots available for pseudo
1701 * stack frames at each real stack frame.
1704 long scm_debug_eframe_size
;
1706 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1708 long scm_eval_stack
;
1710 scm_t_option scm_eval_opts
[] = {
1711 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1714 scm_t_option scm_debug_opts
[] = {
1715 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1716 "*Flyweight representation of the stack at traps." },
1717 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1718 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1719 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1720 "Record procedure names at definition." },
1721 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1722 "Display backtrace in anti-chronological order." },
1723 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1724 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1725 { SCM_OPTION_INTEGER
, "frames", 3,
1726 "Maximum number of tail-recursive frames in backtrace." },
1727 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1728 "Maximal number of stored backtrace frames." },
1729 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1730 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1731 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1732 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1733 { 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."}
1736 scm_t_option scm_evaluator_trap_table
[] = {
1737 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1738 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1739 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1740 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1741 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1742 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1743 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1746 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1748 "Option interface for the evaluation options. Instead of using\n"
1749 "this procedure directly, use the procedures @code{eval-enable},\n"
1750 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1751 #define FUNC_NAME s_scm_eval_options_interface
1755 ans
= scm_options (setting
,
1759 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1765 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1767 "Option interface for the evaluator trap options.")
1768 #define FUNC_NAME s_scm_evaluator_traps
1772 ans
= scm_options (setting
,
1773 scm_evaluator_trap_table
,
1774 SCM_N_EVALUATOR_TRAPS
,
1776 SCM_RESET_DEBUG_MODE
;
1783 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1785 SCM
*results
= lloc
, res
;
1786 while (SCM_CONSP (l
))
1788 res
= EVALCAR (l
, env
);
1790 *lloc
= scm_list_1 (res
);
1791 lloc
= SCM_CDRLOC (*lloc
);
1795 scm_wrong_num_args (proc
);
1802 /* SECTION: This code is compiled twice.
1806 /* Update the toplevel environment frame ENV so that it refers to the
1807 * current module. */
1808 #define UPDATE_TOPLEVEL_ENV(env) \
1810 SCM p = scm_current_module_lookup_closure (); \
1811 if (p != SCM_CAR(env)) \
1812 env = scm_top_level_env (p); \
1816 /* This is the evaluator. Like any real monster, it has three heads:
1818 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1819 * version. Both are implemented using a common code base, using the
1820 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1821 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1822 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1823 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1824 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1825 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1826 * are enclosed within #ifdef DEVAL ... #endif.
1828 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1829 * take two input parameters, x and env: x is a single expression to be
1830 * evalutated. env is the environment in which bindings are searched.
1832 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1833 * is a single expression, it is necessarily in a tail position. If x is just
1834 * a call to another function like in the expression (foo exp1 exp2 ...), the
1835 * realization of that call therefore _must_not_ increase stack usage (the
1836 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1837 * making extensive use of 'goto' statements within the evaluator: The gotos
1838 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1839 * that SCM_CEVAL was already using. If, however, x represents some form that
1840 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1841 * then recursive calls to SCM_CEVAL are performed for all but the last
1842 * expression of that sequence. */
1846 scm_ceval (SCM x
, SCM env
)
1852 scm_deval (SCM x
, SCM env
)
1857 SCM_CEVAL (SCM x
, SCM env
)
1861 scm_t_debug_frame debug
;
1862 scm_t_debug_info
*debug_info_end
;
1863 debug
.prev
= scm_last_debug_frame
;
1866 * The debug.vect contains twice as much scm_t_debug_info frames as the
1867 * user has specified with (debug-set! frames <n>).
1869 * Even frames are eval frames, odd frames are apply frames.
1871 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1872 * sizeof (scm_t_debug_info
));
1873 debug
.info
= debug
.vect
;
1874 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1875 scm_last_debug_frame
= &debug
;
1877 #ifdef EVAL_STACK_CHECKING
1878 if (scm_stack_checking_enabled_p
1879 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1882 debug
.info
->e
.exp
= x
;
1883 debug
.info
->e
.env
= env
;
1885 scm_report_stack_overflow ();
1895 SCM_CLEAR_ARGSREADY (debug
);
1896 if (SCM_OVERFLOWP (debug
))
1899 * In theory, this should be the only place where it is necessary to
1900 * check for space in debug.vect since both eval frames and
1901 * available space are even.
1903 * For this to be the case, however, it is necessary that primitive
1904 * special forms which jump back to `loop', `begin' or some similar
1905 * label call PREP_APPLY.
1907 else if (++debug
.info
>= debug_info_end
)
1909 SCM_SET_OVERFLOW (debug
);
1914 debug
.info
->e
.exp
= x
;
1915 debug
.info
->e
.env
= env
;
1916 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1918 if (SCM_ENTER_FRAME_P
1919 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1922 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1923 SCM_SET_TAILREC (debug
);
1924 if (SCM_CHEAPTRAPS_P
)
1925 stackrep
= scm_make_debugobj (&debug
);
1929 SCM val
= scm_make_continuation (&first
);
1939 /* This gives the possibility for the debugger to
1940 modify the source expression before evaluation. */
1945 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1946 scm_sym_enter_frame
,
1949 scm_unmemocopy (x
, env
));
1956 switch (SCM_TYP7 (x
))
1958 case scm_tc7_symbol
:
1959 /* Only happens when called at top level. */
1960 x
= scm_cons (x
, SCM_UNDEFINED
);
1961 RETURN (*scm_lookupcar (x
, env
, 1));
1963 case SCM_BIT8 (SCM_IM_AND
):
1965 while (!SCM_NULLP (SCM_CDR (x
)))
1967 SCM test_result
= EVALCAR (x
, env
);
1968 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1969 RETURN (SCM_BOOL_F
);
1973 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1976 case SCM_BIT8 (SCM_IM_BEGIN
):
1979 RETURN (SCM_UNSPECIFIED
);
1981 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1984 /* If we are on toplevel with a lookup closure, we need to sync
1985 with the current module. */
1986 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1988 UPDATE_TOPLEVEL_ENV (env
);
1989 while (!SCM_NULLP (SCM_CDR (x
)))
1992 UPDATE_TOPLEVEL_ENV (env
);
1998 goto nontoplevel_begin
;
2001 while (!SCM_NULLP (SCM_CDR (x
)))
2003 SCM form
= SCM_CAR (x
);
2006 if (SCM_ISYMP (form
))
2008 scm_rec_mutex_lock (&source_mutex
);
2009 /* check for race condition */
2010 if (SCM_ISYMP (SCM_CAR (x
)))
2011 x
= scm_m_expand_body (x
, env
);
2012 scm_rec_mutex_unlock (&source_mutex
);
2013 goto nontoplevel_begin
;
2016 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2019 SCM_CEVAL (form
, env
);
2025 /* scm_eval last form in list */
2026 SCM last_form
= SCM_CAR (x
);
2028 if (SCM_CONSP (last_form
))
2030 /* This is by far the most frequent case. */
2032 goto loop
; /* tail recurse */
2034 else if (SCM_IMP (last_form
))
2035 RETURN (SCM_EVALIM (last_form
, env
));
2036 else if (SCM_VARIABLEP (last_form
))
2037 RETURN (SCM_VARIABLE_REF (last_form
));
2038 else if (SCM_SYMBOLP (last_form
))
2039 RETURN (*scm_lookupcar (x
, env
, 1));
2045 case SCM_BIT8 (SCM_IM_CASE
):
2048 SCM key
= EVALCAR (x
, env
);
2050 while (!SCM_NULLP (x
))
2052 SCM clause
= SCM_CAR (x
);
2053 SCM labels
= SCM_CAR (clause
);
2054 if (SCM_EQ_P (labels
, scm_sym_else
))
2056 x
= SCM_CDR (clause
);
2057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2060 while (!SCM_NULLP (labels
))
2062 SCM label
= SCM_CAR (labels
);
2063 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2065 x
= SCM_CDR (clause
);
2066 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2069 labels
= SCM_CDR (labels
);
2074 RETURN (SCM_UNSPECIFIED
);
2077 case SCM_BIT8 (SCM_IM_COND
):
2079 while (!SCM_NULLP (x
))
2081 SCM clause
= SCM_CAR (x
);
2082 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2084 x
= SCM_CDR (clause
);
2085 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2090 arg1
= EVALCAR (clause
, env
);
2091 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2093 x
= SCM_CDR (clause
);
2096 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2098 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2104 proc
= EVALCAR (proc
, env
);
2105 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2106 PREP_APPLY (proc
, scm_list_1 (arg1
));
2108 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2109 goto umwrongnumargs
;
2117 RETURN (SCM_UNSPECIFIED
);
2120 case SCM_BIT8 (SCM_IM_DO
):
2123 /* Compute the initialization values and the initial environment. */
2124 SCM init_forms
= SCM_CADR (x
);
2125 SCM init_values
= SCM_EOL
;
2126 while (!SCM_NULLP (init_forms
))
2128 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2129 init_forms
= SCM_CDR (init_forms
);
2131 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2135 SCM test_form
= SCM_CAR (x
);
2136 SCM body_forms
= SCM_CADR (x
);
2137 SCM step_forms
= SCM_CDDR (x
);
2139 SCM test_result
= EVALCAR (test_form
, env
);
2141 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2144 /* Evaluate body forms. */
2146 for (temp_forms
= body_forms
;
2147 !SCM_NULLP (temp_forms
);
2148 temp_forms
= SCM_CDR (temp_forms
))
2150 SCM form
= SCM_CAR (temp_forms
);
2151 /* Dirk:FIXME: We only need to eval forms, that may have a
2152 * side effect here. This is only true for forms that start
2153 * with a pair. All others are just constants. However,
2154 * since in the common case there is no constant expression
2155 * in a body of a do form, we just check for immediates here
2156 * and have SCM_CEVAL take care of other cases. In the long
2157 * run it would make sense to get rid of this test and have
2158 * the macro transformer of 'do' eliminate all forms that
2159 * have no sideeffect. */
2160 if (!SCM_IMP (form
))
2161 SCM_CEVAL (form
, env
);
2166 /* Evaluate the step expressions. */
2168 SCM step_values
= SCM_EOL
;
2169 for (temp_forms
= step_forms
;
2170 !SCM_NULLP (temp_forms
);
2171 temp_forms
= SCM_CDR (temp_forms
))
2173 SCM value
= EVALCAR (temp_forms
, env
);
2174 step_values
= scm_cons (value
, step_values
);
2176 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2179 test_result
= EVALCAR (test_form
, env
);
2184 RETURN (SCM_UNSPECIFIED
);
2185 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2186 goto nontoplevel_begin
;
2189 case SCM_BIT8 (SCM_IM_IF
):
2192 SCM test_result
= EVALCAR (x
, env
);
2193 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2199 RETURN (SCM_UNSPECIFIED
);
2202 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2206 case SCM_BIT8 (SCM_IM_LET
):
2209 SCM init_forms
= SCM_CADR (x
);
2210 SCM init_values
= SCM_EOL
;
2213 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2214 init_forms
= SCM_CDR (init_forms
);
2216 while (!SCM_NULLP (init_forms
));
2217 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2220 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2221 goto nontoplevel_begin
;
2224 case SCM_BIT8 (SCM_IM_LETREC
):
2226 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2229 SCM init_forms
= SCM_CAR (x
);
2230 SCM init_values
= SCM_EOL
;
2233 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2234 init_forms
= SCM_CDR (init_forms
);
2236 while (!SCM_NULLP (init_forms
));
2237 SCM_SETCDR (SCM_CAR (env
), init_values
);
2240 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2241 goto nontoplevel_begin
;
2244 case SCM_BIT8 (SCM_IM_LETSTAR
):
2247 SCM bindings
= SCM_CAR (x
);
2248 if (SCM_NULLP (bindings
))
2249 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2254 SCM name
= SCM_CAR (bindings
);
2255 SCM init
= SCM_CDR (bindings
);
2256 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2257 bindings
= SCM_CDR (init
);
2259 while (!SCM_NULLP (bindings
));
2263 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2264 goto nontoplevel_begin
;
2267 case SCM_BIT8 (SCM_IM_OR
):
2269 while (!SCM_NULLP (SCM_CDR (x
)))
2271 SCM val
= EVALCAR (x
, env
);
2272 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2277 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2281 case SCM_BIT8 (SCM_IM_LAMBDA
):
2282 RETURN (scm_closure (SCM_CDR (x
), env
));
2285 case SCM_BIT8 (SCM_IM_QUOTE
):
2286 RETURN (SCM_CADR (x
));
2289 case SCM_BIT8 (SCM_IM_SET_X
):
2293 SCM variable
= SCM_CAR (x
);
2294 if (SCM_ILOCP (variable
))
2295 location
= scm_ilookup (variable
, env
);
2296 else if (SCM_VARIABLEP (variable
))
2297 location
= SCM_VARIABLE_LOC (variable
);
2298 else /* (SCM_SYMBOLP (variable)) is known to be true */
2299 location
= scm_lookupcar (x
, env
, 1);
2301 *location
= EVALCAR (x
, env
);
2303 RETURN (SCM_UNSPECIFIED
);
2306 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2307 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2310 /* new syntactic forms go here. */
2311 case SCM_BIT8 (SCM_MAKISYM (0)):
2313 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2314 switch (SCM_ISYMNUM (proc
))
2318 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2320 proc
= EVALCAR (proc
, env
);
2321 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2322 if (SCM_CLOSUREP (proc
))
2324 PREP_APPLY (proc
, SCM_EOL
);
2325 arg1
= SCM_CDDR (x
);
2326 arg1
= EVALCAR (arg1
, env
);
2328 /* Go here to tail-call a closure. PROC is the closure
2329 and ARG1 is the list of arguments. Do not forget to
2332 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2334 debug
.info
->a
.args
= arg1
;
2336 if (scm_badargsp (formals
, arg1
))
2337 scm_wrong_num_args (proc
);
2339 /* Copy argument list */
2340 if (SCM_NULL_OR_NIL_P (arg1
))
2341 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2344 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2346 arg1
= SCM_CDR (arg1
);
2347 while (!SCM_NULL_OR_NIL_P (arg1
))
2349 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2350 SCM_SETCDR (tail
, new_tail
);
2352 arg1
= SCM_CDR (arg1
);
2354 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2357 x
= SCM_CLOSURE_BODY (proc
);
2358 goto nontoplevel_begin
;
2368 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2371 SCM val
= scm_make_continuation (&first
);
2379 proc
= scm_eval_car (proc
, env
);
2380 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2381 PREP_APPLY (proc
, scm_list_1 (arg1
));
2383 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2384 goto umwrongnumargs
;
2390 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2391 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2394 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2395 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2398 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2400 /* If not done yet, evaluate the operand forms. The result is a
2401 * list of arguments stored in arg1, which is used to perform the
2402 * function dispatch. */
2403 SCM operand_forms
= SCM_CADR (x
);
2404 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2405 if (SCM_ILOCP (operand_forms
))
2406 arg1
= *scm_ilookup (operand_forms
, env
);
2407 else if (SCM_VARIABLEP (operand_forms
))
2408 arg1
= SCM_VARIABLE_REF (operand_forms
);
2409 else if (!SCM_CONSP (operand_forms
))
2410 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2413 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2414 operand_forms
= SCM_CDR (operand_forms
);
2415 while (!SCM_NULLP (operand_forms
))
2417 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2418 SCM_SETCDR (tail
, new_tail
);
2420 operand_forms
= SCM_CDR (operand_forms
);
2425 /* The type dispatch code is duplicated below
2426 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2427 * cuts down execution time for type dispatch to 50%. */
2428 type_dispatch
: /* inputs: x, arg1 */
2429 /* Type dispatch means to determine from the types of the function
2430 * arguments (i. e. the 'signature' of the call), which method from
2431 * a generic function is to be called. This process of selecting
2432 * the right method takes some time. To speed it up, guile uses
2433 * caching: Together with the macro call to dispatch the signatures
2434 * of some previous calls to that generic function from the same
2435 * place are stored (in the code!) in a cache that we call the
2436 * 'method cache'. This is done since it is likely, that
2437 * consecutive calls to dispatch from that position in the code will
2438 * have the same signature. Thus, the type dispatch works as
2439 * follows: First, determine a hash value from the signature of the
2440 * actual arguments. Second, use this hash value as an index to
2441 * find that same signature in the method cache stored at this
2442 * position in the code. If found, you have also found the
2443 * corresponding method that belongs to that signature. If the
2444 * signature is not found in the method cache, you have to perform a
2445 * full search over all signatures stored with the generic
2448 unsigned long int specializers
;
2449 unsigned long int hash_value
;
2450 unsigned long int cache_end_pos
;
2451 unsigned long int mask
;
2455 SCM z
= SCM_CDDR (x
);
2456 SCM tmp
= SCM_CADR (z
);
2457 specializers
= SCM_INUM (SCM_CAR (z
));
2459 /* Compute a hash value for searching the method cache. There
2460 * are two variants for computing the hash value, a (rather)
2461 * complicated one, and a simple one. For the complicated one
2462 * explained below, tmp holds a number that is used in the
2464 if (SCM_INUMP (tmp
))
2466 /* Use the signature of the actual arguments to determine
2467 * the hash value. This is done as follows: Each class has
2468 * an array of random numbers, that are determined when the
2469 * class is created. The integer 'hashset' is an index into
2470 * that array of random numbers. Now, from all classes that
2471 * are part of the signature of the actual arguments, the
2472 * random numbers at index 'hashset' are taken and summed
2473 * up, giving the hash value. The value of 'hashset' is
2474 * stored at the call to dispatch. This allows to have
2475 * different 'formulas' for calculating the hash value at
2476 * different places where dispatch is called. This allows
2477 * to optimize the hash formula at every individual place
2478 * where dispatch is called, such that hopefully the hash
2479 * value that is computed will directly point to the right
2480 * method in the method cache. */
2481 unsigned long int hashset
= SCM_INUM (tmp
);
2482 unsigned long int counter
= specializers
+ 1;
2485 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2487 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2488 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2489 tmp_arg
= SCM_CDR (tmp_arg
);
2493 method_cache
= SCM_CADR (z
);
2494 mask
= SCM_INUM (SCM_CAR (z
));
2496 cache_end_pos
= hash_value
;
2500 /* This method of determining the hash value is much
2501 * simpler: Set the hash value to zero and just perform a
2502 * linear search through the method cache. */
2504 mask
= (unsigned long int) ((long) -1);
2506 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2511 /* Search the method cache for a method with a matching
2512 * signature. Start the search at position 'hash_value'. The
2513 * hashing implementation uses linear probing for conflict
2514 * resolution, that is, if the signature in question is not
2515 * found at the starting index in the hash table, the next table
2516 * entry is tried, and so on, until in the worst case the whole
2517 * cache has been searched, but still the signature has not been
2522 SCM args
= arg1
; /* list of arguments */
2523 z
= SCM_VELTS (method_cache
)[hash_value
];
2524 while (!SCM_NULLP (args
))
2526 /* More arguments than specifiers => CLASS != ENV */
2527 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2528 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2530 args
= SCM_CDR (args
);
2533 /* Fewer arguments than specifiers => CAR != ENV */
2534 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2537 hash_value
= (hash_value
+ 1) & mask
;
2538 } while (hash_value
!= cache_end_pos
);
2540 /* No appropriate method was found in the cache. */
2541 z
= scm_memoize_method (x
, arg1
);
2543 apply_cmethod
: /* inputs: z, arg1 */
2545 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2546 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2547 x
= SCM_CMETHOD_BODY (z
);
2548 goto nontoplevel_begin
;
2554 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2557 SCM instance
= EVALCAR (x
, env
);
2558 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2559 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2563 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2566 SCM instance
= EVALCAR (x
, env
);
2567 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2568 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2569 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2570 RETURN (SCM_UNSPECIFIED
);
2574 #ifdef SCM_ENABLE_ELISP
2576 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2578 SCM test_form
= SCM_CDR (x
);
2579 x
= SCM_CDR (test_form
);
2580 while (!SCM_NULL_OR_NIL_P (x
))
2582 SCM test_result
= EVALCAR (test_form
, env
);
2583 if (!(SCM_FALSEP (test_result
)
2584 || SCM_NULL_OR_NIL_P (test_result
)))
2586 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2587 RETURN (test_result
);
2588 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2593 test_form
= SCM_CDR (x
);
2594 x
= SCM_CDR (test_form
);
2598 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2602 #endif /* SCM_ENABLE_ELISP */
2604 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2606 SCM vars
, exps
, vals
;
2609 vars
= SCM_CAAR (x
);
2610 exps
= SCM_CDAR (x
);
2614 while (SCM_NIMP (exps
))
2616 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2617 exps
= SCM_CDR (exps
);
2620 scm_swap_bindings (vars
, vals
);
2621 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2623 /* Ignore all but the last evaluation result. */
2624 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2626 if (SCM_CONSP (SCM_CAR (x
)))
2627 SCM_CEVAL (SCM_CAR (x
), env
);
2629 proc
= EVALCAR (x
, env
);
2631 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2632 scm_swap_bindings (vars
, vals
);
2638 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2641 x
= EVALCAR (proc
, env
);
2642 proc
= SCM_CDR (proc
);
2643 proc
= EVALCAR (proc
, env
);
2644 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2645 if (SCM_VALUESP (arg1
))
2646 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2648 arg1
= scm_list_1 (arg1
);
2649 if (SCM_CLOSUREP (proc
))
2651 PREP_APPLY (proc
, arg1
);
2654 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2665 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2666 case scm_tc7_vector
:
2670 case scm_tc7_byvect
:
2677 #ifdef HAVE_LONG_LONGS
2678 case scm_tc7_llvect
:
2681 case scm_tc7_string
:
2683 case scm_tcs_closures
:
2687 case scm_tcs_struct
:
2690 case scm_tc7_variable
:
2691 RETURN (SCM_VARIABLE_REF(x
));
2693 case SCM_BIT8(SCM_ILOC00
):
2694 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2695 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2698 case scm_tcs_cons_nimcar
:
2699 if (SCM_SYMBOLP (SCM_CAR (x
)))
2701 SCM orig_sym
= SCM_CAR (x
);
2703 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2704 if (location
== NULL
)
2706 /* we have lost the race, start again. */
2714 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2718 if (SCM_MACROP (proc
))
2720 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2722 handle_a_macro
: /* inputs: x, env, proc */
2724 /* Set a flag during macro expansion so that macro
2725 application frames can be deleted from the backtrace. */
2726 SCM_SET_MACROEXP (debug
);
2728 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2729 scm_cons (env
, scm_listofnull
));
2732 SCM_CLEAR_MACROEXP (debug
);
2734 switch (SCM_MACRO_TYPE (proc
))
2737 if (scm_ilength (arg1
) <= 0)
2738 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2740 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2743 SCM_SETCAR (x
, SCM_CAR (arg1
));
2744 SCM_SETCDR (x
, SCM_CDR (arg1
));
2748 /* Prevent memoizing of debug info expression. */
2749 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2754 SCM_SETCAR (x
, SCM_CAR (arg1
));
2755 SCM_SETCDR (x
, SCM_CDR (arg1
));
2757 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2759 #if SCM_ENABLE_DEPRECATED == 1
2764 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2776 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2777 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2780 if (SCM_CLOSUREP (proc
))
2782 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2783 SCM args
= SCM_CDR (x
);
2784 while (!SCM_NULLP (formals
))
2786 if (!SCM_CONSP (formals
))
2789 goto umwrongnumargs
;
2790 formals
= SCM_CDR (formals
);
2791 args
= SCM_CDR (args
);
2793 if (!SCM_NULLP (args
))
2794 goto umwrongnumargs
;
2796 else if (SCM_MACROP (proc
))
2797 goto handle_a_macro
;
2801 evapply
: /* inputs: x, proc */
2802 PREP_APPLY (proc
, SCM_EOL
);
2803 if (SCM_NULLP (SCM_CDR (x
))) {
2806 switch (SCM_TYP7 (proc
))
2807 { /* no arguments given */
2808 case scm_tc7_subr_0
:
2809 RETURN (SCM_SUBRF (proc
) ());
2810 case scm_tc7_subr_1o
:
2811 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2813 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2814 case scm_tc7_rpsubr
:
2815 RETURN (SCM_BOOL_T
);
2817 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2819 if (!SCM_SMOB_APPLICABLE_P (proc
))
2821 RETURN (SCM_SMOB_APPLY_0 (proc
));
2824 proc
= SCM_CCLO_SUBR (proc
);
2826 debug
.info
->a
.proc
= proc
;
2827 debug
.info
->a
.args
= scm_list_1 (arg1
);
2831 proc
= SCM_PROCEDURE (proc
);
2833 debug
.info
->a
.proc
= proc
;
2835 if (!SCM_CLOSUREP (proc
))
2837 if (scm_badformalsp (proc
, 0))
2838 goto umwrongnumargs
;
2839 case scm_tcs_closures
:
2840 x
= SCM_CLOSURE_BODY (proc
);
2841 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2842 goto nontoplevel_begin
;
2843 case scm_tcs_struct
:
2844 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2846 x
= SCM_ENTITY_PROCEDURE (proc
);
2850 else if (!SCM_I_OPERATORP (proc
))
2855 proc
= (SCM_I_ENTITYP (proc
)
2856 ? SCM_ENTITY_PROCEDURE (proc
)
2857 : SCM_OPERATOR_PROCEDURE (proc
));
2859 debug
.info
->a
.proc
= proc
;
2860 debug
.info
->a
.args
= scm_list_1 (arg1
);
2862 if (SCM_NIMP (proc
))
2867 case scm_tc7_subr_1
:
2868 case scm_tc7_subr_2
:
2869 case scm_tc7_subr_2o
:
2871 case scm_tc7_subr_3
:
2872 case scm_tc7_lsubr_2
:
2875 scm_wrong_num_args (proc
);
2877 /* handle macros here */
2882 /* must handle macros by here */
2885 arg1
= EVALCAR (x
, env
);
2887 scm_wrong_num_args (proc
);
2889 debug
.info
->a
.args
= scm_list_1 (arg1
);
2897 evap1
: /* inputs: proc, arg1 */
2898 switch (SCM_TYP7 (proc
))
2899 { /* have one argument in arg1 */
2900 case scm_tc7_subr_2o
:
2901 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2902 case scm_tc7_subr_1
:
2903 case scm_tc7_subr_1o
:
2904 RETURN (SCM_SUBRF (proc
) (arg1
));
2906 if (SCM_SUBRF (proc
))
2908 if (SCM_INUMP (arg1
))
2910 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2912 else if (SCM_REALP (arg1
))
2914 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2917 else if (SCM_BIGP (arg1
))
2919 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2922 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2923 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2925 proc
= SCM_SNAME (proc
);
2927 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2928 while ('c' != *--chrs
)
2930 SCM_ASSERT (SCM_CONSP (arg1
),
2931 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2932 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2936 case scm_tc7_rpsubr
:
2937 RETURN (SCM_BOOL_T
);
2939 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2942 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2944 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2947 if (!SCM_SMOB_APPLICABLE_P (proc
))
2949 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2953 proc
= SCM_CCLO_SUBR (proc
);
2955 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2956 debug
.info
->a
.proc
= proc
;
2960 proc
= SCM_PROCEDURE (proc
);
2962 debug
.info
->a
.proc
= proc
;
2964 if (!SCM_CLOSUREP (proc
))
2966 if (scm_badformalsp (proc
, 1))
2967 goto umwrongnumargs
;
2968 case scm_tcs_closures
:
2970 x
= SCM_CLOSURE_BODY (proc
);
2972 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2974 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2976 goto nontoplevel_begin
;
2977 case scm_tcs_struct
:
2978 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2980 x
= SCM_ENTITY_PROCEDURE (proc
);
2982 arg1
= debug
.info
->a
.args
;
2984 arg1
= scm_list_1 (arg1
);
2988 else if (!SCM_I_OPERATORP (proc
))
2994 proc
= (SCM_I_ENTITYP (proc
)
2995 ? SCM_ENTITY_PROCEDURE (proc
)
2996 : SCM_OPERATOR_PROCEDURE (proc
));
2998 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2999 debug
.info
->a
.proc
= proc
;
3001 if (SCM_NIMP (proc
))
3006 case scm_tc7_subr_2
:
3007 case scm_tc7_subr_0
:
3008 case scm_tc7_subr_3
:
3009 case scm_tc7_lsubr_2
:
3010 scm_wrong_num_args (proc
);
3016 arg2
= EVALCAR (x
, env
);
3018 scm_wrong_num_args (proc
);
3020 { /* have two or more arguments */
3022 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3025 if (SCM_NULLP (x
)) {
3028 switch (SCM_TYP7 (proc
))
3029 { /* have two arguments */
3030 case scm_tc7_subr_2
:
3031 case scm_tc7_subr_2o
:
3032 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3035 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3037 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3039 case scm_tc7_lsubr_2
:
3040 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3041 case scm_tc7_rpsubr
:
3043 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3045 if (!SCM_SMOB_APPLICABLE_P (proc
))
3047 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3051 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3052 scm_cons (proc
, debug
.info
->a
.args
),
3055 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3056 scm_cons2 (proc
, arg1
,
3063 case scm_tcs_struct
:
3064 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3066 x
= SCM_ENTITY_PROCEDURE (proc
);
3068 arg1
= debug
.info
->a
.args
;
3070 arg1
= scm_list_2 (arg1
, arg2
);
3074 else if (!SCM_I_OPERATORP (proc
))
3080 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3081 ? SCM_ENTITY_PROCEDURE (proc
)
3082 : SCM_OPERATOR_PROCEDURE (proc
),
3083 scm_cons (proc
, debug
.info
->a
.args
),
3086 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3087 ? SCM_ENTITY_PROCEDURE (proc
)
3088 : SCM_OPERATOR_PROCEDURE (proc
),
3089 scm_cons2 (proc
, arg1
,
3097 case scm_tc7_subr_0
:
3099 case scm_tc7_subr_1o
:
3100 case scm_tc7_subr_1
:
3101 case scm_tc7_subr_3
:
3102 scm_wrong_num_args (proc
);
3106 proc
= SCM_PROCEDURE (proc
);
3108 debug
.info
->a
.proc
= proc
;
3110 if (!SCM_CLOSUREP (proc
))
3112 if (scm_badformalsp (proc
, 2))
3113 goto umwrongnumargs
;
3114 case scm_tcs_closures
:
3117 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3121 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3122 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3124 x
= SCM_CLOSURE_BODY (proc
);
3125 goto nontoplevel_begin
;
3129 scm_wrong_num_args (proc
);
3131 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3132 deval_args (x
, env
, proc
,
3133 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3137 switch (SCM_TYP7 (proc
))
3138 { /* have 3 or more arguments */
3140 case scm_tc7_subr_3
:
3141 if (!SCM_NULLP (SCM_CDR (x
)))
3142 scm_wrong_num_args (proc
);
3144 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3145 SCM_CADDR (debug
.info
->a
.args
)));
3147 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3148 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3151 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3152 arg2
= SCM_CDR (arg2
);
3154 while (SCM_NIMP (arg2
));
3156 case scm_tc7_rpsubr
:
3157 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3158 RETURN (SCM_BOOL_F
);
3159 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3162 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3163 RETURN (SCM_BOOL_F
);
3164 arg2
= SCM_CAR (arg1
);
3165 arg1
= SCM_CDR (arg1
);
3167 while (SCM_NIMP (arg1
));
3168 RETURN (SCM_BOOL_T
);
3169 case scm_tc7_lsubr_2
:
3170 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3171 SCM_CDDR (debug
.info
->a
.args
)));
3173 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3175 if (!SCM_SMOB_APPLICABLE_P (proc
))
3177 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3178 SCM_CDDR (debug
.info
->a
.args
)));
3182 proc
= SCM_PROCEDURE (proc
);
3183 debug
.info
->a
.proc
= proc
;
3184 if (!SCM_CLOSUREP (proc
))
3186 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3187 goto umwrongnumargs
;
3188 case scm_tcs_closures
:
3189 SCM_SET_ARGSREADY (debug
);
3190 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3193 x
= SCM_CLOSURE_BODY (proc
);
3194 goto nontoplevel_begin
;
3196 case scm_tc7_subr_3
:
3197 if (!SCM_NULLP (SCM_CDR (x
)))
3198 scm_wrong_num_args (proc
);
3200 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3202 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3205 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3208 while (SCM_NIMP (x
));
3210 case scm_tc7_rpsubr
:
3211 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3212 RETURN (SCM_BOOL_F
);
3215 arg1
= EVALCAR (x
, env
);
3216 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3217 RETURN (SCM_BOOL_F
);
3221 while (SCM_NIMP (x
));
3222 RETURN (SCM_BOOL_T
);
3223 case scm_tc7_lsubr_2
:
3224 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3226 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3228 scm_eval_args (x
, env
, proc
))));
3230 if (!SCM_SMOB_APPLICABLE_P (proc
))
3232 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3233 scm_eval_args (x
, env
, proc
)));
3237 proc
= SCM_PROCEDURE (proc
);
3238 if (!SCM_CLOSUREP (proc
))
3241 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3242 if (SCM_NULLP (formals
)
3243 || (SCM_CONSP (formals
)
3244 && (SCM_NULLP (SCM_CDR (formals
))
3245 || (SCM_CONSP (SCM_CDR (formals
))
3246 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3247 goto umwrongnumargs
;
3249 case scm_tcs_closures
:
3251 SCM_SET_ARGSREADY (debug
);
3253 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3256 scm_eval_args (x
, env
, proc
)),
3258 x
= SCM_CLOSURE_BODY (proc
);
3259 goto nontoplevel_begin
;
3261 case scm_tcs_struct
:
3262 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3265 arg1
= debug
.info
->a
.args
;
3267 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3269 x
= SCM_ENTITY_PROCEDURE (proc
);
3272 else if (!SCM_I_OPERATORP (proc
))
3276 case scm_tc7_subr_2
:
3277 case scm_tc7_subr_1o
:
3278 case scm_tc7_subr_2o
:
3279 case scm_tc7_subr_0
:
3281 case scm_tc7_subr_1
:
3282 scm_wrong_num_args (proc
);
3290 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3291 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3293 SCM_CLEAR_TRACED_FRAME (debug
);
3294 if (SCM_CHEAPTRAPS_P
)
3295 arg1
= scm_make_debugobj (&debug
);
3299 SCM val
= scm_make_continuation (&first
);
3310 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3314 scm_last_debug_frame
= debug
.prev
;
3320 /* SECTION: This code is compiled once.
3326 /* Simple procedure calls
3330 scm_call_0 (SCM proc
)
3332 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3336 scm_call_1 (SCM proc
, SCM arg1
)
3338 return scm_apply (proc
, arg1
, scm_listofnull
);
3342 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3344 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3348 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3350 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3354 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3356 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3357 scm_cons (arg4
, scm_listofnull
)));
3360 /* Simple procedure applies
3364 scm_apply_0 (SCM proc
, SCM args
)
3366 return scm_apply (proc
, args
, SCM_EOL
);
3370 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3372 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3376 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3378 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3382 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3384 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3388 /* This code processes the arguments to apply:
3390 (apply PROC ARG1 ... ARGS)
3392 Given a list (ARG1 ... ARGS), this function conses the ARG1
3393 ... arguments onto the front of ARGS, and returns the resulting
3394 list. Note that ARGS is a list; thus, the argument to this
3395 function is a list whose last element is a list.
3397 Apply calls this function, and applies PROC to the elements of the
3398 result. apply:nconc2last takes care of building the list of
3399 arguments, given (ARG1 ... ARGS).
3401 Rather than do new consing, apply:nconc2last destroys its argument.
3402 On that topic, this code came into my care with the following
3403 beautifully cryptic comment on that topic: "This will only screw
3404 you if you do (scm_apply scm_apply '( ... ))" If you know what
3405 they're referring to, send me a patch to this comment. */
3407 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3409 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3410 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3411 "@var{args}, and returns the resulting list. Note that\n"
3412 "@var{args} is a list; thus, the argument to this function is\n"
3413 "a list whose last element is a list.\n"
3414 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3415 "destroys its argument, so use with care.")
3416 #define FUNC_NAME s_scm_nconc2last
3419 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3421 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3422 SCM_NULL_OR_NIL_P, but not
3423 needed in 99.99% of cases,
3424 and it could seriously hurt
3425 performance. - Neil */
3426 lloc
= SCM_CDRLOC (*lloc
);
3427 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3428 *lloc
= SCM_CAR (*lloc
);
3436 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3437 * It is compiled twice.
3442 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3448 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3453 /* Apply a function to a list of arguments.
3455 This function is exported to the Scheme level as taking two
3456 required arguments and a tail argument, as if it were:
3457 (lambda (proc arg1 . args) ...)
3458 Thus, if you just have a list of arguments to pass to a procedure,
3459 pass the list as ARG1, and '() for ARGS. If you have some fixed
3460 args, pass the first as ARG1, then cons any remaining fixed args
3461 onto the front of your argument list, and pass that as ARGS. */
3464 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3466 #ifdef DEBUG_EXTENSIONS
3468 scm_t_debug_frame debug
;
3469 scm_t_debug_info debug_vect_body
;
3470 debug
.prev
= scm_last_debug_frame
;
3471 debug
.status
= SCM_APPLYFRAME
;
3472 debug
.vect
= &debug_vect_body
;
3473 debug
.vect
[0].a
.proc
= proc
;
3474 debug
.vect
[0].a
.args
= SCM_EOL
;
3475 scm_last_debug_frame
= &debug
;
3478 return scm_dapply (proc
, arg1
, args
);
3482 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3484 /* If ARGS is the empty list, then we're calling apply with only two
3485 arguments --- ARG1 is the list of arguments for PROC. Whatever
3486 the case, futz with things so that ARG1 is the first argument to
3487 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3490 Setting the debug apply frame args this way is pretty messy.
3491 Perhaps we should store arg1 and args directly in the frame as
3492 received, and let scm_frame_arguments unpack them, because that's
3493 a relatively rare operation. This works for now; if the Guile
3494 developer archives are still around, see Mikael's post of
3496 if (SCM_NULLP (args
))
3498 if (SCM_NULLP (arg1
))
3500 arg1
= SCM_UNDEFINED
;
3502 debug
.vect
[0].a
.args
= SCM_EOL
;
3508 debug
.vect
[0].a
.args
= arg1
;
3510 args
= SCM_CDR (arg1
);
3511 arg1
= SCM_CAR (arg1
);
3516 args
= scm_nconc2last (args
);
3518 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3522 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3525 if (SCM_CHEAPTRAPS_P
)
3526 tmp
= scm_make_debugobj (&debug
);
3531 tmp
= scm_make_continuation (&first
);
3536 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3543 switch (SCM_TYP7 (proc
))
3545 case scm_tc7_subr_2o
:
3546 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3547 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3548 case scm_tc7_subr_2
:
3549 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3550 scm_wrong_num_args (proc
);
3551 args
= SCM_CAR (args
);
3552 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3553 case scm_tc7_subr_0
:
3554 if (!SCM_UNBNDP (arg1
))
3555 scm_wrong_num_args (proc
);
3557 RETURN (SCM_SUBRF (proc
) ());
3558 case scm_tc7_subr_1
:
3559 if (SCM_UNBNDP (arg1
))
3560 scm_wrong_num_args (proc
);
3561 case scm_tc7_subr_1o
:
3562 if (!SCM_NULLP (args
))
3563 scm_wrong_num_args (proc
);
3565 RETURN (SCM_SUBRF (proc
) (arg1
));
3567 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3568 scm_wrong_num_args (proc
);
3569 if (SCM_SUBRF (proc
))
3571 if (SCM_INUMP (arg1
))
3573 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3575 else if (SCM_REALP (arg1
))
3577 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3580 else if (SCM_BIGP (arg1
))
3581 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3583 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3584 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3586 proc
= SCM_SNAME (proc
);
3588 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3589 while ('c' != *--chrs
)
3591 SCM_ASSERT (SCM_CONSP (arg1
),
3592 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3593 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3597 case scm_tc7_subr_3
:
3598 if (SCM_NULLP (args
)
3599 || SCM_NULLP (SCM_CDR (args
))
3600 || !SCM_NULLP (SCM_CDDR (args
)))
3601 scm_wrong_num_args (proc
);
3603 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3606 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3608 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3610 case scm_tc7_lsubr_2
:
3611 if (!SCM_CONSP (args
))
3612 scm_wrong_num_args (proc
);
3614 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3616 if (SCM_NULLP (args
))
3617 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3618 while (SCM_NIMP (args
))
3620 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3621 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3622 args
= SCM_CDR (args
);
3625 case scm_tc7_rpsubr
:
3626 if (SCM_NULLP (args
))
3627 RETURN (SCM_BOOL_T
);
3628 while (SCM_NIMP (args
))
3630 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3631 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3632 RETURN (SCM_BOOL_F
);
3633 arg1
= SCM_CAR (args
);
3634 args
= SCM_CDR (args
);
3636 RETURN (SCM_BOOL_T
);
3637 case scm_tcs_closures
:
3639 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3641 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3643 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3644 scm_wrong_num_args (proc
);
3646 /* Copy argument list */
3651 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3652 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3654 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3658 SCM_SETCDR (tl
, arg1
);
3661 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3662 proc
= SCM_CLOSURE_BODY (proc
);
3665 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3667 if (SCM_IMP (SCM_CAR (proc
)))
3669 if (SCM_ISYMP (SCM_CAR (proc
)))
3671 scm_rec_mutex_lock (&source_mutex
);
3672 /* check for race condition */
3673 if (SCM_ISYMP (SCM_CAR (proc
)))
3674 proc
= scm_m_expand_body (proc
, args
);
3675 scm_rec_mutex_unlock (&source_mutex
);
3679 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3682 SCM_CEVAL (SCM_CAR (proc
), args
);
3685 RETURN (EVALCAR (proc
, args
));
3687 if (!SCM_SMOB_APPLICABLE_P (proc
))
3689 if (SCM_UNBNDP (arg1
))
3690 RETURN (SCM_SMOB_APPLY_0 (proc
));
3691 else if (SCM_NULLP (args
))
3692 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3693 else if (SCM_NULLP (SCM_CDR (args
)))
3694 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3696 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3699 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3701 proc
= SCM_CCLO_SUBR (proc
);
3702 debug
.vect
[0].a
.proc
= proc
;
3703 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3705 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3707 proc
= SCM_CCLO_SUBR (proc
);
3711 proc
= SCM_PROCEDURE (proc
);
3713 debug
.vect
[0].a
.proc
= proc
;
3716 case scm_tcs_struct
:
3717 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3720 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3722 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3724 RETURN (scm_apply_generic (proc
, args
));
3726 else if (!SCM_I_OPERATORP (proc
))
3732 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3734 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3737 proc
= (SCM_I_ENTITYP (proc
)
3738 ? SCM_ENTITY_PROCEDURE (proc
)
3739 : SCM_OPERATOR_PROCEDURE (proc
));
3741 debug
.vect
[0].a
.proc
= proc
;
3742 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3744 if (SCM_NIMP (proc
))
3751 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3755 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3756 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3758 SCM_CLEAR_TRACED_FRAME (debug
);
3759 if (SCM_CHEAPTRAPS_P
)
3760 arg1
= scm_make_debugobj (&debug
);
3764 SCM val
= scm_make_continuation (&first
);
3775 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3779 scm_last_debug_frame
= debug
.prev
;
3785 /* SECTION: The rest of this file is only read once.
3792 * Trampolines make it possible to move procedure application dispatch
3793 * outside inner loops. The motivation was clean implementation of
3794 * efficient replacements of R5RS primitives in SRFI-1.
3796 * The semantics is clear: scm_trampoline_N returns an optimized
3797 * version of scm_call_N (or NULL if the procedure isn't applicable
3800 * Applying the optimization to map and for-each increased efficiency
3801 * noticeably. For example, (map abs ls) is now 8 times faster than
3806 call_subr1_1 (SCM proc
, SCM arg1
)
3808 return SCM_SUBRF (proc
) (arg1
);
3812 call_subr2o_1 (SCM proc
, SCM arg1
)
3814 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3818 call_lsubr_1 (SCM proc
, SCM arg1
)
3820 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3824 call_dsubr_1 (SCM proc
, SCM arg1
)
3826 if (SCM_INUMP (arg1
))
3828 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3830 else if (SCM_REALP (arg1
))
3832 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3835 else if (SCM_BIGP (arg1
))
3836 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3838 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3839 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3843 call_cxr_1 (SCM proc
, SCM arg1
)
3845 proc
= SCM_SNAME (proc
);
3847 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3848 while ('c' != *--chrs
)
3850 SCM_ASSERT (SCM_CONSP (arg1
),
3851 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3852 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3859 call_closure_1 (SCM proc
, SCM arg1
)
3861 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3862 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3868 scm_trampoline_1 (SCM proc
)
3874 switch (SCM_TYP7 (proc
))
3876 case scm_tc7_subr_1
:
3877 case scm_tc7_subr_1o
:
3878 return call_subr1_1
;
3879 case scm_tc7_subr_2o
:
3880 return call_subr2o_1
;
3882 return call_lsubr_1
;
3884 if (SCM_SUBRF (proc
))
3885 return call_dsubr_1
;
3888 case scm_tcs_closures
:
3890 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3891 if (!SCM_CONSP (formals
) || SCM_NULLP (SCM_CDR (formals
)))
3892 return call_closure_1
;
3896 case scm_tcs_struct
:
3897 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3898 return scm_call_generic_1
;
3899 else if (!SCM_I_OPERATORP (proc
))
3903 if (SCM_SMOB_APPLICABLE_P (proc
))
3904 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
3909 case scm_tc7_rpsubr
:
3914 return 0; /* not applicable on one arg */
3919 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3921 return SCM_SUBRF (proc
) (arg1
, arg2
);
3925 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
3927 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
3931 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
3933 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
3937 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
3939 return scm_eval_body (SCM_CLOSURE_BODY (proc
),
3940 SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3941 scm_list_2 (arg1
, arg2
),
3946 scm_trampoline_2 (SCM proc
)
3952 switch (SCM_TYP7 (proc
))
3954 case scm_tc7_subr_2
:
3955 case scm_tc7_subr_2o
:
3956 case scm_tc7_rpsubr
:
3958 return call_subr2_2
;
3959 case scm_tc7_lsubr_2
:
3960 return call_lsubr2_2
;
3962 return call_lsubr_2
;
3963 case scm_tcs_closures
:
3965 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3966 if (!SCM_CONSP (formals
)
3967 || (SCM_CONSP (SCM_CDR (formals
))
3968 && SCM_NULLP (SCM_CDDR (formals
))))
3969 return call_closure_2
;
3973 case scm_tcs_struct
:
3974 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3975 return scm_call_generic_2
;
3976 else if (!SCM_I_OPERATORP (proc
))
3980 if (SCM_SMOB_APPLICABLE_P (proc
))
3981 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
3989 return 0; /* not applicable on two args */
3993 /* Typechecking for multi-argument MAP and FOR-EACH.
3995 Verify that each element of the vector ARGV, except for the first,
3996 is a proper list whose length is LEN. Attribute errors to WHO,
3997 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3999 check_map_args (SCM argv
,
4006 SCM
const *ve
= SCM_VELTS (argv
);
4009 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4011 long elt_len
= scm_ilength (ve
[i
]);
4016 scm_apply_generic (gf
, scm_cons (proc
, args
));
4018 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4022 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4025 scm_remember_upto_here_1 (argv
);
4029 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4031 /* Note: Currently, scm_map applies PROC to the argument list(s)
4032 sequentially, starting with the first element(s). This is used in
4033 evalext.c where the Scheme procedure `map-in-order', which guarantees
4034 sequential behaviour, is implemented using scm_map. If the
4035 behaviour changes, we need to update `map-in-order'.
4039 scm_map (SCM proc
, SCM arg1
, SCM args
)
4040 #define FUNC_NAME s_map
4045 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4047 len
= scm_ilength (arg1
);
4048 SCM_GASSERTn (len
>= 0,
4049 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4050 SCM_VALIDATE_REST_ARGUMENT (args
);
4051 if (SCM_NULLP (args
))
4053 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4054 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4055 while (SCM_NIMP (arg1
))
4057 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4058 pres
= SCM_CDRLOC (*pres
);
4059 arg1
= SCM_CDR (arg1
);
4063 if (SCM_NULLP (SCM_CDR (args
)))
4065 SCM arg2
= SCM_CAR (args
);
4066 int len2
= scm_ilength (arg2
);
4067 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4069 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4070 SCM_GASSERTn (len2
>= 0,
4071 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4073 SCM_OUT_OF_RANGE (3, arg2
);
4074 while (SCM_NIMP (arg1
))
4076 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4077 pres
= SCM_CDRLOC (*pres
);
4078 arg1
= SCM_CDR (arg1
);
4079 arg2
= SCM_CDR (arg2
);
4083 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4084 ve
= SCM_VELTS (args
);
4085 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4089 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4091 if (SCM_IMP (ve
[i
]))
4093 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4094 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4096 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4097 pres
= SCM_CDRLOC (*pres
);
4103 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4106 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4107 #define FUNC_NAME s_for_each
4109 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4111 len
= scm_ilength (arg1
);
4112 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4113 SCM_ARG2
, s_for_each
);
4114 SCM_VALIDATE_REST_ARGUMENT (args
);
4115 if (SCM_NULLP (args
))
4117 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4118 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4119 while (SCM_NIMP (arg1
))
4121 call (proc
, SCM_CAR (arg1
));
4122 arg1
= SCM_CDR (arg1
);
4124 return SCM_UNSPECIFIED
;
4126 if (SCM_NULLP (SCM_CDR (args
)))
4128 SCM arg2
= SCM_CAR (args
);
4129 int len2
= scm_ilength (arg2
);
4130 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4131 SCM_GASSERTn (call
, g_for_each
,
4132 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4133 SCM_GASSERTn (len2
>= 0, g_for_each
,
4134 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4136 SCM_OUT_OF_RANGE (3, arg2
);
4137 while (SCM_NIMP (arg1
))
4139 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4140 arg1
= SCM_CDR (arg1
);
4141 arg2
= SCM_CDR (arg2
);
4143 return SCM_UNSPECIFIED
;
4145 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
4146 ve
= SCM_VELTS (args
);
4147 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4151 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4153 if (SCM_IMP (ve
[i
]))
4154 return SCM_UNSPECIFIED
;
4155 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4156 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4158 scm_apply (proc
, arg1
, SCM_EOL
);
4165 scm_closure (SCM code
, SCM env
)
4168 SCM closcar
= scm_cons (code
, SCM_EOL
);
4169 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4170 scm_remember_upto_here (closcar
);
4175 scm_t_bits scm_tc16_promise
;
4178 scm_makprom (SCM code
)
4180 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4182 scm_make_rec_mutex ());
4186 promise_free (SCM promise
)
4188 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4193 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4195 int writingp
= SCM_WRITINGP (pstate
);
4196 scm_puts ("#<promise ", port
);
4197 SCM_SET_WRITINGP (pstate
, 1);
4198 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4199 SCM_SET_WRITINGP (pstate
, writingp
);
4200 scm_putc ('>', port
);
4204 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4206 "If the promise @var{x} has not been computed yet, compute and\n"
4207 "return @var{x}, otherwise just return the previously computed\n"
4209 #define FUNC_NAME s_scm_force
4211 SCM_VALIDATE_SMOB (1, promise
, promise
);
4212 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4213 if (!SCM_PROMISE_COMPUTED_P (promise
))
4215 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4216 if (!SCM_PROMISE_COMPUTED_P (promise
))
4218 SCM_SET_PROMISE_DATA (promise
, ans
);
4219 SCM_SET_PROMISE_COMPUTED (promise
);
4222 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4223 return SCM_PROMISE_DATA (promise
);
4228 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4230 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4231 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4232 #define FUNC_NAME s_scm_promise_p
4234 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4239 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4240 (SCM xorig
, SCM x
, SCM y
),
4241 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4242 "Any source properties associated with @var{xorig} are also associated\n"
4243 "with the new pair.")
4244 #define FUNC_NAME s_scm_cons_source
4247 z
= scm_cons (x
, y
);
4248 /* Copy source properties possibly associated with xorig. */
4249 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4251 scm_whash_insert (scm_source_whash
, z
, p
);
4257 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4259 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4260 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4261 "contents of both pairs and vectors (since both cons cells and vector\n"
4262 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4263 "any other object.")
4264 #define FUNC_NAME s_scm_copy_tree
4269 if (SCM_VECTORP (obj
))
4271 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4272 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4274 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4277 if (!SCM_CONSP (obj
))
4279 ans
= tl
= scm_cons_source (obj
,
4280 scm_copy_tree (SCM_CAR (obj
)),
4282 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4284 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4288 SCM_SETCDR (tl
, obj
);
4294 /* We have three levels of EVAL here:
4296 - scm_i_eval (exp, env)
4298 evaluates EXP in environment ENV. ENV is a lexical environment
4299 structure as used by the actual tree code evaluator. When ENV is
4300 a top-level environment, then changes to the current module are
4301 tracked by updating ENV so that it continues to be in sync with
4304 - scm_primitive_eval (exp)
4306 evaluates EXP in the top-level environment as determined by the
4307 current module. This is done by constructing a suitable
4308 environment and calling scm_i_eval. Thus, changes to the
4309 top-level module are tracked normally.
4311 - scm_eval (exp, mod)
4313 evaluates EXP while MOD is the current module. This is done by
4314 setting the current module to MOD, invoking scm_primitive_eval on
4315 EXP, and then restoring the current module to the value it had
4316 previously. That is, while EXP is evaluated, changes to the
4317 current module are tracked, but these changes do not persist when
4320 For each level of evals, there are two variants, distinguished by a
4321 _x suffix: the ordinary variant does not modify EXP while the _x
4322 variant can destructively modify EXP into something completely
4323 unintelligible. A Scheme data structure passed as EXP to one of the
4324 _x variants should not ever be used again for anything. So when in
4325 doubt, use the ordinary variant.
4330 scm_i_eval_x (SCM exp
, SCM env
)
4332 return SCM_XEVAL (exp
, env
);
4336 scm_i_eval (SCM exp
, SCM env
)
4338 exp
= scm_copy_tree (exp
);
4339 return SCM_XEVAL (exp
, env
);
4343 scm_primitive_eval_x (SCM exp
)
4346 SCM transformer
= scm_current_module_transformer ();
4347 if (SCM_NIMP (transformer
))
4348 exp
= scm_call_1 (transformer
, exp
);
4349 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4350 return scm_i_eval_x (exp
, env
);
4353 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4355 "Evaluate @var{exp} in the top-level environment specified by\n"
4356 "the current module.")
4357 #define FUNC_NAME s_scm_primitive_eval
4360 SCM transformer
= scm_current_module_transformer ();
4361 if (SCM_NIMP (transformer
))
4362 exp
= scm_call_1 (transformer
, exp
);
4363 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4364 return scm_i_eval (exp
, env
);
4368 /* Eval does not take the second arg optionally. This is intentional
4369 * in order to be R5RS compatible, and to prepare for the new module
4370 * system, where we would like to make the choice of evaluation
4371 * environment explicit. */
4374 change_environment (void *data
)
4376 SCM pair
= SCM_PACK (data
);
4377 SCM new_module
= SCM_CAR (pair
);
4378 SCM old_module
= scm_current_module ();
4379 SCM_SETCDR (pair
, old_module
);
4380 scm_set_current_module (new_module
);
4385 restore_environment (void *data
)
4387 SCM pair
= SCM_PACK (data
);
4388 SCM old_module
= SCM_CDR (pair
);
4389 SCM new_module
= scm_current_module ();
4390 SCM_SETCAR (pair
, new_module
);
4391 scm_set_current_module (old_module
);
4395 inner_eval_x (void *data
)
4397 return scm_primitive_eval_x (SCM_PACK(data
));
4401 scm_eval_x (SCM exp
, SCM module
)
4402 #define FUNC_NAME "eval!"
4404 SCM_VALIDATE_MODULE (2, module
);
4406 return scm_internal_dynamic_wind
4407 (change_environment
, inner_eval_x
, restore_environment
,
4408 (void *) SCM_UNPACK (exp
),
4409 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4414 inner_eval (void *data
)
4416 return scm_primitive_eval (SCM_PACK(data
));
4419 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4420 (SCM exp
, SCM module
),
4421 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4422 "in the top-level environment specified by @var{module}.\n"
4423 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4424 "@var{module} is made the current module. The current module\n"
4425 "is reset to its previous value when @var{eval} returns.")
4426 #define FUNC_NAME s_scm_eval
4428 SCM_VALIDATE_MODULE (2, module
);
4430 return scm_internal_dynamic_wind
4431 (change_environment
, inner_eval
, restore_environment
,
4432 (void *) SCM_UNPACK (exp
),
4433 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4438 /* At this point, scm_deval and scm_dapply are generated.
4441 #ifdef DEBUG_EXTENSIONS
4451 scm_init_opts (scm_evaluator_traps
,
4452 scm_evaluator_trap_table
,
4453 SCM_N_EVALUATOR_TRAPS
);
4454 scm_init_opts (scm_eval_options_interface
,
4456 SCM_N_EVAL_OPTIONS
);
4458 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4459 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4460 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4461 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4463 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4464 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4465 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4466 scm_listofnull
= scm_list_1 (SCM_EOL
);
4468 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4473 #include "libguile/eval.x"
4475 scm_add_feature ("delay");