1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This file is read twice in order to produce debugging versions of
21 * scm_ceval and scm_apply. These functions, scm_deval and
22 * scm_dapply, are produced when we define the preprocessor macro
23 * DEVAL. The file is divided into sections which are treated
24 * differently with respect to DEVAL. The heads of these sections are
25 * marked with the string "SECTION:".
28 /* SECTION: This code is compiled once.
35 #include "libguile/__scm.h"
39 /* AIX requires this to be the first thing in the file. The #pragma
40 directive is indented so pre-ANSI compilers will ignore it, rather
49 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/debug.h"
58 #include "libguile/dynwind.h"
59 #include "libguile/alist.h"
60 #include "libguile/eq.h"
61 #include "libguile/continuations.h"
62 #include "libguile/futures.h"
63 #include "libguile/throw.h"
64 #include "libguile/smob.h"
65 #include "libguile/macros.h"
66 #include "libguile/procprop.h"
67 #include "libguile/hashtab.h"
68 #include "libguile/hash.h"
69 #include "libguile/srcprop.h"
70 #include "libguile/stackchk.h"
71 #include "libguile/objects.h"
72 #include "libguile/async.h"
73 #include "libguile/feature.h"
74 #include "libguile/modules.h"
75 #include "libguile/ports.h"
76 #include "libguile/root.h"
77 #include "libguile/vectors.h"
78 #include "libguile/fluids.h"
79 #include "libguile/goops.h"
80 #include "libguile/values.h"
82 #include "libguile/validate.h"
83 #include "libguile/eval.h"
84 #include "libguile/lang.h"
88 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
90 if (SCM_EQ_P ((x), SCM_EOL)) \
91 scm_misc_error (NULL, s_expression, SCM_EOL); \
96 /* The evaluator contains a plethora of EVAL symbols.
97 * This is an attempt at explanation.
99 * The following macros should be used in code which is read twice
100 * (where the choice of evaluator is hard soldered):
102 * SCM_CEVAL is the symbol used within one evaluator to call itself.
103 * Originally, it is defined to scm_ceval, but is redefined to
104 * scm_deval during the second pass.
106 * SCM_EVALIM is used when it is known that the expression is an
107 * immediate. (This macro never calls an evaluator.)
109 * EVALCAR evaluates the car of an expression.
111 * The following macros should be used in code which is read once
112 * (where the choice of evaluator is dynamic):
114 * SCM_XEVAL takes care of immediates without calling an evaluator. It
115 * then calls scm_ceval *or* scm_deval, depending on the debugging
118 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
119 * depending on the debugging mode.
121 * The main motivation for keeping this plethora is efficiency
122 * together with maintainability (=> locality of code).
125 #define SCM_CEVAL scm_ceval
127 #define SCM_EVALIM2(x) \
128 ((SCM_EQ_P ((x), SCM_EOL) \
129 ? scm_misc_error (NULL, s_expression, SCM_EOL), 0 \
133 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
134 ? *scm_ilookup ((x), env) \
137 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
139 : (*scm_ceval_ptr) ((x), (env)))
141 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
142 ? SCM_EVALIM (SCM_CAR (x), env) \
143 : (SCM_SYMBOLP (SCM_CAR (x)) \
144 ? *scm_lookupcar (x, env, 1) \
145 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
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 SCM_REC_MUTEX (source_mutex
);
156 static const char s_expression
[] = "missing or extra expression";
157 static const char s_test
[] = "bad test";
158 static const char s_body
[] = "bad body";
159 static const char s_bindings
[] = "bad bindings";
160 static const char s_duplicate_bindings
[] = "duplicate bindings";
161 static const char s_variable
[] = "bad variable";
162 static const char s_clauses
[] = "bad or missing clauses";
163 static const char s_formals
[] = "bad formals";
164 static const char s_duplicate_formals
[] = "duplicate formals";
165 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
168 /* Lookup a given local variable in an environment. The local variable is
169 * given as an iloc, that is a triple <frame, binding, last?>, where frame
170 * indicates the relative number of the environment frame (counting upwards
171 * from the innermost environment frame), binding indicates the number of the
172 * binding within the frame, and last? (which is extracted from the iloc using
173 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
174 * very end of the improper list of bindings. */
176 scm_ilookup (SCM iloc
, SCM env
)
178 unsigned int frame_nr
= SCM_IFRAME (iloc
);
179 unsigned int binding_nr
= SCM_IDIST (iloc
);
183 for (; 0 != frame_nr
; --frame_nr
)
184 frames
= SCM_CDR (frames
);
186 bindings
= SCM_CAR (frames
);
187 for (; 0 != binding_nr
; --binding_nr
)
188 bindings
= SCM_CDR (bindings
);
190 if (SCM_ICDRP (iloc
))
191 return SCM_CDRLOC (bindings
);
192 return SCM_CARLOC (SCM_CDR (bindings
));
196 /* The Lookup Car Race
199 Memoization of variables and special forms is done while executing
200 the code for the first time. As long as there is only one thread
201 everything is fine, but as soon as two threads execute the same
202 code concurrently `for the first time' they can come into conflict.
204 This memoization includes rewriting variable references into more
205 efficient forms and expanding macros. Furthermore, macro expansion
206 includes `compiling' special forms like `let', `cond', etc. into
207 tree-code instructions.
209 There shouldn't normally be a problem with memoizing local and
210 global variable references (into ilocs and variables), because all
211 threads will mutate the code in *exactly* the same way and (if I
212 read the C code correctly) it is not possible to observe a half-way
213 mutated cons cell. The lookup procedure can handle this
214 transparently without any critical sections.
216 It is different with macro expansion, because macro expansion
217 happens outside of the lookup procedure and can't be
218 undone. Therefore the lookup procedure can't cope with it. It has
219 to indicate failure when it detects a lost race and hope that the
220 caller can handle it. Luckily, it turns out that this is the case.
222 An example to illustrate this: Suppose that the following form will
223 be memoized concurrently by two threads
227 Let's first examine the lookup of X in the body. The first thread
228 decides that it has to find the symbol "x" in the environment and
229 starts to scan it. Then the other thread takes over and actually
230 overtakes the first. It looks up "x" and substitutes an
231 appropriate iloc for it. Now the first thread continues and
232 completes its lookup. It comes to exactly the same conclusions as
233 the second one and could - without much ado - just overwrite the
234 iloc with the same iloc.
236 But let's see what will happen when the race occurs while looking
237 up the symbol "let" at the start of the form. It could happen that
238 the second thread interrupts the lookup of the first thread and not
239 only substitutes a variable for it but goes right ahead and
240 replaces it with the compiled form (#@let* (x 12) x). Now, when
241 the first thread completes its lookup, it would replace the #@let*
242 with a variable containing the "let" binding, effectively reverting
243 the form to (let (x 12) x). This is wrong. It has to detect that
244 it has lost the race and the evaluator has to reconsider the
245 changed form completely.
247 This race condition could be resolved with some kind of traffic
248 light (like mutexes) around scm_lookupcar, but I think that it is
249 best to avoid them in this case. They would serialize memoization
250 completely and because lookup involves calling arbitrary Scheme
251 code (via the lookup-thunk), threads could be blocked for an
252 arbitrary amount of time or even deadlock. But with the current
253 solution a lot of unnecessary work is potentially done. */
255 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
256 return NULL to indicate a failed lookup due to some race conditions
257 between threads. This only happens when VLOC is the first cell of
258 a special form that will eventually be memoized (like `let', etc.)
259 In that case the whole lookup is bogus and the caller has to
260 reconsider the complete special form.
262 SCM_LOOKUPCAR is still there, of course. It just calls
263 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
264 should only be called when it is known that VLOC is not the first
265 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
266 for NULL. I think I've found the only places where this
269 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
272 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
275 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
276 register SCM iloc
= SCM_ILOC00
;
277 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
279 if (!SCM_CONSP (SCM_CAR (env
)))
281 al
= SCM_CARLOC (env
);
282 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
286 if (SCM_EQ_P (fl
, var
))
288 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
290 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
291 return SCM_CDRLOC (*al
);
296 al
= SCM_CDRLOC (*al
);
297 if (SCM_EQ_P (SCM_CAR (fl
), var
))
299 if (SCM_UNBNDP (SCM_CAR (*al
)))
304 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
306 SCM_SETCAR (vloc
, iloc
);
307 return SCM_CARLOC (*al
);
309 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
311 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
314 SCM top_thunk
, real_var
;
317 top_thunk
= SCM_CAR (env
); /* env now refers to a
318 top level env thunk */
322 top_thunk
= SCM_BOOL_F
;
323 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
324 if (SCM_FALSEP (real_var
))
327 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
333 scm_error (scm_unbound_variable_key
, NULL
,
334 "Unbound variable: ~S",
335 scm_list_1 (var
), SCM_BOOL_F
);
337 scm_misc_error (NULL
, "Damaged environment: ~S",
342 /* A variable could not be found, but we shall
343 not throw an error. */
344 static SCM undef_object
= SCM_UNDEFINED
;
345 return &undef_object
;
349 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
351 /* Some other thread has changed the very cell we are working
352 on. In effect, it must have done our job or messed it up
355 var
= SCM_CAR (vloc
);
356 if (SCM_VARIABLEP (var
))
357 return SCM_VARIABLE_LOC (var
);
358 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
359 return scm_ilookup (var
, genv
);
360 /* We can't cope with anything else than variables and ilocs. When
361 a special form has been memoized (i.e. `let' into `#@let') we
362 return NULL and expect the calling function to do the right
363 thing. For the evaluator, this means going back and redoing
364 the dispatch on the car of the form. */
368 SCM_SETCAR (vloc
, real_var
);
369 return SCM_VARIABLE_LOC (real_var
);
374 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
376 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
382 #define unmemocar scm_unmemocar
384 SCM_SYMBOL (sym_three_question_marks
, "???");
387 scm_unmemocar (SCM form
, SCM env
)
389 if (!SCM_CONSP (form
))
393 SCM c
= SCM_CAR (form
);
394 if (SCM_VARIABLEP (c
))
396 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
397 if (SCM_FALSEP (sym
))
398 sym
= sym_three_question_marks
;
399 SCM_SETCAR (form
, sym
);
401 else if (SCM_ILOCP (c
))
403 unsigned long int ir
;
405 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
407 env
= SCM_CAAR (env
);
408 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
410 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
418 scm_eval_car (SCM pair
, SCM env
)
420 return SCM_XEVALCAR (pair
, env
);
425 * The following rewrite expressions and
426 * some memoized forms have different syntax
429 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
430 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
431 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
432 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
434 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
435 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
436 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
437 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
440 /* Check that the body denoted by XORIG is valid and rewrite it into
441 its internal form. The internal form of a body is just the body
442 itself, but prefixed with an ISYM that denotes to what kind of
443 outer construct this body belongs. A lambda body starts with
444 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
445 etc. The one exception is a body that belongs to a letrec that has
446 been formed by rewriting internal defines: it starts with
449 /* XXX - Besides controlling the rewriting of internal defines, the
450 additional ISYM could be used for improved error messages.
451 This is not done yet. */
454 scm_m_body (SCM op
, SCM xorig
, const char *what
)
456 SCM_ASSYNT (scm_ilength (xorig
) >= 1, s_body
, what
);
458 /* Don't add another ISYM if one is present already. */
459 if (SCM_ISYMP (SCM_CAR (xorig
)))
462 /* Retain possible doc string. */
463 if (!SCM_CONSP (SCM_CAR (xorig
)))
465 if (!SCM_NULLP (SCM_CDR (xorig
)))
466 return scm_cons (SCM_CAR (xorig
),
467 scm_m_body (op
, SCM_CDR (xorig
), what
));
471 return scm_cons (op
, xorig
);
475 /* Start of the memoizers for the standard R5RS builtin macros. */
478 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
479 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
482 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
484 long len
= scm_ilength (SCM_CDR (xorig
));
485 SCM_ASSYNT (len
>= 0, s_test
, s_and
);
487 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
493 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
494 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
497 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
499 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, s_expression
, s_begin
);
500 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
504 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
505 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
508 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
511 SCM cdrx
= SCM_CDR (xorig
);
512 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, s_clauses
, s_case
);
513 clauses
= SCM_CDR (cdrx
);
514 while (!SCM_NULLP (clauses
))
516 SCM clause
= SCM_CAR (clauses
);
517 SCM_ASSYNT (scm_ilength (clause
) >= 2, s_clauses
, s_case
);
518 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
519 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
520 && SCM_NULLP (SCM_CDR (clauses
))),
522 clauses
= SCM_CDR (clauses
);
524 return scm_cons (SCM_IM_CASE
, cdrx
);
528 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
529 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
532 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
534 SCM cdrx
= SCM_CDR (xorig
);
536 SCM_ASSYNT (scm_ilength (clauses
) >= 1, s_clauses
, s_cond
);
537 while (!SCM_NULLP (clauses
))
539 SCM clause
= SCM_CAR (clauses
);
540 long len
= scm_ilength (clause
);
541 SCM_ASSYNT (len
>= 1, s_clauses
, s_cond
);
542 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
544 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
545 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
547 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
549 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
550 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
552 clauses
= SCM_CDR (clauses
);
554 return scm_cons (SCM_IM_COND
, cdrx
);
558 SCM_SYNTAX(s_define
, "define", scm_i_makbimacro
, scm_m_define
);
559 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
561 /* Guile provides an extension to R5RS' define syntax to represent function
562 * currying in a compact way. With this extension, it is allowed to write
563 * (define <nested-variable> <body>), where <nested-variable> has of one of
564 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
565 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
566 * should be either a sequence of zero or more variables, or a sequence of one
567 * or more variables followed by a space-delimited period and another
568 * variable. Each level of argument nesting wraps the <body> within another
569 * lambda expression. For example, the following forms are allowed, each one
570 * followed by an equivalent, more explicit implementation.
572 * (define ((a b . c) . d) <body>) is equivalent to
573 * (define a (lambda (b . c) (lambda d <body>)))
575 * (define (((a) b) c . d) <body>) is equivalent to
576 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
578 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
579 * module that does not implement this extension. */
581 scm_m_define (SCM x
, SCM env
)
585 SCM_ASSYNT (scm_ilength (x
) >= 2, s_expression
, s_define
);
588 while (SCM_CONSP (name
))
590 /* This while loop realizes function currying by variable nesting. */
591 SCM formals
= SCM_CDR (name
);
592 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
593 name
= SCM_CAR (name
);
595 SCM_ASSYNT (SCM_SYMBOLP (name
), s_variable
, s_define
);
596 SCM_ASSYNT (scm_ilength (x
) == 1, s_expression
, s_define
);
597 if (SCM_TOP_LEVEL (env
))
600 x
= scm_eval_car (x
, env
);
601 if (SCM_REC_PROCNAMES_P
)
604 while (SCM_MACROP (tmp
))
605 tmp
= SCM_MACRO_CODE (tmp
);
606 if (SCM_CLOSUREP (tmp
)
607 /* Only the first definition determines the name. */
608 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
609 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
611 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
612 SCM_VARIABLE_SET (var
, x
);
613 return SCM_UNSPECIFIED
;
616 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
620 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
621 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
623 /* Promises are implemented as closures with an empty parameter list. Thus,
624 * (delay <expression>) is transformed into (#@delay '() <expression>), where
625 * the empty list represents the empty parameter list. This representation
626 * allows for easy creation of the closure during evaluation. */
628 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
630 SCM_ASSYNT (scm_ilength (xorig
) == 2, s_expression
, s_delay
);
631 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
635 /* DO gets the most radically altered syntax. The order of the vars is
636 * reversed here. In contrast, the order of the inits and steps is reversed
637 * during the evaluation:
639 (do ((<var1> <init1> <step1>)
647 (#@do (<init1> <init2> ... <initn>)
651 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
654 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
655 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
658 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
661 SCM x
= SCM_CDR (xorig
);
664 SCM
*initloc
= &inits
;
666 SCM
*steploc
= &steps
;
667 SCM_ASSYNT (scm_ilength (x
) >= 2, s_test
, "do");
668 bindings
= SCM_CAR (x
);
669 SCM_ASSYNT (scm_ilength (bindings
) >= 0, s_bindings
, "do");
670 while (!SCM_NULLP (bindings
))
672 SCM binding
= SCM_CAR (bindings
);
673 long len
= scm_ilength (binding
);
674 SCM_ASSYNT (len
== 2 || len
== 3, s_bindings
, "do");
676 SCM name
= SCM_CAR (binding
);
677 SCM init
= SCM_CADR (binding
);
678 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
679 SCM_ASSYNT (SCM_SYMBOLP (name
), s_variable
, "do");
680 vars
= scm_cons (name
, vars
);
681 *initloc
= scm_list_1 (init
);
682 initloc
= SCM_CDRLOC (*initloc
);
683 *steploc
= scm_list_1 (step
);
684 steploc
= SCM_CDRLOC (*steploc
);
685 bindings
= SCM_CDR (bindings
);
689 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, s_test
, "do");
690 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
691 x
= scm_cons2 (inits
, vars
, x
);
692 return scm_cons (SCM_IM_DO
, x
);
696 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
697 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
700 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
702 long len
= scm_ilength (SCM_CDR (xorig
));
703 SCM_ASSYNT (len
>= 2 && len
<= 3, s_expression
, s_if
);
704 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
708 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
709 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
711 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
712 * cdr of the last cons. (Thus, LIST is not required to be a proper
713 * list and OBJ can also be found in the improper ending.) */
715 scm_c_improper_memq (SCM obj
, SCM list
)
717 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
719 if (SCM_EQ_P (SCM_CAR (list
), obj
))
722 return SCM_EQ_P (list
, obj
);
726 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
729 SCM x
= SCM_CDR (xorig
);
731 SCM_ASSYNT (SCM_CONSP (x
), s_formals
, s_lambda
);
733 formals
= SCM_CAR (x
);
734 while (SCM_CONSP (formals
))
736 SCM formal
= SCM_CAR (formals
);
737 SCM_ASSYNT (SCM_SYMBOLP (formal
), s_formals
, s_lambda
);
738 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
739 scm_misc_error (s_lambda
, s_duplicate_formals
, SCM_EOL
);
740 formals
= SCM_CDR (formals
);
742 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
743 scm_misc_error (s_lambda
, s_formals
, SCM_EOL
);
745 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
746 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
750 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
751 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
752 * reversed here, the list of inits gets reversed during evaluation. */
754 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
760 SCM_ASSYNT (scm_ilength (bindings
) >= 1, s_bindings
, what
);
764 SCM binding
= SCM_CAR (bindings
);
765 SCM_ASSYNT (scm_ilength (binding
) == 2, s_bindings
, what
);
766 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), s_variable
, what
);
767 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
768 scm_misc_error (what
, s_duplicate_bindings
, SCM_EOL
);
769 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
770 *initloc
= scm_list_1 (SCM_CADR (binding
));
771 initloc
= SCM_CDRLOC (*initloc
);
772 bindings
= SCM_CDR (bindings
);
774 while (!SCM_NULLP (bindings
));
780 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
781 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
784 scm_m_let (SCM xorig
, SCM env
)
786 SCM x
= SCM_CDR (xorig
);
789 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_let
);
792 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
794 /* null or single binding, let* is faster */
796 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
797 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
799 else if (SCM_CONSP (temp
))
803 SCM rvars
, inits
, body
;
804 transform_bindings (bindings
, &rvars
, &inits
, "let");
805 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
806 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
810 /* named let: Transform (let name ((var init) ...) body ...) into
811 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
817 SCM
*initloc
= &inits
;
820 SCM_ASSYNT (SCM_SYMBOLP (name
), s_bindings
, s_let
);
822 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_let
);
823 bindings
= SCM_CAR (x
);
824 SCM_ASSYNT (scm_ilength (bindings
) >= 0, s_bindings
, s_let
);
825 while (!SCM_NULLP (bindings
))
826 { /* vars and inits both in order */
827 SCM binding
= SCM_CAR (bindings
);
828 SCM_ASSYNT (scm_ilength (binding
) == 2, s_bindings
, s_let
);
829 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), s_variable
, s_let
);
830 *varloc
= scm_list_1 (SCM_CAR (binding
));
831 varloc
= SCM_CDRLOC (*varloc
);
832 *initloc
= scm_list_1 (SCM_CADR (binding
));
833 initloc
= SCM_CDRLOC (*initloc
);
834 bindings
= SCM_CDR (bindings
);
838 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
839 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
840 SCM rvar
= scm_list_1 (name
);
841 SCM init
= scm_list_1 (lambda_form
);
842 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
843 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
844 return scm_cons (letrec
, inits
);
850 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
851 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
853 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
854 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
856 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
859 SCM x
= SCM_CDR (xorig
);
863 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_letstar
);
865 bindings
= SCM_CAR (x
);
866 SCM_ASSYNT (scm_ilength (bindings
) >= 0, s_bindings
, s_letstar
);
867 while (!SCM_NULLP (bindings
))
869 SCM binding
= SCM_CAR (bindings
);
870 SCM_ASSYNT (scm_ilength (binding
) == 2, s_bindings
, s_letstar
);
871 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), s_variable
, s_letstar
);
872 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
873 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
874 bindings
= SCM_CDR (bindings
);
877 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
878 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
882 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
883 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
886 scm_m_letrec (SCM xorig
, SCM env
)
888 SCM x
= SCM_CDR (xorig
);
889 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_letrec
);
891 if (SCM_NULLP (SCM_CAR (x
)))
893 /* null binding, let* faster */
894 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
895 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
899 SCM rvars
, inits
, body
;
900 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
901 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
902 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
907 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
908 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
911 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
913 long len
= scm_ilength (SCM_CDR (xorig
));
914 SCM_ASSYNT (len
>= 0, s_test
, s_or
);
916 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
922 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
923 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
925 /* Internal function to handle a quasiquotation: 'form' is the parameter in
926 * the call (quasiquotation form), 'env' is the environment where unquoted
927 * expressions will be evaluated, and 'depth' is the current quasiquotation
928 * nesting level and is known to be greater than zero. */
930 iqq (SCM form
, SCM env
, unsigned long int depth
)
932 if (SCM_CONSP (form
))
934 SCM tmp
= SCM_CAR (form
);
935 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
937 SCM args
= SCM_CDR (form
);
938 SCM_ASSYNT (scm_ilength (args
) == 1, s_expression
, s_quasiquote
);
939 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
941 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
943 SCM args
= SCM_CDR (form
);
944 SCM_ASSYNT (scm_ilength (args
) == 1, s_expression
, s_quasiquote
);
946 return scm_eval_car (args
, env
);
948 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
950 else if (SCM_CONSP (tmp
)
951 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
953 SCM args
= SCM_CDR (tmp
);
954 SCM_ASSYNT (scm_ilength (args
) == 1, s_expression
, s_quasiquote
);
957 SCM list
= scm_eval_car (args
, env
);
958 SCM rest
= SCM_CDR (form
);
959 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
960 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
963 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
964 iqq (SCM_CDR (form
), env
, depth
));
967 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
968 iqq (SCM_CDR (form
), env
, depth
));
970 else if (SCM_VECTORP (form
))
972 size_t i
= SCM_VECTOR_LENGTH (form
);
973 SCM
const *const data
= SCM_VELTS (form
);
976 tmp
= scm_cons (data
[--i
], tmp
);
977 scm_remember_upto_here_1 (form
);
978 return scm_vector (iqq (tmp
, env
, depth
));
985 scm_m_quasiquote (SCM xorig
, SCM env
)
987 SCM x
= SCM_CDR (xorig
);
988 SCM_ASSYNT (scm_ilength (x
) == 1, s_expression
, s_quasiquote
);
989 return iqq (SCM_CAR (x
), env
, 1);
993 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
994 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
997 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
999 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, s_expression
, s_quote
);
1000 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
1004 /* Will go into the RnRS module when Guile is factorized.
1005 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1006 static const char s_set_x
[] = "set!";
1007 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1010 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1012 SCM x
= SCM_CDR (xorig
);
1013 SCM_ASSYNT (scm_ilength (x
) == 2, s_expression
, s_set_x
);
1014 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), s_variable
, s_set_x
);
1015 return scm_cons (SCM_IM_SET_X
, x
);
1019 /* Start of the memoizers for non-R5RS builtin macros. */
1022 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1023 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1024 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1027 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1029 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, s_expression
, s_atapply
);
1030 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1034 /* (@bind ((var exp) ...) body ...)
1036 This will assign the values of the `exp's to the global variables
1037 named by `var's (symbols, not evaluated), creating them if they
1038 don't exist, executes body, and then restores the previous values of
1039 the `var's. Additionally, whenever control leaves body, the values
1040 of the `var's are saved and restored when control returns. It is an
1041 error when a symbol appears more than once among the `var's.
1042 All `exp's are evaluated before any `var' is set.
1044 Think of this as `let' for dynamic scope.
1046 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1048 XXX - also implement `@bind*'.
1051 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1054 scm_m_atbind (SCM xorig
, SCM env
)
1056 SCM x
= SCM_CDR (xorig
);
1057 SCM top_level
= scm_env_top_level (env
);
1058 SCM vars
= SCM_EOL
, var
;
1061 SCM_ASSYNT (scm_ilength (x
) > 1, s_expression
, s_atbind
);
1064 while (SCM_NIMP (x
))
1067 SCM sym_exp
= SCM_CAR (x
);
1068 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, s_bindings
, s_atbind
);
1069 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), s_bindings
, s_atbind
);
1071 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1072 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1073 scm_misc_error (s_atbind
, s_duplicate_bindings
, SCM_EOL
);
1074 /* The first call to scm_sym2var will look beyond the current
1075 module, while the second call wont. */
1076 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1077 if (SCM_FALSEP (var
))
1078 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1079 vars
= scm_cons (var
, vars
);
1080 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1082 return scm_cons (SCM_IM_BIND
,
1083 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1088 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1089 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1093 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1095 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1096 s_expression
, s_atcall_cc
);
1097 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1101 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1102 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1105 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1107 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1108 s_expression
, s_at_call_with_values
);
1109 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1113 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1114 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1116 /* Like promises, futures are implemented as closures with an empty
1117 * parameter list. Thus, (future <expression>) is transformed into
1118 * (#@future '() <expression>), where the empty list represents the
1119 * empty parameter list. This representation allows for easy creation
1120 * of the closure during evaluation. */
1122 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
1124 SCM_ASSYNT (scm_ilength (xorig
) == 2, s_expression
, s_future
);
1125 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
1129 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1130 SCM_SYMBOL (scm_sym_setter
, "setter");
1133 scm_m_generalized_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1135 SCM x
= SCM_CDR (xorig
);
1136 SCM_ASSYNT (2 == scm_ilength (x
), s_expression
, s_set_x
);
1137 if (SCM_SYMBOLP (SCM_CAR (x
)))
1138 return scm_cons (SCM_IM_SET_X
, x
);
1139 else if (SCM_CONSP (SCM_CAR (x
)))
1140 return scm_cons (scm_list_2 (scm_sym_setter
, SCM_CAAR (x
)),
1141 scm_append (scm_list_2 (SCM_CDAR (x
), SCM_CDR (x
))));
1143 scm_misc_error (s_set_x
, s_variable
, SCM_EOL
);
1147 static const char* s_atslot_ref
= "@slot-ref";
1149 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1150 * soon as the module system allows us to more freely create bindings in
1151 * arbitrary modules during the startup phase, the code from goops.c should be
1154 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1155 #define FUNC_NAME s_atslot_ref
1157 SCM x
= SCM_CDR (xorig
);
1158 SCM_ASSYNT (scm_ilength (x
) == 2, s_expression
, FUNC_NAME
);
1159 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1160 return scm_cons (SCM_IM_SLOT_REF
, x
);
1165 static const char* s_atslot_set_x
= "@slot-set!";
1167 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1168 * soon as the module system allows us to more freely create bindings in
1169 * arbitrary modules during the startup phase, the code from goops.c should be
1172 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1173 #define FUNC_NAME s_atslot_set_x
1175 SCM x
= SCM_CDR (xorig
);
1176 SCM_ASSYNT (scm_ilength (x
) == 3, s_expression
, FUNC_NAME
);
1177 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1178 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1183 #if SCM_ENABLE_ELISP
1185 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1188 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1190 long len
= scm_ilength (SCM_CDR (xorig
));
1191 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, s_expression
, "nil-cond");
1192 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1196 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1199 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1201 SCM x
= SCM_CDR (xorig
), var
;
1202 SCM_ASSYNT (scm_ilength (x
) >= 1, s_expression
, "@fop");
1203 var
= scm_symbol_fref (SCM_CAR (x
));
1204 /* Passing the symbol name as the `subr' arg here isn't really
1205 right, but without it it can be very difficult to work out from
1206 the error message which function definition was missing. In any
1207 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1208 something equivalent to (signal void-function (list SYM)) in
1210 SCM_ASSYNT (SCM_VARIABLEP (var
),
1211 "Symbol's function definition is void",
1212 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1213 /* Support `defalias'. */
1214 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1216 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1217 SCM_ASSYNT (SCM_VARIABLEP (var
),
1218 "Symbol's function definition is void",
1219 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1221 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1222 former allows for automatically picking up redefinitions of the
1223 corresponding symbol. */
1224 SCM_SETCAR (x
, var
);
1225 /* If the variable contains a procedure, leave the
1226 `transformer-macro' in place so that the procedure's arguments
1227 get properly transformed, and change the initial @fop to
1229 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1231 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1234 /* Otherwise (the variable contains a macro), the arguments should
1235 not be transformed, so cut the `transformer-macro' out and return
1236 the resulting expression starting with the variable. */
1237 SCM_SETCDR (x
, SCM_CDADR (x
));
1241 #endif /* SCM_ENABLE_ELISP */
1244 /* Start of the memoizers for deprecated macros. */
1247 #if (SCM_ENABLE_DEPRECATED == 1)
1249 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1252 scm_m_undefine (SCM x
, SCM env
)
1256 SCM_ASSYNT (SCM_TOP_LEVEL (env
), "bad placement ", s_undefine
);
1257 SCM_ASSYNT (SCM_CONSP (x
) && SCM_NULLP (SCM_CDR (x
)),
1258 s_expression
, s_undefine
);
1260 SCM_ASSYNT (SCM_SYMBOLP (x
), s_variable
, s_undefine
);
1261 arg1
= scm_sym2var (x
, scm_env_top_level (env
), SCM_BOOL_F
);
1262 SCM_ASSYNT (!SCM_FALSEP (arg1
) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1
)),
1263 "variable already unbound ", s_undefine
);
1264 SCM_VARIABLE_SET (arg1
, SCM_UNDEFINED
);
1268 return SCM_UNSPECIFIED
;
1276 scm_m_expand_body (SCM xorig
, SCM env
)
1278 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1279 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1281 while (SCM_NIMP (x
))
1283 SCM form
= SCM_CAR (x
);
1284 if (!SCM_CONSP (form
))
1286 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1289 form
= scm_macroexp (scm_cons_source (form
,
1294 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1296 defs
= scm_cons (SCM_CDR (form
), defs
);
1299 else if (!SCM_IMP (defs
))
1303 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1305 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1309 x
= scm_cons (form
, SCM_CDR (x
));
1314 if (!SCM_NULLP (defs
))
1316 SCM rvars
, inits
, body
, letrec
;
1317 transform_bindings (defs
, &rvars
, &inits
, what
);
1318 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1319 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1320 SCM_SETCAR (xorig
, letrec
);
1321 SCM_SETCDR (xorig
, SCM_EOL
);
1325 SCM_ASSYNT (SCM_CONSP (x
), s_body
, what
);
1326 SCM_SETCAR (xorig
, SCM_CAR (x
));
1327 SCM_SETCDR (xorig
, SCM_CDR (x
));
1334 scm_macroexp (SCM x
, SCM env
)
1336 SCM res
, proc
, orig_sym
;
1338 /* Don't bother to produce error messages here. We get them when we
1339 eventually execute the code for real. */
1342 orig_sym
= SCM_CAR (x
);
1343 if (!SCM_SYMBOLP (orig_sym
))
1347 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1348 if (proc_ptr
== NULL
)
1350 /* We have lost the race. */
1356 /* Only handle memoizing macros. `Acros' and `macros' are really
1357 special forms and should not be evaluated here. */
1359 if (!SCM_MACROP (proc
)
1360 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1363 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1364 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1366 if (scm_ilength (res
) <= 0)
1367 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1370 SCM_SETCAR (x
, SCM_CAR (res
));
1371 SCM_SETCDR (x
, SCM_CDR (res
));
1377 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1379 /* A function object to implement "apply" for non-closure functions. */
1381 /* An endless list consisting of #<undefined> objects: */
1382 static SCM undefineds
;
1384 /* scm_unmemocopy takes a memoized expression together with its
1385 * environment and rewrites it to its original form. Thus, it is the
1386 * inversion of the rewrite rules above. The procedure is not
1387 * optimized for speed. It's used in scm_iprin1 when printing the
1388 * code of a closure, in scm_procedure_source, in display_frame when
1389 * generating the source for a stackframe in a backtrace, and in
1390 * display_expression.
1392 * Unmemoizing is not a reliable process. You cannot in general
1393 * expect to get the original source back.
1395 * However, GOOPS currently relies on this for method compilation.
1396 * This ought to change.
1400 build_binding_list (SCM names
, SCM inits
)
1402 SCM bindings
= SCM_EOL
;
1403 while (!SCM_NULLP (names
))
1405 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1406 bindings
= scm_cons (binding
, bindings
);
1407 names
= SCM_CDR (names
);
1408 inits
= SCM_CDR (inits
);
1414 unmemocopy (SCM x
, SCM env
)
1420 p
= scm_whash_lookup (scm_source_whash
, x
);
1421 switch (SCM_ITAG7 (SCM_CAR (x
)))
1423 case SCM_BIT7 (SCM_IM_AND
):
1424 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1426 case SCM_BIT7 (SCM_IM_BEGIN
):
1427 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1429 case SCM_BIT7 (SCM_IM_CASE
):
1430 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1432 case SCM_BIT7 (SCM_IM_COND
):
1433 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1435 case SCM_BIT7 (SCM_IM_DO
):
1437 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
1438 * where ix is an initializer for a local variable, nx is the name of
1439 * the local variable, test is the test clause of the do loop, body is
1440 * the body of the do loop and sx are the step clauses for the local
1442 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1445 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1447 names
= SCM_CAR (x
);
1448 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1450 test
= unmemocopy (SCM_CAR (x
), env
);
1452 memoized_body
= SCM_CAR (x
);
1454 steps
= scm_reverse (unmemocopy (x
, env
));
1456 /* build transformed binding list */
1458 while (!SCM_NULLP (names
))
1460 SCM name
= SCM_CAR (names
);
1461 SCM init
= SCM_CAR (inits
);
1462 SCM step
= SCM_CAR (steps
);
1463 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1465 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1467 names
= SCM_CDR (names
);
1468 inits
= SCM_CDR (inits
);
1469 steps
= SCM_CDR (steps
);
1471 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1472 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1474 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1477 case SCM_BIT7 (SCM_IM_IF
):
1478 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1480 case SCM_BIT7 (SCM_IM_LET
):
1482 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1483 * where nx is the name of a local variable, ix is an initializer for
1484 * the local variable and by are the body clauses. */
1485 SCM names
, inits
, bindings
;
1488 names
= SCM_CAR (x
);
1490 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1491 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1493 bindings
= build_binding_list (names
, inits
);
1494 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1495 ls
= scm_cons (scm_sym_let
, z
);
1498 case SCM_BIT7 (SCM_IM_LETREC
):
1500 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1501 * where nx is the name of a local variable, ix is an initializer for
1502 * the local variable and by are the body clauses. */
1503 SCM names
, inits
, bindings
;
1506 names
= SCM_CAR (x
);
1507 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1509 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1511 bindings
= build_binding_list (names
, inits
);
1512 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1513 ls
= scm_cons (scm_sym_letrec
, z
);
1516 case SCM_BIT7 (SCM_IM_LETSTAR
):
1524 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1527 y
= z
= scm_acons (SCM_CAR (b
),
1529 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1531 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1535 SCM_SETCDR (y
, SCM_EOL
);
1536 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1537 ls
= scm_cons (scm_sym_let
, z
);
1542 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1544 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1547 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1550 while (SCM_NIMP (b
));
1551 SCM_SETCDR (z
, SCM_EOL
);
1553 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1554 ls
= scm_cons (scm_sym_letstar
, z
);
1557 case SCM_BIT7 (SCM_IM_OR
):
1558 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1560 case SCM_BIT7 (SCM_IM_LAMBDA
):
1562 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1563 ls
= scm_cons (scm_sym_lambda
, z
);
1564 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1566 case SCM_BIT7 (SCM_IM_QUOTE
):
1567 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1569 case SCM_BIT7 (SCM_IM_SET_X
):
1570 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1572 case SCM_BIT7 (SCM_IM_DEFINE
):
1577 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1578 ls
= scm_cons (scm_sym_define
, z
);
1579 if (!SCM_NULLP (env
))
1580 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1585 case SCM_BIT7 (SCM_MAKISYM (0)):
1589 switch (SCM_ISYMNUM (z
))
1591 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1592 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1594 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1595 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1597 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1598 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1601 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1602 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1605 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1606 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1609 /* appease the Sun compiler god: */ ;
1613 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1619 while (SCM_CONSP (x
))
1621 SCM form
= SCM_CAR (x
);
1622 if (!SCM_ISYMP (form
))
1624 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1625 SCM_SETCDR (z
, unmemocar (copy
, env
));
1631 if (!SCM_FALSEP (p
))
1632 scm_whash_insert (scm_source_whash
, ls
, p
);
1638 scm_unmemocopy (SCM x
, SCM env
)
1640 if (!SCM_NULLP (env
))
1641 /* Make a copy of the lowest frame to protect it from
1642 modifications by SCM_IM_DEFINE */
1643 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1645 return unmemocopy (x
, env
);
1650 scm_badargsp (SCM formals
, SCM args
)
1652 while (!SCM_NULLP (formals
))
1654 if (!SCM_CONSP (formals
))
1656 if (SCM_NULLP (args
))
1658 formals
= SCM_CDR (formals
);
1659 args
= SCM_CDR (args
);
1661 return !SCM_NULLP (args
) ? 1 : 0;
1666 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1668 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1669 while (SCM_CONSP (l
))
1671 res
= EVALCAR (l
, env
);
1673 *lloc
= scm_list_1 (res
);
1674 lloc
= SCM_CDRLOC (*lloc
);
1678 scm_wrong_num_args (proc
);
1684 scm_eval_body (SCM code
, SCM env
)
1688 next
= SCM_CDR (code
);
1689 while (!SCM_NULLP (next
))
1691 if (SCM_IMP (SCM_CAR (code
)))
1693 if (SCM_ISYMP (SCM_CAR (code
)))
1695 scm_rec_mutex_lock (&source_mutex
);
1696 /* check for race condition */
1697 if (SCM_ISYMP (SCM_CAR (code
)))
1698 code
= scm_m_expand_body (code
, env
);
1699 scm_rec_mutex_unlock (&source_mutex
);
1704 SCM_XEVAL (SCM_CAR (code
), env
);
1706 next
= SCM_CDR (code
);
1708 return SCM_XEVALCAR (code
, env
);
1714 /* SECTION: This code is specific for the debugging support. One
1715 * branch is read when DEVAL isn't defined, the other when DEVAL is
1721 #define SCM_APPLY scm_apply
1722 #define PREP_APPLY(proc, args)
1724 #define RETURN(x) do { return x; } while (0)
1725 #ifdef STACK_CHECKING
1726 #ifndef NO_CEVAL_STACK_CHECKING
1727 #define EVAL_STACK_CHECKING
1734 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1736 #define SCM_APPLY scm_dapply
1738 #define PREP_APPLY(p, l) \
1739 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1741 #define ENTER_APPLY \
1743 SCM_SET_ARGSREADY (debug);\
1744 if (scm_check_apply_p && SCM_TRAPS_P)\
1745 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1747 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1748 SCM_SET_TRACED_FRAME (debug); \
1750 if (SCM_CHEAPTRAPS_P)\
1752 tmp = scm_make_debugobj (&debug);\
1753 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1758 tmp = scm_make_continuation (&first);\
1760 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1766 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1767 #ifdef STACK_CHECKING
1768 #ifndef EVAL_STACK_CHECKING
1769 #define EVAL_STACK_CHECKING
1773 /* scm_ceval_ptr points to the currently selected evaluator.
1774 * *fixme*: Although efficiency is important here, this state variable
1775 * should probably not be a global. It should be related to the
1780 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1782 /* scm_last_debug_frame contains a pointer to the last debugging
1783 * information stack frame. It is accessed very often from the
1784 * debugging evaluator, so it should probably not be indirectly
1785 * addressed. Better to save and restore it from the current root at
1789 /* scm_debug_eframe_size is the number of slots available for pseudo
1790 * stack frames at each real stack frame.
1793 long scm_debug_eframe_size
;
1795 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1797 long scm_eval_stack
;
1799 scm_t_option scm_eval_opts
[] = {
1800 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1803 scm_t_option scm_debug_opts
[] = {
1804 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1805 "*Flyweight representation of the stack at traps." },
1806 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1807 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1808 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1809 "Record procedure names at definition." },
1810 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1811 "Display backtrace in anti-chronological order." },
1812 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1813 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1814 { SCM_OPTION_INTEGER
, "frames", 3,
1815 "Maximum number of tail-recursive frames in backtrace." },
1816 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1817 "Maximal number of stored backtrace frames." },
1818 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1819 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1820 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1821 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1822 { 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."}
1825 scm_t_option scm_evaluator_trap_table
[] = {
1826 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1827 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1828 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1829 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1830 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1831 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1832 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1835 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1837 "Option interface for the evaluation options. Instead of using\n"
1838 "this procedure directly, use the procedures @code{eval-enable},\n"
1839 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1840 #define FUNC_NAME s_scm_eval_options_interface
1844 ans
= scm_options (setting
,
1848 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1855 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1857 "Option interface for the evaluator trap options.")
1858 #define FUNC_NAME s_scm_evaluator_traps
1862 ans
= scm_options (setting
,
1863 scm_evaluator_trap_table
,
1864 SCM_N_EVALUATOR_TRAPS
,
1866 SCM_RESET_DEBUG_MODE
;
1874 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1876 SCM
*results
= lloc
, res
;
1877 while (SCM_CONSP (l
))
1879 res
= EVALCAR (l
, env
);
1881 *lloc
= scm_list_1 (res
);
1882 lloc
= SCM_CDRLOC (*lloc
);
1886 scm_wrong_num_args (proc
);
1893 /* SECTION: This code is compiled twice.
1897 /* Update the toplevel environment frame ENV so that it refers to the
1898 * current module. */
1899 #define UPDATE_TOPLEVEL_ENV(env) \
1901 SCM p = scm_current_module_lookup_closure (); \
1902 if (p != SCM_CAR (env)) \
1903 env = scm_top_level_env (p); \
1907 /* This is the evaluator. Like any real monster, it has three heads:
1909 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1910 * version. Both are implemented using a common code base, using the
1911 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1912 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1913 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1914 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1915 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1916 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1917 * are enclosed within #ifdef DEVAL ... #endif.
1919 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1920 * take two input parameters, x and env: x is a single expression to be
1921 * evalutated. env is the environment in which bindings are searched.
1923 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1924 * is a single expression, it is necessarily in a tail position. If x is just
1925 * a call to another function like in the expression (foo exp1 exp2 ...), the
1926 * realization of that call therefore _must_not_ increase stack usage (the
1927 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1928 * making extensive use of 'goto' statements within the evaluator: The gotos
1929 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1930 * that SCM_CEVAL was already using. If, however, x represents some form that
1931 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1932 * then recursive calls to SCM_CEVAL are performed for all but the last
1933 * expression of that sequence. */
1937 scm_ceval (SCM x
, SCM env
)
1943 scm_deval (SCM x
, SCM env
)
1948 SCM_CEVAL (SCM x
, SCM env
)
1952 scm_t_debug_frame debug
;
1953 scm_t_debug_info
*debug_info_end
;
1954 debug
.prev
= scm_last_debug_frame
;
1957 * The debug.vect contains twice as much scm_t_debug_info frames as the
1958 * user has specified with (debug-set! frames <n>).
1960 * Even frames are eval frames, odd frames are apply frames.
1962 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1963 * sizeof (scm_t_debug_info
));
1964 debug
.info
= debug
.vect
;
1965 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1966 scm_last_debug_frame
= &debug
;
1968 #ifdef EVAL_STACK_CHECKING
1969 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
1972 debug
.info
->e
.exp
= x
;
1973 debug
.info
->e
.env
= env
;
1975 scm_report_stack_overflow ();
1985 SCM_CLEAR_ARGSREADY (debug
);
1986 if (SCM_OVERFLOWP (debug
))
1989 * In theory, this should be the only place where it is necessary to
1990 * check for space in debug.vect since both eval frames and
1991 * available space are even.
1993 * For this to be the case, however, it is necessary that primitive
1994 * special forms which jump back to `loop', `begin' or some similar
1995 * label call PREP_APPLY.
1997 else if (++debug
.info
>= debug_info_end
)
1999 SCM_SET_OVERFLOW (debug
);
2004 debug
.info
->e
.exp
= x
;
2005 debug
.info
->e
.env
= env
;
2006 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2008 if (SCM_ENTER_FRAME_P
2009 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2012 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2013 SCM_SET_TAILREC (debug
);
2014 if (SCM_CHEAPTRAPS_P
)
2015 stackrep
= scm_make_debugobj (&debug
);
2019 SCM val
= scm_make_continuation (&first
);
2029 /* This gives the possibility for the debugger to
2030 modify the source expression before evaluation. */
2035 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2036 scm_sym_enter_frame
,
2039 scm_unmemocopy (x
, env
));
2046 switch (SCM_TYP7 (x
))
2048 case scm_tc7_symbol
:
2049 /* Only happens when called at top level. */
2050 x
= scm_cons (x
, SCM_UNDEFINED
);
2051 RETURN (*scm_lookupcar (x
, env
, 1));
2053 case SCM_BIT7 (SCM_IM_AND
):
2055 while (!SCM_NULLP (SCM_CDR (x
)))
2057 SCM test_result
= EVALCAR (x
, env
);
2058 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2059 RETURN (SCM_BOOL_F
);
2063 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2066 case SCM_BIT7 (SCM_IM_BEGIN
):
2069 RETURN (SCM_UNSPECIFIED
);
2071 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2074 /* If we are on toplevel with a lookup closure, we need to sync
2075 with the current module. */
2076 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2078 UPDATE_TOPLEVEL_ENV (env
);
2079 while (!SCM_NULLP (SCM_CDR (x
)))
2082 UPDATE_TOPLEVEL_ENV (env
);
2088 goto nontoplevel_begin
;
2091 while (!SCM_NULLP (SCM_CDR (x
)))
2093 SCM form
= SCM_CAR (x
);
2096 if (SCM_ISYMP (form
))
2098 scm_rec_mutex_lock (&source_mutex
);
2099 /* check for race condition */
2100 if (SCM_ISYMP (SCM_CAR (x
)))
2101 x
= scm_m_expand_body (x
, env
);
2102 scm_rec_mutex_unlock (&source_mutex
);
2103 goto nontoplevel_begin
;
2106 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2109 SCM_CEVAL (form
, env
);
2115 /* scm_eval last form in list */
2116 SCM last_form
= SCM_CAR (x
);
2118 if (SCM_CONSP (last_form
))
2120 /* This is by far the most frequent case. */
2122 goto loop
; /* tail recurse */
2124 else if (SCM_IMP (last_form
))
2125 RETURN (SCM_EVALIM (last_form
, env
));
2126 else if (SCM_VARIABLEP (last_form
))
2127 RETURN (SCM_VARIABLE_REF (last_form
));
2128 else if (SCM_SYMBOLP (last_form
))
2129 RETURN (*scm_lookupcar (x
, env
, 1));
2135 case SCM_BIT7 (SCM_IM_CASE
):
2138 SCM key
= EVALCAR (x
, env
);
2140 while (!SCM_NULLP (x
))
2142 SCM clause
= SCM_CAR (x
);
2143 SCM labels
= SCM_CAR (clause
);
2144 if (SCM_EQ_P (labels
, scm_sym_else
))
2146 x
= SCM_CDR (clause
);
2147 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2150 while (!SCM_NULLP (labels
))
2152 SCM label
= SCM_CAR (labels
);
2153 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2155 x
= SCM_CDR (clause
);
2156 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2159 labels
= SCM_CDR (labels
);
2164 RETURN (SCM_UNSPECIFIED
);
2167 case SCM_BIT7 (SCM_IM_COND
):
2169 while (!SCM_NULLP (x
))
2171 SCM clause
= SCM_CAR (x
);
2172 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2174 x
= SCM_CDR (clause
);
2175 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2180 arg1
= EVALCAR (clause
, env
);
2181 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2183 x
= SCM_CDR (clause
);
2186 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2188 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2194 proc
= EVALCAR (proc
, env
);
2195 PREP_APPLY (proc
, scm_list_1 (arg1
));
2203 RETURN (SCM_UNSPECIFIED
);
2206 case SCM_BIT7 (SCM_IM_DO
):
2209 /* Compute the initialization values and the initial environment. */
2210 SCM init_forms
= SCM_CAR (x
);
2211 SCM init_values
= SCM_EOL
;
2212 while (!SCM_NULLP (init_forms
))
2214 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2215 init_forms
= SCM_CDR (init_forms
);
2218 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2222 SCM test_form
= SCM_CAR (x
);
2223 SCM body_forms
= SCM_CADR (x
);
2224 SCM step_forms
= SCM_CDDR (x
);
2226 SCM test_result
= EVALCAR (test_form
, env
);
2228 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2231 /* Evaluate body forms. */
2233 for (temp_forms
= body_forms
;
2234 !SCM_NULLP (temp_forms
);
2235 temp_forms
= SCM_CDR (temp_forms
))
2237 SCM form
= SCM_CAR (temp_forms
);
2238 /* Dirk:FIXME: We only need to eval forms, that may have a
2239 * side effect here. This is only true for forms that start
2240 * with a pair. All others are just constants. However,
2241 * since in the common case there is no constant expression
2242 * in a body of a do form, we just check for immediates here
2243 * and have SCM_CEVAL take care of other cases. In the long
2244 * run it would make sense to get rid of this test and have
2245 * the macro transformer of 'do' eliminate all forms that
2246 * have no sideeffect. */
2247 if (!SCM_IMP (form
))
2248 SCM_CEVAL (form
, env
);
2253 /* Evaluate the step expressions. */
2255 SCM step_values
= SCM_EOL
;
2256 for (temp_forms
= step_forms
;
2257 !SCM_NULLP (temp_forms
);
2258 temp_forms
= SCM_CDR (temp_forms
))
2260 SCM value
= EVALCAR (temp_forms
, env
);
2261 step_values
= scm_cons (value
, step_values
);
2263 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2268 test_result
= EVALCAR (test_form
, env
);
2273 RETURN (SCM_UNSPECIFIED
);
2274 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2275 goto nontoplevel_begin
;
2278 case SCM_BIT7 (SCM_IM_IF
):
2281 SCM test_result
= EVALCAR (x
, env
);
2282 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2288 RETURN (SCM_UNSPECIFIED
);
2291 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2295 case SCM_BIT7 (SCM_IM_LET
):
2298 SCM init_forms
= SCM_CADR (x
);
2299 SCM init_values
= SCM_EOL
;
2302 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2303 init_forms
= SCM_CDR (init_forms
);
2305 while (!SCM_NULLP (init_forms
));
2306 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2309 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2310 goto nontoplevel_begin
;
2313 case SCM_BIT7 (SCM_IM_LETREC
):
2315 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2318 SCM init_forms
= SCM_CAR (x
);
2319 SCM init_values
= SCM_EOL
;
2322 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2323 init_forms
= SCM_CDR (init_forms
);
2325 while (!SCM_NULLP (init_forms
));
2326 SCM_SETCDR (SCM_CAR (env
), init_values
);
2329 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2330 goto nontoplevel_begin
;
2333 case SCM_BIT7 (SCM_IM_LETSTAR
):
2336 SCM bindings
= SCM_CAR (x
);
2337 if (SCM_NULLP (bindings
))
2338 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2343 SCM name
= SCM_CAR (bindings
);
2344 SCM init
= SCM_CDR (bindings
);
2345 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2346 bindings
= SCM_CDR (init
);
2348 while (!SCM_NULLP (bindings
));
2352 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2353 goto nontoplevel_begin
;
2356 case SCM_BIT7 (SCM_IM_OR
):
2358 while (!SCM_NULLP (SCM_CDR (x
)))
2360 SCM val
= EVALCAR (x
, env
);
2361 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2366 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2370 case SCM_BIT7 (SCM_IM_LAMBDA
):
2371 RETURN (scm_closure (SCM_CDR (x
), env
));
2374 case SCM_BIT7 (SCM_IM_QUOTE
):
2375 RETURN (SCM_CADR (x
));
2378 case SCM_BIT7 (SCM_IM_SET_X
):
2382 SCM variable
= SCM_CAR (x
);
2383 if (SCM_ILOCP (variable
))
2384 location
= scm_ilookup (variable
, env
);
2385 else if (SCM_VARIABLEP (variable
))
2386 location
= SCM_VARIABLE_LOC (variable
);
2387 else /* (SCM_SYMBOLP (variable)) is known to be true */
2388 location
= scm_lookupcar (x
, env
, 1);
2390 *location
= EVALCAR (x
, env
);
2392 RETURN (SCM_UNSPECIFIED
);
2395 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2396 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2399 /* new syntactic forms go here. */
2400 case SCM_BIT7 (SCM_MAKISYM (0)):
2402 switch (SCM_ISYMNUM (proc
))
2406 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2408 proc
= EVALCAR (x
, env
);
2409 PREP_APPLY (proc
, SCM_EOL
);
2411 arg1
= EVALCAR (x
, env
);
2414 /* Go here to tail-apply a procedure. PROC is the procedure and
2415 * ARG1 is the list of arguments. PREP_APPLY must have been called
2416 * before jumping to apply_proc. */
2417 if (SCM_CLOSUREP (proc
))
2419 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2421 debug
.info
->a
.args
= arg1
;
2423 if (scm_badargsp (formals
, arg1
))
2424 scm_wrong_num_args (proc
);
2426 /* Copy argument list */
2427 if (SCM_NULL_OR_NIL_P (arg1
))
2428 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2431 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2433 arg1
= SCM_CDR (arg1
);
2434 while (!SCM_NULL_OR_NIL_P (arg1
))
2436 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2437 SCM_SETCDR (tail
, new_tail
);
2439 arg1
= SCM_CDR (arg1
);
2441 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2444 x
= SCM_CLOSURE_BODY (proc
);
2445 goto nontoplevel_begin
;
2450 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
2454 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2457 SCM val
= scm_make_continuation (&first
);
2465 proc
= scm_eval_car (proc
, env
);
2466 PREP_APPLY (proc
, scm_list_1 (arg1
));
2473 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2474 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2477 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2478 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2481 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
2482 following code (type_dispatch) is intended to be the tail
2483 of the case clause for the internal macro
2484 SCM_IM_DISPATCH. Please don't remove it from this
2485 location without discussing it with Mikael
2486 <djurfeldt@nada.kth.se> */
2488 /* The type dispatch code is duplicated below
2489 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2490 * cuts down execution time for type dispatch to 50%. */
2491 type_dispatch
: /* inputs: x, arg1 */
2492 /* Type dispatch means to determine from the types of the function
2493 * arguments (i. e. the 'signature' of the call), which method from
2494 * a generic function is to be called. This process of selecting
2495 * the right method takes some time. To speed it up, guile uses
2496 * caching: Together with the macro call to dispatch the signatures
2497 * of some previous calls to that generic function from the same
2498 * place are stored (in the code!) in a cache that we call the
2499 * 'method cache'. This is done since it is likely, that
2500 * consecutive calls to dispatch from that position in the code will
2501 * have the same signature. Thus, the type dispatch works as
2502 * follows: First, determine a hash value from the signature of the
2503 * actual arguments. Second, use this hash value as an index to
2504 * find that same signature in the method cache stored at this
2505 * position in the code. If found, you have also found the
2506 * corresponding method that belongs to that signature. If the
2507 * signature is not found in the method cache, you have to perform a
2508 * full search over all signatures stored with the generic
2511 unsigned long int specializers
;
2512 unsigned long int hash_value
;
2513 unsigned long int cache_end_pos
;
2514 unsigned long int mask
;
2518 SCM z
= SCM_CDDR (x
);
2519 SCM tmp
= SCM_CADR (z
);
2520 specializers
= SCM_INUM (SCM_CAR (z
));
2522 /* Compute a hash value for searching the method cache. There
2523 * are two variants for computing the hash value, a (rather)
2524 * complicated one, and a simple one. For the complicated one
2525 * explained below, tmp holds a number that is used in the
2527 if (SCM_INUMP (tmp
))
2529 /* Use the signature of the actual arguments to determine
2530 * the hash value. This is done as follows: Each class has
2531 * an array of random numbers, that are determined when the
2532 * class is created. The integer 'hashset' is an index into
2533 * that array of random numbers. Now, from all classes that
2534 * are part of the signature of the actual arguments, the
2535 * random numbers at index 'hashset' are taken and summed
2536 * up, giving the hash value. The value of 'hashset' is
2537 * stored at the call to dispatch. This allows to have
2538 * different 'formulas' for calculating the hash value at
2539 * different places where dispatch is called. This allows
2540 * to optimize the hash formula at every individual place
2541 * where dispatch is called, such that hopefully the hash
2542 * value that is computed will directly point to the right
2543 * method in the method cache. */
2544 unsigned long int hashset
= SCM_INUM (tmp
);
2545 unsigned long int counter
= specializers
+ 1;
2548 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2550 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2551 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2552 tmp_arg
= SCM_CDR (tmp_arg
);
2556 method_cache
= SCM_CADR (z
);
2557 mask
= SCM_INUM (SCM_CAR (z
));
2559 cache_end_pos
= hash_value
;
2563 /* This method of determining the hash value is much
2564 * simpler: Set the hash value to zero and just perform a
2565 * linear search through the method cache. */
2567 mask
= (unsigned long int) ((long) -1);
2569 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2574 /* Search the method cache for a method with a matching
2575 * signature. Start the search at position 'hash_value'. The
2576 * hashing implementation uses linear probing for conflict
2577 * resolution, that is, if the signature in question is not
2578 * found at the starting index in the hash table, the next table
2579 * entry is tried, and so on, until in the worst case the whole
2580 * cache has been searched, but still the signature has not been
2585 SCM args
= arg1
; /* list of arguments */
2586 z
= SCM_VELTS (method_cache
)[hash_value
];
2587 while (!SCM_NULLP (args
))
2589 /* More arguments than specifiers => CLASS != ENV */
2590 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2591 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2593 args
= SCM_CDR (args
);
2596 /* Fewer arguments than specifiers => CAR != ENV */
2597 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2600 hash_value
= (hash_value
+ 1) & mask
;
2601 } while (hash_value
!= cache_end_pos
);
2603 /* No appropriate method was found in the cache. */
2604 z
= scm_memoize_method (x
, arg1
);
2606 apply_cmethod
: /* inputs: z, arg1 */
2608 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2609 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2610 x
= SCM_CMETHOD_BODY (z
);
2611 goto nontoplevel_begin
;
2617 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2620 SCM instance
= EVALCAR (x
, env
);
2621 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2622 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2626 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2629 SCM instance
= EVALCAR (x
, env
);
2630 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2631 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2632 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2633 RETURN (SCM_UNSPECIFIED
);
2637 #if SCM_ENABLE_ELISP
2639 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2641 SCM test_form
= SCM_CDR (x
);
2642 x
= SCM_CDR (test_form
);
2643 while (!SCM_NULL_OR_NIL_P (x
))
2645 SCM test_result
= EVALCAR (test_form
, env
);
2646 if (!(SCM_FALSEP (test_result
)
2647 || SCM_NULL_OR_NIL_P (test_result
)))
2649 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2650 RETURN (test_result
);
2651 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2656 test_form
= SCM_CDR (x
);
2657 x
= SCM_CDR (test_form
);
2661 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2665 #endif /* SCM_ENABLE_ELISP */
2667 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2669 SCM vars
, exps
, vals
;
2672 vars
= SCM_CAAR (x
);
2673 exps
= SCM_CDAR (x
);
2677 while (SCM_NIMP (exps
))
2679 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2680 exps
= SCM_CDR (exps
);
2683 scm_swap_bindings (vars
, vals
);
2684 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2686 /* Ignore all but the last evaluation result. */
2687 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2689 if (SCM_CONSP (SCM_CAR (x
)))
2690 SCM_CEVAL (SCM_CAR (x
), env
);
2692 proc
= EVALCAR (x
, env
);
2694 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2695 scm_swap_bindings (vars
, vals
);
2701 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2706 producer
= EVALCAR (x
, env
);
2708 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
2709 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
2710 if (SCM_VALUESP (arg1
))
2711 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2713 arg1
= scm_list_1 (arg1
);
2714 PREP_APPLY (proc
, arg1
);
2726 case scm_tc7_vector
:
2730 case scm_tc7_byvect
:
2737 #if SCM_SIZEOF_LONG_LONG != 0
2738 case scm_tc7_llvect
:
2741 case scm_tc7_string
:
2743 case scm_tcs_closures
:
2747 case scm_tcs_struct
:
2750 case scm_tc7_variable
:
2751 RETURN (SCM_VARIABLE_REF(x
));
2753 case SCM_BIT7 (SCM_ILOC00
):
2754 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2757 case scm_tcs_cons_nimcar
:
2758 if (SCM_SYMBOLP (SCM_CAR (x
)))
2760 SCM orig_sym
= SCM_CAR (x
);
2762 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2763 if (location
== NULL
)
2765 /* we have lost the race, start again. */
2771 if (SCM_MACROP (proc
))
2773 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2775 handle_a_macro
: /* inputs: x, env, proc */
2777 /* Set a flag during macro expansion so that macro
2778 application frames can be deleted from the backtrace. */
2779 SCM_SET_MACROEXP (debug
);
2781 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2782 scm_cons (env
, scm_listofnull
));
2785 SCM_CLEAR_MACROEXP (debug
);
2787 switch (SCM_MACRO_TYPE (proc
))
2791 if (scm_ilength (arg1
) <= 0)
2792 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2794 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2797 SCM_SETCAR (x
, SCM_CAR (arg1
));
2798 SCM_SETCDR (x
, SCM_CDR (arg1
));
2802 /* Prevent memoizing of debug info expression. */
2803 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2808 SCM_SETCAR (x
, SCM_CAR (arg1
));
2809 SCM_SETCDR (x
, SCM_CDR (arg1
));
2811 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2813 #if SCM_ENABLE_DEPRECATED == 1
2818 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2830 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2833 if (SCM_MACROP (proc
))
2834 goto handle_a_macro
;
2838 evapply
: /* inputs: x, proc */
2839 PREP_APPLY (proc
, SCM_EOL
);
2840 if (SCM_NULLP (SCM_CDR (x
))) {
2843 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2844 switch (SCM_TYP7 (proc
))
2845 { /* no arguments given */
2846 case scm_tc7_subr_0
:
2847 RETURN (SCM_SUBRF (proc
) ());
2848 case scm_tc7_subr_1o
:
2849 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2851 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2852 case scm_tc7_rpsubr
:
2853 RETURN (SCM_BOOL_T
);
2855 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2857 if (!SCM_SMOB_APPLICABLE_P (proc
))
2859 RETURN (SCM_SMOB_APPLY_0 (proc
));
2862 proc
= SCM_CCLO_SUBR (proc
);
2864 debug
.info
->a
.proc
= proc
;
2865 debug
.info
->a
.args
= scm_list_1 (arg1
);
2869 proc
= SCM_PROCEDURE (proc
);
2871 debug
.info
->a
.proc
= proc
;
2873 if (!SCM_CLOSUREP (proc
))
2876 case scm_tcs_closures
:
2878 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2879 if (SCM_CONSP (formals
))
2880 goto umwrongnumargs
;
2881 x
= SCM_CLOSURE_BODY (proc
);
2882 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2883 goto nontoplevel_begin
;
2885 case scm_tcs_struct
:
2886 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2888 x
= SCM_ENTITY_PROCEDURE (proc
);
2892 else if (SCM_I_OPERATORP (proc
))
2895 proc
= (SCM_I_ENTITYP (proc
)
2896 ? SCM_ENTITY_PROCEDURE (proc
)
2897 : SCM_OPERATOR_PROCEDURE (proc
));
2899 debug
.info
->a
.proc
= proc
;
2900 debug
.info
->a
.args
= scm_list_1 (arg1
);
2906 case scm_tc7_subr_1
:
2907 case scm_tc7_subr_2
:
2908 case scm_tc7_subr_2o
:
2911 case scm_tc7_subr_3
:
2912 case scm_tc7_lsubr_2
:
2915 scm_wrong_num_args (proc
);
2918 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2922 /* must handle macros by here */
2925 arg1
= EVALCAR (x
, env
);
2927 scm_wrong_num_args (proc
);
2929 debug
.info
->a
.args
= scm_list_1 (arg1
);
2937 evap1
: /* inputs: proc, arg1 */
2938 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2939 switch (SCM_TYP7 (proc
))
2940 { /* have one argument in arg1 */
2941 case scm_tc7_subr_2o
:
2942 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2943 case scm_tc7_subr_1
:
2944 case scm_tc7_subr_1o
:
2945 RETURN (SCM_SUBRF (proc
) (arg1
));
2947 if (SCM_INUMP (arg1
))
2949 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2951 else if (SCM_REALP (arg1
))
2953 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2955 else if (SCM_BIGP (arg1
))
2957 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2959 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2960 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2963 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
2966 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
2967 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2968 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2973 case scm_tc7_rpsubr
:
2974 RETURN (SCM_BOOL_T
);
2976 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2979 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2981 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2984 if (!SCM_SMOB_APPLICABLE_P (proc
))
2986 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2990 proc
= SCM_CCLO_SUBR (proc
);
2992 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2993 debug
.info
->a
.proc
= proc
;
2997 proc
= SCM_PROCEDURE (proc
);
2999 debug
.info
->a
.proc
= proc
;
3001 if (!SCM_CLOSUREP (proc
))
3004 case scm_tcs_closures
:
3007 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3008 if (SCM_NULLP (formals
)
3009 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3010 goto umwrongnumargs
;
3011 x
= SCM_CLOSURE_BODY (proc
);
3013 env
= SCM_EXTEND_ENV (formals
,
3017 env
= SCM_EXTEND_ENV (formals
,
3021 goto nontoplevel_begin
;
3023 case scm_tcs_struct
:
3024 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3026 x
= SCM_ENTITY_PROCEDURE (proc
);
3028 arg1
= debug
.info
->a
.args
;
3030 arg1
= scm_list_1 (arg1
);
3034 else if (SCM_I_OPERATORP (proc
))
3038 proc
= (SCM_I_ENTITYP (proc
)
3039 ? SCM_ENTITY_PROCEDURE (proc
)
3040 : SCM_OPERATOR_PROCEDURE (proc
));
3042 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3043 debug
.info
->a
.proc
= proc
;
3049 case scm_tc7_subr_2
:
3050 case scm_tc7_subr_0
:
3051 case scm_tc7_subr_3
:
3052 case scm_tc7_lsubr_2
:
3053 scm_wrong_num_args (proc
);
3059 arg2
= EVALCAR (x
, env
);
3061 scm_wrong_num_args (proc
);
3063 { /* have two or more arguments */
3065 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3068 if (SCM_NULLP (x
)) {
3071 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3072 switch (SCM_TYP7 (proc
))
3073 { /* have two arguments */
3074 case scm_tc7_subr_2
:
3075 case scm_tc7_subr_2o
:
3076 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3079 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3081 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3083 case scm_tc7_lsubr_2
:
3084 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3085 case scm_tc7_rpsubr
:
3087 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3089 if (!SCM_SMOB_APPLICABLE_P (proc
))
3091 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3095 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3096 scm_cons (proc
, debug
.info
->a
.args
),
3099 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3100 scm_cons2 (proc
, arg1
,
3107 case scm_tcs_struct
:
3108 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3110 x
= SCM_ENTITY_PROCEDURE (proc
);
3112 arg1
= debug
.info
->a
.args
;
3114 arg1
= scm_list_2 (arg1
, arg2
);
3118 else if (SCM_I_OPERATORP (proc
))
3122 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3123 ? SCM_ENTITY_PROCEDURE (proc
)
3124 : SCM_OPERATOR_PROCEDURE (proc
),
3125 scm_cons (proc
, debug
.info
->a
.args
),
3128 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3129 ? SCM_ENTITY_PROCEDURE (proc
)
3130 : SCM_OPERATOR_PROCEDURE (proc
),
3131 scm_cons2 (proc
, arg1
,
3141 case scm_tc7_subr_0
:
3144 case scm_tc7_subr_1o
:
3145 case scm_tc7_subr_1
:
3146 case scm_tc7_subr_3
:
3147 scm_wrong_num_args (proc
);
3151 proc
= SCM_PROCEDURE (proc
);
3153 debug
.info
->a
.proc
= proc
;
3155 if (!SCM_CLOSUREP (proc
))
3158 case scm_tcs_closures
:
3161 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3162 if (SCM_NULLP (formals
)
3163 || (SCM_CONSP (formals
)
3164 && (SCM_NULLP (SCM_CDR (formals
))
3165 || (SCM_CONSP (SCM_CDR (formals
))
3166 && SCM_CONSP (SCM_CDDR (formals
))))))
3167 goto umwrongnumargs
;
3169 env
= SCM_EXTEND_ENV (formals
,
3173 env
= SCM_EXTEND_ENV (formals
,
3174 scm_list_2 (arg1
, arg2
),
3177 x
= SCM_CLOSURE_BODY (proc
);
3178 goto nontoplevel_begin
;
3183 scm_wrong_num_args (proc
);
3185 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3186 deval_args (x
, env
, proc
,
3187 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3191 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3192 switch (SCM_TYP7 (proc
))
3193 { /* have 3 or more arguments */
3195 case scm_tc7_subr_3
:
3196 if (!SCM_NULLP (SCM_CDR (x
)))
3197 scm_wrong_num_args (proc
);
3199 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3200 SCM_CADDR (debug
.info
->a
.args
)));
3202 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3203 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3206 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3207 arg2
= SCM_CDR (arg2
);
3209 while (SCM_NIMP (arg2
));
3211 case scm_tc7_rpsubr
:
3212 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3213 RETURN (SCM_BOOL_F
);
3214 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3217 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3218 RETURN (SCM_BOOL_F
);
3219 arg2
= SCM_CAR (arg1
);
3220 arg1
= SCM_CDR (arg1
);
3222 while (SCM_NIMP (arg1
));
3223 RETURN (SCM_BOOL_T
);
3224 case scm_tc7_lsubr_2
:
3225 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3226 SCM_CDDR (debug
.info
->a
.args
)));
3228 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3230 if (!SCM_SMOB_APPLICABLE_P (proc
))
3232 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3233 SCM_CDDR (debug
.info
->a
.args
)));
3237 proc
= SCM_PROCEDURE (proc
);
3238 debug
.info
->a
.proc
= proc
;
3239 if (!SCM_CLOSUREP (proc
))
3242 case scm_tcs_closures
:
3244 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3245 if (SCM_NULLP (formals
)
3246 || (SCM_CONSP (formals
)
3247 && (SCM_NULLP (SCM_CDR (formals
))
3248 || (SCM_CONSP (SCM_CDR (formals
))
3249 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3250 goto umwrongnumargs
;
3251 SCM_SET_ARGSREADY (debug
);
3252 env
= SCM_EXTEND_ENV (formals
,
3255 x
= SCM_CLOSURE_BODY (proc
);
3256 goto nontoplevel_begin
;
3259 case scm_tc7_subr_3
:
3260 if (!SCM_NULLP (SCM_CDR (x
)))
3261 scm_wrong_num_args (proc
);
3263 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3265 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3268 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3271 while (SCM_NIMP (x
));
3273 case scm_tc7_rpsubr
:
3274 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3275 RETURN (SCM_BOOL_F
);
3278 arg1
= EVALCAR (x
, env
);
3279 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3280 RETURN (SCM_BOOL_F
);
3284 while (SCM_NIMP (x
));
3285 RETURN (SCM_BOOL_T
);
3286 case scm_tc7_lsubr_2
:
3287 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3289 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3291 scm_eval_args (x
, env
, proc
))));
3293 if (!SCM_SMOB_APPLICABLE_P (proc
))
3295 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3296 scm_eval_args (x
, env
, proc
)));
3300 proc
= SCM_PROCEDURE (proc
);
3301 if (!SCM_CLOSUREP (proc
))
3304 case scm_tcs_closures
:
3306 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3307 if (SCM_NULLP (formals
)
3308 || (SCM_CONSP (formals
)
3309 && (SCM_NULLP (SCM_CDR (formals
))
3310 || (SCM_CONSP (SCM_CDR (formals
))
3311 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3312 goto umwrongnumargs
;
3313 env
= SCM_EXTEND_ENV (formals
,
3316 scm_eval_args (x
, env
, proc
)),
3318 x
= SCM_CLOSURE_BODY (proc
);
3319 goto nontoplevel_begin
;
3322 case scm_tcs_struct
:
3323 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3326 arg1
= debug
.info
->a
.args
;
3328 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3330 x
= SCM_ENTITY_PROCEDURE (proc
);
3333 else if (SCM_I_OPERATORP (proc
))
3337 case scm_tc7_subr_2
:
3338 case scm_tc7_subr_1o
:
3339 case scm_tc7_subr_2o
:
3340 case scm_tc7_subr_0
:
3343 case scm_tc7_subr_1
:
3344 scm_wrong_num_args (proc
);
3352 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3353 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3355 SCM_CLEAR_TRACED_FRAME (debug
);
3356 if (SCM_CHEAPTRAPS_P
)
3357 arg1
= scm_make_debugobj (&debug
);
3361 SCM val
= scm_make_continuation (&first
);
3372 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3376 scm_last_debug_frame
= debug
.prev
;
3382 /* SECTION: This code is compiled once.
3389 /* Simple procedure calls
3393 scm_call_0 (SCM proc
)
3395 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3399 scm_call_1 (SCM proc
, SCM arg1
)
3401 return scm_apply (proc
, arg1
, scm_listofnull
);
3405 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3407 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3411 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3413 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3417 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3419 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3420 scm_cons (arg4
, scm_listofnull
)));
3423 /* Simple procedure applies
3427 scm_apply_0 (SCM proc
, SCM args
)
3429 return scm_apply (proc
, args
, SCM_EOL
);
3433 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3435 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3439 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3441 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3445 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3447 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3451 /* This code processes the arguments to apply:
3453 (apply PROC ARG1 ... ARGS)
3455 Given a list (ARG1 ... ARGS), this function conses the ARG1
3456 ... arguments onto the front of ARGS, and returns the resulting
3457 list. Note that ARGS is a list; thus, the argument to this
3458 function is a list whose last element is a list.
3460 Apply calls this function, and applies PROC to the elements of the
3461 result. apply:nconc2last takes care of building the list of
3462 arguments, given (ARG1 ... ARGS).
3464 Rather than do new consing, apply:nconc2last destroys its argument.
3465 On that topic, this code came into my care with the following
3466 beautifully cryptic comment on that topic: "This will only screw
3467 you if you do (scm_apply scm_apply '( ... ))" If you know what
3468 they're referring to, send me a patch to this comment. */
3470 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3472 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3473 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3474 "@var{args}, and returns the resulting list. Note that\n"
3475 "@var{args} is a list; thus, the argument to this function is\n"
3476 "a list whose last element is a list.\n"
3477 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3478 "destroys its argument, so use with care.")
3479 #define FUNC_NAME s_scm_nconc2last
3482 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3484 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3485 SCM_NULL_OR_NIL_P, but not
3486 needed in 99.99% of cases,
3487 and it could seriously hurt
3488 performance. - Neil */
3489 lloc
= SCM_CDRLOC (*lloc
);
3490 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3491 *lloc
= SCM_CAR (*lloc
);
3499 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3500 * It is compiled twice.
3505 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3511 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3516 /* Apply a function to a list of arguments.
3518 This function is exported to the Scheme level as taking two
3519 required arguments and a tail argument, as if it were:
3520 (lambda (proc arg1 . args) ...)
3521 Thus, if you just have a list of arguments to pass to a procedure,
3522 pass the list as ARG1, and '() for ARGS. If you have some fixed
3523 args, pass the first as ARG1, then cons any remaining fixed args
3524 onto the front of your argument list, and pass that as ARGS. */
3527 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3530 scm_t_debug_frame debug
;
3531 scm_t_debug_info debug_vect_body
;
3532 debug
.prev
= scm_last_debug_frame
;
3533 debug
.status
= SCM_APPLYFRAME
;
3534 debug
.vect
= &debug_vect_body
;
3535 debug
.vect
[0].a
.proc
= proc
;
3536 debug
.vect
[0].a
.args
= SCM_EOL
;
3537 scm_last_debug_frame
= &debug
;
3540 return scm_dapply (proc
, arg1
, args
);
3543 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3545 /* If ARGS is the empty list, then we're calling apply with only two
3546 arguments --- ARG1 is the list of arguments for PROC. Whatever
3547 the case, futz with things so that ARG1 is the first argument to
3548 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3551 Setting the debug apply frame args this way is pretty messy.
3552 Perhaps we should store arg1 and args directly in the frame as
3553 received, and let scm_frame_arguments unpack them, because that's
3554 a relatively rare operation. This works for now; if the Guile
3555 developer archives are still around, see Mikael's post of
3557 if (SCM_NULLP (args
))
3559 if (SCM_NULLP (arg1
))
3561 arg1
= SCM_UNDEFINED
;
3563 debug
.vect
[0].a
.args
= SCM_EOL
;
3569 debug
.vect
[0].a
.args
= arg1
;
3571 args
= SCM_CDR (arg1
);
3572 arg1
= SCM_CAR (arg1
);
3577 args
= scm_nconc2last (args
);
3579 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3583 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3586 if (SCM_CHEAPTRAPS_P
)
3587 tmp
= scm_make_debugobj (&debug
);
3592 tmp
= scm_make_continuation (&first
);
3597 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3604 switch (SCM_TYP7 (proc
))
3606 case scm_tc7_subr_2o
:
3607 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3608 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3609 case scm_tc7_subr_2
:
3610 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3611 scm_wrong_num_args (proc
);
3612 args
= SCM_CAR (args
);
3613 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3614 case scm_tc7_subr_0
:
3615 if (!SCM_UNBNDP (arg1
))
3616 scm_wrong_num_args (proc
);
3618 RETURN (SCM_SUBRF (proc
) ());
3619 case scm_tc7_subr_1
:
3620 if (SCM_UNBNDP (arg1
))
3621 scm_wrong_num_args (proc
);
3622 case scm_tc7_subr_1o
:
3623 if (!SCM_NULLP (args
))
3624 scm_wrong_num_args (proc
);
3626 RETURN (SCM_SUBRF (proc
) (arg1
));
3628 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3629 scm_wrong_num_args (proc
);
3630 if (SCM_INUMP (arg1
))
3632 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3634 else if (SCM_REALP (arg1
))
3636 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3638 else if (SCM_BIGP (arg1
))
3639 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3640 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3641 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3643 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3644 scm_wrong_num_args (proc
);
3646 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3649 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3650 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3651 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3656 case scm_tc7_subr_3
:
3657 if (SCM_NULLP (args
)
3658 || SCM_NULLP (SCM_CDR (args
))
3659 || !SCM_NULLP (SCM_CDDR (args
)))
3660 scm_wrong_num_args (proc
);
3662 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3665 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3667 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3669 case scm_tc7_lsubr_2
:
3670 if (!SCM_CONSP (args
))
3671 scm_wrong_num_args (proc
);
3673 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3675 if (SCM_NULLP (args
))
3676 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3677 while (SCM_NIMP (args
))
3679 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3680 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3681 args
= SCM_CDR (args
);
3684 case scm_tc7_rpsubr
:
3685 if (SCM_NULLP (args
))
3686 RETURN (SCM_BOOL_T
);
3687 while (SCM_NIMP (args
))
3689 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3690 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3691 RETURN (SCM_BOOL_F
);
3692 arg1
= SCM_CAR (args
);
3693 args
= SCM_CDR (args
);
3695 RETURN (SCM_BOOL_T
);
3696 case scm_tcs_closures
:
3698 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3700 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3702 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3703 scm_wrong_num_args (proc
);
3705 /* Copy argument list */
3710 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3711 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
3713 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
3716 SCM_SETCDR (tl
, arg1
);
3719 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3722 proc
= SCM_CLOSURE_BODY (proc
);
3724 arg1
= SCM_CDR (proc
);
3725 while (!SCM_NULLP (arg1
))
3727 if (SCM_IMP (SCM_CAR (proc
)))
3729 if (SCM_ISYMP (SCM_CAR (proc
)))
3731 scm_rec_mutex_lock (&source_mutex
);
3732 /* check for race condition */
3733 if (SCM_ISYMP (SCM_CAR (proc
)))
3734 proc
= scm_m_expand_body (proc
, args
);
3735 scm_rec_mutex_unlock (&source_mutex
);
3739 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3742 SCM_CEVAL (SCM_CAR (proc
), args
);
3744 arg1
= SCM_CDR (proc
);
3746 RETURN (EVALCAR (proc
, args
));
3748 if (!SCM_SMOB_APPLICABLE_P (proc
))
3750 if (SCM_UNBNDP (arg1
))
3751 RETURN (SCM_SMOB_APPLY_0 (proc
));
3752 else if (SCM_NULLP (args
))
3753 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3754 else if (SCM_NULLP (SCM_CDR (args
)))
3755 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3757 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3760 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3762 proc
= SCM_CCLO_SUBR (proc
);
3763 debug
.vect
[0].a
.proc
= proc
;
3764 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3766 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3768 proc
= SCM_CCLO_SUBR (proc
);
3772 proc
= SCM_PROCEDURE (proc
);
3774 debug
.vect
[0].a
.proc
= proc
;
3777 case scm_tcs_struct
:
3778 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3781 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3783 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3785 RETURN (scm_apply_generic (proc
, args
));
3787 else if (SCM_I_OPERATORP (proc
))
3791 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3793 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3796 proc
= (SCM_I_ENTITYP (proc
)
3797 ? SCM_ENTITY_PROCEDURE (proc
)
3798 : SCM_OPERATOR_PROCEDURE (proc
));
3800 debug
.vect
[0].a
.proc
= proc
;
3801 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3803 if (SCM_NIMP (proc
))
3812 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3816 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3817 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3819 SCM_CLEAR_TRACED_FRAME (debug
);
3820 if (SCM_CHEAPTRAPS_P
)
3821 arg1
= scm_make_debugobj (&debug
);
3825 SCM val
= scm_make_continuation (&first
);
3836 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3840 scm_last_debug_frame
= debug
.prev
;
3846 /* SECTION: The rest of this file is only read once.
3853 * Trampolines make it possible to move procedure application dispatch
3854 * outside inner loops. The motivation was clean implementation of
3855 * efficient replacements of R5RS primitives in SRFI-1.
3857 * The semantics is clear: scm_trampoline_N returns an optimized
3858 * version of scm_call_N (or NULL if the procedure isn't applicable
3861 * Applying the optimization to map and for-each increased efficiency
3862 * noticeably. For example, (map abs ls) is now 8 times faster than
3867 call_subr0_0 (SCM proc
)
3869 return SCM_SUBRF (proc
) ();
3873 call_subr1o_0 (SCM proc
)
3875 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3879 call_lsubr_0 (SCM proc
)
3881 return SCM_SUBRF (proc
) (SCM_EOL
);
3885 scm_i_call_closure_0 (SCM proc
)
3887 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3890 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3895 scm_trampoline_0 (SCM proc
)
3901 switch (SCM_TYP7 (proc
))
3903 case scm_tc7_subr_0
:
3904 return call_subr0_0
;
3905 case scm_tc7_subr_1o
:
3906 return call_subr1o_0
;
3908 return call_lsubr_0
;
3909 case scm_tcs_closures
:
3911 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3912 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3913 return scm_i_call_closure_0
;
3917 case scm_tcs_struct
:
3918 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3919 return scm_call_generic_0
;
3920 else if (SCM_I_OPERATORP (proc
))
3924 if (SCM_SMOB_APPLICABLE_P (proc
))
3925 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3929 case scm_tc7_rpsubr
:
3934 return NULL
; /* not applicable on one arg */
3939 call_subr1_1 (SCM proc
, SCM arg1
)
3941 return SCM_SUBRF (proc
) (arg1
);
3945 call_subr2o_1 (SCM proc
, SCM arg1
)
3947 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3951 call_lsubr_1 (SCM proc
, SCM arg1
)
3953 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3957 call_dsubr_1 (SCM proc
, SCM arg1
)
3959 if (SCM_INUMP (arg1
))
3961 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3963 else if (SCM_REALP (arg1
))
3965 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3967 else if (SCM_BIGP (arg1
))
3968 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3969 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3970 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3974 call_cxr_1 (SCM proc
, SCM arg1
)
3976 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3979 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3980 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3981 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3988 call_closure_1 (SCM proc
, SCM arg1
)
3990 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3993 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3998 scm_trampoline_1 (SCM proc
)
4004 switch (SCM_TYP7 (proc
))
4006 case scm_tc7_subr_1
:
4007 case scm_tc7_subr_1o
:
4008 return call_subr1_1
;
4009 case scm_tc7_subr_2o
:
4010 return call_subr2o_1
;
4012 return call_lsubr_1
;
4014 return call_dsubr_1
;
4017 case scm_tcs_closures
:
4019 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4020 if (!SCM_NULLP (formals
)
4021 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4022 return call_closure_1
;
4026 case scm_tcs_struct
:
4027 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4028 return scm_call_generic_1
;
4029 else if (SCM_I_OPERATORP (proc
))
4033 if (SCM_SMOB_APPLICABLE_P (proc
))
4034 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4038 case scm_tc7_rpsubr
:
4043 return NULL
; /* not applicable on one arg */
4048 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4050 return SCM_SUBRF (proc
) (arg1
, arg2
);
4054 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4056 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4060 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4062 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4066 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4068 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4069 scm_list_2 (arg1
, arg2
),
4071 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4076 scm_trampoline_2 (SCM proc
)
4082 switch (SCM_TYP7 (proc
))
4084 case scm_tc7_subr_2
:
4085 case scm_tc7_subr_2o
:
4086 case scm_tc7_rpsubr
:
4088 return call_subr2_2
;
4089 case scm_tc7_lsubr_2
:
4090 return call_lsubr2_2
;
4092 return call_lsubr_2
;
4093 case scm_tcs_closures
:
4095 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4096 if (!SCM_NULLP (formals
)
4097 && (!SCM_CONSP (formals
)
4098 || (!SCM_NULLP (SCM_CDR (formals
))
4099 && (!SCM_CONSP (SCM_CDR (formals
))
4100 || !SCM_CONSP (SCM_CDDR (formals
))))))
4101 return call_closure_2
;
4105 case scm_tcs_struct
:
4106 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4107 return scm_call_generic_2
;
4108 else if (SCM_I_OPERATORP (proc
))
4112 if (SCM_SMOB_APPLICABLE_P (proc
))
4113 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4120 return NULL
; /* not applicable on two args */
4124 /* Typechecking for multi-argument MAP and FOR-EACH.
4126 Verify that each element of the vector ARGV, except for the first,
4127 is a proper list whose length is LEN. Attribute errors to WHO,
4128 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4130 check_map_args (SCM argv
,
4137 SCM
const *ve
= SCM_VELTS (argv
);
4140 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4142 long elt_len
= scm_ilength (ve
[i
]);
4147 scm_apply_generic (gf
, scm_cons (proc
, args
));
4149 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4153 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4156 scm_remember_upto_here_1 (argv
);
4160 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4162 /* Note: Currently, scm_map applies PROC to the argument list(s)
4163 sequentially, starting with the first element(s). This is used in
4164 evalext.c where the Scheme procedure `map-in-order', which guarantees
4165 sequential behaviour, is implemented using scm_map. If the
4166 behaviour changes, we need to update `map-in-order'.
4170 scm_map (SCM proc
, SCM arg1
, SCM args
)
4171 #define FUNC_NAME s_map
4176 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4178 len
= scm_ilength (arg1
);
4179 SCM_GASSERTn (len
>= 0,
4180 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4181 SCM_VALIDATE_REST_ARGUMENT (args
);
4182 if (SCM_NULLP (args
))
4184 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4185 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4186 while (SCM_NIMP (arg1
))
4188 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4189 pres
= SCM_CDRLOC (*pres
);
4190 arg1
= SCM_CDR (arg1
);
4194 if (SCM_NULLP (SCM_CDR (args
)))
4196 SCM arg2
= SCM_CAR (args
);
4197 int len2
= scm_ilength (arg2
);
4198 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4200 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4201 SCM_GASSERTn (len2
>= 0,
4202 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4204 SCM_OUT_OF_RANGE (3, arg2
);
4205 while (SCM_NIMP (arg1
))
4207 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4208 pres
= SCM_CDRLOC (*pres
);
4209 arg1
= SCM_CDR (arg1
);
4210 arg2
= SCM_CDR (arg2
);
4214 arg1
= scm_cons (arg1
, args
);
4215 args
= scm_vector (arg1
);
4216 ve
= SCM_VELTS (args
);
4217 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4221 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4223 if (SCM_IMP (ve
[i
]))
4225 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4226 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4228 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4229 pres
= SCM_CDRLOC (*pres
);
4235 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4238 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4239 #define FUNC_NAME s_for_each
4241 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4243 len
= scm_ilength (arg1
);
4244 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4245 SCM_ARG2
, s_for_each
);
4246 SCM_VALIDATE_REST_ARGUMENT (args
);
4247 if (SCM_NULLP (args
))
4249 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4250 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4251 while (SCM_NIMP (arg1
))
4253 call (proc
, SCM_CAR (arg1
));
4254 arg1
= SCM_CDR (arg1
);
4256 return SCM_UNSPECIFIED
;
4258 if (SCM_NULLP (SCM_CDR (args
)))
4260 SCM arg2
= SCM_CAR (args
);
4261 int len2
= scm_ilength (arg2
);
4262 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4263 SCM_GASSERTn (call
, g_for_each
,
4264 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4265 SCM_GASSERTn (len2
>= 0, g_for_each
,
4266 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4268 SCM_OUT_OF_RANGE (3, arg2
);
4269 while (SCM_NIMP (arg1
))
4271 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4272 arg1
= SCM_CDR (arg1
);
4273 arg2
= SCM_CDR (arg2
);
4275 return SCM_UNSPECIFIED
;
4277 arg1
= scm_cons (arg1
, args
);
4278 args
= scm_vector (arg1
);
4279 ve
= SCM_VELTS (args
);
4280 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4284 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4286 if (SCM_IMP (ve
[i
]))
4287 return SCM_UNSPECIFIED
;
4288 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4289 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4291 scm_apply (proc
, arg1
, SCM_EOL
);
4298 scm_closure (SCM code
, SCM env
)
4301 SCM closcar
= scm_cons (code
, SCM_EOL
);
4302 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4303 scm_remember_upto_here (closcar
);
4308 scm_t_bits scm_tc16_promise
;
4311 scm_makprom (SCM code
)
4313 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4315 scm_make_rec_mutex ());
4319 promise_free (SCM promise
)
4321 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4326 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4328 int writingp
= SCM_WRITINGP (pstate
);
4329 scm_puts ("#<promise ", port
);
4330 SCM_SET_WRITINGP (pstate
, 1);
4331 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4332 SCM_SET_WRITINGP (pstate
, writingp
);
4333 scm_putc ('>', port
);
4337 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4339 "If the promise @var{x} has not been computed yet, compute and\n"
4340 "return @var{x}, otherwise just return the previously computed\n"
4342 #define FUNC_NAME s_scm_force
4344 SCM_VALIDATE_SMOB (1, promise
, promise
);
4345 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4346 if (!SCM_PROMISE_COMPUTED_P (promise
))
4348 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4349 if (!SCM_PROMISE_COMPUTED_P (promise
))
4351 SCM_SET_PROMISE_DATA (promise
, ans
);
4352 SCM_SET_PROMISE_COMPUTED (promise
);
4355 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4356 return SCM_PROMISE_DATA (promise
);
4361 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4363 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4364 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4365 #define FUNC_NAME s_scm_promise_p
4367 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4372 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4373 (SCM xorig
, SCM x
, SCM y
),
4374 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4375 "Any source properties associated with @var{xorig} are also associated\n"
4376 "with the new pair.")
4377 #define FUNC_NAME s_scm_cons_source
4380 z
= scm_cons (x
, y
);
4381 /* Copy source properties possibly associated with xorig. */
4382 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4384 scm_whash_insert (scm_source_whash
, z
, p
);
4390 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4392 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4393 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4394 "contents of both pairs and vectors (since both cons cells and vector\n"
4395 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4396 "any other object.")
4397 #define FUNC_NAME s_scm_copy_tree
4402 if (SCM_VECTORP (obj
))
4404 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4405 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4407 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4410 if (!SCM_CONSP (obj
))
4412 ans
= tl
= scm_cons_source (obj
,
4413 scm_copy_tree (SCM_CAR (obj
)),
4415 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4417 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4421 SCM_SETCDR (tl
, obj
);
4427 /* We have three levels of EVAL here:
4429 - scm_i_eval (exp, env)
4431 evaluates EXP in environment ENV. ENV is a lexical environment
4432 structure as used by the actual tree code evaluator. When ENV is
4433 a top-level environment, then changes to the current module are
4434 tracked by updating ENV so that it continues to be in sync with
4437 - scm_primitive_eval (exp)
4439 evaluates EXP in the top-level environment as determined by the
4440 current module. This is done by constructing a suitable
4441 environment and calling scm_i_eval. Thus, changes to the
4442 top-level module are tracked normally.
4444 - scm_eval (exp, mod)
4446 evaluates EXP while MOD is the current module. This is done by
4447 setting the current module to MOD, invoking scm_primitive_eval on
4448 EXP, and then restoring the current module to the value it had
4449 previously. That is, while EXP is evaluated, changes to the
4450 current module are tracked, but these changes do not persist when
4453 For each level of evals, there are two variants, distinguished by a
4454 _x suffix: the ordinary variant does not modify EXP while the _x
4455 variant can destructively modify EXP into something completely
4456 unintelligible. A Scheme data structure passed as EXP to one of the
4457 _x variants should not ever be used again for anything. So when in
4458 doubt, use the ordinary variant.
4463 scm_i_eval_x (SCM exp
, SCM env
)
4465 return SCM_XEVAL (exp
, env
);
4469 scm_i_eval (SCM exp
, SCM env
)
4471 exp
= scm_copy_tree (exp
);
4472 return SCM_XEVAL (exp
, env
);
4476 scm_primitive_eval_x (SCM exp
)
4479 SCM transformer
= scm_current_module_transformer ();
4480 if (SCM_NIMP (transformer
))
4481 exp
= scm_call_1 (transformer
, exp
);
4482 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4483 return scm_i_eval_x (exp
, env
);
4486 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4488 "Evaluate @var{exp} in the top-level environment specified by\n"
4489 "the current module.")
4490 #define FUNC_NAME s_scm_primitive_eval
4493 SCM transformer
= scm_current_module_transformer ();
4494 if (SCM_NIMP (transformer
))
4495 exp
= scm_call_1 (transformer
, exp
);
4496 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4497 return scm_i_eval (exp
, env
);
4501 /* Eval does not take the second arg optionally. This is intentional
4502 * in order to be R5RS compatible, and to prepare for the new module
4503 * system, where we would like to make the choice of evaluation
4504 * environment explicit. */
4507 change_environment (void *data
)
4509 SCM pair
= SCM_PACK (data
);
4510 SCM new_module
= SCM_CAR (pair
);
4511 SCM old_module
= scm_current_module ();
4512 SCM_SETCDR (pair
, old_module
);
4513 scm_set_current_module (new_module
);
4518 restore_environment (void *data
)
4520 SCM pair
= SCM_PACK (data
);
4521 SCM old_module
= SCM_CDR (pair
);
4522 SCM new_module
= scm_current_module ();
4523 SCM_SETCAR (pair
, new_module
);
4524 scm_set_current_module (old_module
);
4528 inner_eval_x (void *data
)
4530 return scm_primitive_eval_x (SCM_PACK(data
));
4534 scm_eval_x (SCM exp
, SCM module
)
4535 #define FUNC_NAME "eval!"
4537 SCM_VALIDATE_MODULE (2, module
);
4539 return scm_internal_dynamic_wind
4540 (change_environment
, inner_eval_x
, restore_environment
,
4541 (void *) SCM_UNPACK (exp
),
4542 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4547 inner_eval (void *data
)
4549 return scm_primitive_eval (SCM_PACK(data
));
4552 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4553 (SCM exp
, SCM module
),
4554 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4555 "in the top-level environment specified by @var{module}.\n"
4556 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4557 "@var{module} is made the current module. The current module\n"
4558 "is reset to its previous value when @var{eval} returns.")
4559 #define FUNC_NAME s_scm_eval
4561 SCM_VALIDATE_MODULE (2, module
);
4563 return scm_internal_dynamic_wind
4564 (change_environment
, inner_eval
, restore_environment
,
4565 (void *) SCM_UNPACK (exp
),
4566 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4571 /* At this point, scm_deval and scm_dapply are generated.
4581 scm_init_opts (scm_evaluator_traps
,
4582 scm_evaluator_trap_table
,
4583 SCM_N_EVALUATOR_TRAPS
);
4584 scm_init_opts (scm_eval_options_interface
,
4586 SCM_N_EVAL_OPTIONS
);
4588 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4589 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4590 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4591 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4593 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4594 SCM_SETCDR (undefineds
, undefineds
);
4595 scm_permanent_object (undefineds
);
4597 scm_listofnull
= scm_list_1 (SCM_EOL
);
4599 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4600 scm_permanent_object (f_apply
);
4602 #include "libguile/eval.x"
4604 scm_add_feature ("delay");