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"
90 * Ilocs are memoized references to variables in local environment frames.
91 * They are represented as three values: The relative offset of the
92 * environment frame, the number of the binding within that frame, and a
93 * boolean value indicating whether the binding is the last binding in the
96 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
97 #define SCM_IDINC (0x00100000L)
98 #define SCM_IDSTMSK (-SCM_IDINC)
99 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
102 + ((binding_nr) << 20) \
103 + ((last_p) ? SCM_ICDR : 0) \
106 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
108 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
109 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
110 (SCM frame
, SCM binding
, SCM cdrp
),
111 "Return a new iloc with frame offset @var{frame}, binding\n"
112 "offset @var{binding} and the cdr flag @var{cdrp}.")
113 #define FUNC_NAME s_scm_dbg_make_iloc
115 SCM_VALIDATE_INUM (1, frame
);
116 SCM_VALIDATE_INUM (2, binding
);
117 return SCM_MAKE_ILOC (SCM_INUM (frame
),
123 SCM
scm_dbg_iloc_p (SCM obj
);
124 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
126 "Return @code{#t} if @var{obj} is an iloc.")
127 #define FUNC_NAME s_scm_dbg_iloc_p
129 return SCM_BOOL (SCM_ILOCP (obj
));
137 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
139 if (SCM_EQ_P ((x), SCM_EOL)) \
140 scm_misc_error (NULL, s_expression, SCM_EOL); \
145 /* The evaluator contains a plethora of EVAL symbols.
146 * This is an attempt at explanation.
148 * The following macros should be used in code which is read twice
149 * (where the choice of evaluator is hard soldered):
151 * SCM_CEVAL is the symbol used within one evaluator to call itself.
152 * Originally, it is defined to scm_ceval, but is redefined to
153 * scm_deval during the second pass.
155 * SCM_EVALIM is used when it is known that the expression is an
156 * immediate. (This macro never calls an evaluator.)
158 * EVALCAR evaluates the car of an expression.
160 * The following macros should be used in code which is read once
161 * (where the choice of evaluator is dynamic):
163 * SCM_XEVAL takes care of immediates without calling an evaluator. It
164 * then calls scm_ceval *or* scm_deval, depending on the debugging
167 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
168 * depending on the debugging mode.
170 * The main motivation for keeping this plethora is efficiency
171 * together with maintainability (=> locality of code).
174 #define SCM_CEVAL scm_ceval
176 #define SCM_EVALIM2(x) \
177 ((SCM_EQ_P ((x), SCM_EOL) \
178 ? scm_misc_error (NULL, s_expression, SCM_EOL), 0 \
182 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
183 ? *scm_ilookup ((x), env) \
186 #define SCM_XEVAL(x, env) (SCM_IMP (x) \
188 : (*scm_ceval_ptr) ((x), (env)))
190 #define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
191 ? SCM_EVALIM (SCM_CAR (x), env) \
192 : (SCM_SYMBOLP (SCM_CAR (x)) \
193 ? *scm_lookupcar (x, env, 1) \
194 : (*scm_ceval_ptr) (SCM_CAR (x), env)))
196 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
197 ? SCM_EVALIM (SCM_CAR (x), env) \
198 : (SCM_SYMBOLP (SCM_CAR (x)) \
199 ? *scm_lookupcar (x, env, 1) \
200 : SCM_CEVAL (SCM_CAR (x), env)))
202 SCM_REC_MUTEX (source_mutex
);
205 static const char s_expression
[] = "missing or extra expression";
206 static const char s_test
[] = "bad test";
207 static const char s_body
[] = "bad body";
208 static const char s_bindings
[] = "bad bindings";
209 static const char s_duplicate_bindings
[] = "duplicate bindings";
210 static const char s_variable
[] = "bad variable";
211 static const char s_clauses
[] = "bad or missing clauses";
212 static const char s_formals
[] = "bad formals";
213 static const char s_duplicate_formals
[] = "duplicate formals";
214 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
217 /* Lookup a given local variable in an environment. The local variable is
218 * given as an iloc, that is a triple <frame, binding, last?>, where frame
219 * indicates the relative number of the environment frame (counting upwards
220 * from the innermost environment frame), binding indicates the number of the
221 * binding within the frame, and last? (which is extracted from the iloc using
222 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
223 * very end of the improper list of bindings. */
225 scm_ilookup (SCM iloc
, SCM env
)
227 unsigned int frame_nr
= SCM_IFRAME (iloc
);
228 unsigned int binding_nr
= SCM_IDIST (iloc
);
232 for (; 0 != frame_nr
; --frame_nr
)
233 frames
= SCM_CDR (frames
);
235 bindings
= SCM_CAR (frames
);
236 for (; 0 != binding_nr
; --binding_nr
)
237 bindings
= SCM_CDR (bindings
);
239 if (SCM_ICDRP (iloc
))
240 return SCM_CDRLOC (bindings
);
241 return SCM_CARLOC (SCM_CDR (bindings
));
245 /* The Lookup Car Race
248 Memoization of variables and special forms is done while executing
249 the code for the first time. As long as there is only one thread
250 everything is fine, but as soon as two threads execute the same
251 code concurrently `for the first time' they can come into conflict.
253 This memoization includes rewriting variable references into more
254 efficient forms and expanding macros. Furthermore, macro expansion
255 includes `compiling' special forms like `let', `cond', etc. into
256 tree-code instructions.
258 There shouldn't normally be a problem with memoizing local and
259 global variable references (into ilocs and variables), because all
260 threads will mutate the code in *exactly* the same way and (if I
261 read the C code correctly) it is not possible to observe a half-way
262 mutated cons cell. The lookup procedure can handle this
263 transparently without any critical sections.
265 It is different with macro expansion, because macro expansion
266 happens outside of the lookup procedure and can't be
267 undone. Therefore the lookup procedure can't cope with it. It has
268 to indicate failure when it detects a lost race and hope that the
269 caller can handle it. Luckily, it turns out that this is the case.
271 An example to illustrate this: Suppose that the following form will
272 be memoized concurrently by two threads
276 Let's first examine the lookup of X in the body. The first thread
277 decides that it has to find the symbol "x" in the environment and
278 starts to scan it. Then the other thread takes over and actually
279 overtakes the first. It looks up "x" and substitutes an
280 appropriate iloc for it. Now the first thread continues and
281 completes its lookup. It comes to exactly the same conclusions as
282 the second one and could - without much ado - just overwrite the
283 iloc with the same iloc.
285 But let's see what will happen when the race occurs while looking
286 up the symbol "let" at the start of the form. It could happen that
287 the second thread interrupts the lookup of the first thread and not
288 only substitutes a variable for it but goes right ahead and
289 replaces it with the compiled form (#@let* (x 12) x). Now, when
290 the first thread completes its lookup, it would replace the #@let*
291 with a variable containing the "let" binding, effectively reverting
292 the form to (let (x 12) x). This is wrong. It has to detect that
293 it has lost the race and the evaluator has to reconsider the
294 changed form completely.
296 This race condition could be resolved with some kind of traffic
297 light (like mutexes) around scm_lookupcar, but I think that it is
298 best to avoid them in this case. They would serialize memoization
299 completely and because lookup involves calling arbitrary Scheme
300 code (via the lookup-thunk), threads could be blocked for an
301 arbitrary amount of time or even deadlock. But with the current
302 solution a lot of unnecessary work is potentially done. */
304 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
305 return NULL to indicate a failed lookup due to some race conditions
306 between threads. This only happens when VLOC is the first cell of
307 a special form that will eventually be memoized (like `let', etc.)
308 In that case the whole lookup is bogus and the caller has to
309 reconsider the complete special form.
311 SCM_LOOKUPCAR is still there, of course. It just calls
312 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
313 should only be called when it is known that VLOC is not the first
314 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
315 for NULL. I think I've found the only places where this
318 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
321 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
324 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
325 register SCM iloc
= SCM_ILOC00
;
326 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
328 if (!SCM_CONSP (SCM_CAR (env
)))
330 al
= SCM_CARLOC (env
);
331 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
335 if (SCM_EQ_P (fl
, var
))
337 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
339 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
340 return SCM_CDRLOC (*al
);
345 al
= SCM_CDRLOC (*al
);
346 if (SCM_EQ_P (SCM_CAR (fl
), var
))
348 if (SCM_UNBNDP (SCM_CAR (*al
)))
353 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
355 SCM_SETCAR (vloc
, iloc
);
356 return SCM_CARLOC (*al
);
358 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
360 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
363 SCM top_thunk
, real_var
;
366 top_thunk
= SCM_CAR (env
); /* env now refers to a
367 top level env thunk */
371 top_thunk
= SCM_BOOL_F
;
372 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
373 if (SCM_FALSEP (real_var
))
376 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
382 scm_error (scm_unbound_variable_key
, NULL
,
383 "Unbound variable: ~S",
384 scm_list_1 (var
), SCM_BOOL_F
);
386 scm_misc_error (NULL
, "Damaged environment: ~S",
391 /* A variable could not be found, but we shall
392 not throw an error. */
393 static SCM undef_object
= SCM_UNDEFINED
;
394 return &undef_object
;
398 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
400 /* Some other thread has changed the very cell we are working
401 on. In effect, it must have done our job or messed it up
404 var
= SCM_CAR (vloc
);
405 if (SCM_VARIABLEP (var
))
406 return SCM_VARIABLE_LOC (var
);
407 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
408 return scm_ilookup (var
, genv
);
409 /* We can't cope with anything else than variables and ilocs. When
410 a special form has been memoized (i.e. `let' into `#@let') we
411 return NULL and expect the calling function to do the right
412 thing. For the evaluator, this means going back and redoing
413 the dispatch on the car of the form. */
417 SCM_SETCAR (vloc
, real_var
);
418 return SCM_VARIABLE_LOC (real_var
);
423 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
425 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
431 #define unmemocar scm_unmemocar
433 SCM_SYMBOL (sym_three_question_marks
, "???");
436 scm_unmemocar (SCM form
, SCM env
)
438 if (!SCM_CONSP (form
))
442 SCM c
= SCM_CAR (form
);
443 if (SCM_VARIABLEP (c
))
445 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
446 if (SCM_FALSEP (sym
))
447 sym
= sym_three_question_marks
;
448 SCM_SETCAR (form
, sym
);
450 else if (SCM_ILOCP (c
))
452 unsigned long int ir
;
454 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
456 env
= SCM_CAAR (env
);
457 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
459 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
467 scm_eval_car (SCM pair
, SCM env
)
469 return SCM_XEVALCAR (pair
, env
);
474 * The following rewrite expressions and
475 * some memoized forms have different syntax
478 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
479 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
480 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
481 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
483 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
484 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
485 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
486 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
489 /* Check that the body denoted by XORIG is valid and rewrite it into
490 its internal form. The internal form of a body is just the body
491 itself, but prefixed with an ISYM that denotes to what kind of
492 outer construct this body belongs. A lambda body starts with
493 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
494 etc. The one exception is a body that belongs to a letrec that has
495 been formed by rewriting internal defines: it starts with
498 /* XXX - Besides controlling the rewriting of internal defines, the
499 additional ISYM could be used for improved error messages.
500 This is not done yet. */
503 scm_m_body (SCM op
, SCM xorig
, const char *what
)
505 SCM_ASSYNT (scm_ilength (xorig
) >= 1, s_body
, what
);
507 /* Don't add another ISYM if one is present already. */
508 if (SCM_ISYMP (SCM_CAR (xorig
)))
511 /* Retain possible doc string. */
512 if (!SCM_CONSP (SCM_CAR (xorig
)))
514 if (!SCM_NULLP (SCM_CDR (xorig
)))
515 return scm_cons (SCM_CAR (xorig
),
516 scm_m_body (op
, SCM_CDR (xorig
), what
));
520 return scm_cons (op
, xorig
);
524 /* Start of the memoizers for the standard R5RS builtin macros. */
527 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
528 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
531 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
533 long len
= scm_ilength (SCM_CDR (xorig
));
534 SCM_ASSYNT (len
>= 0, s_test
, s_and
);
536 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
542 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
543 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
546 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
548 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, s_expression
, s_begin
);
549 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
553 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
554 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
557 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
560 SCM cdrx
= SCM_CDR (xorig
);
561 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, s_clauses
, s_case
);
562 clauses
= SCM_CDR (cdrx
);
563 while (!SCM_NULLP (clauses
))
565 SCM clause
= SCM_CAR (clauses
);
566 SCM_ASSYNT (scm_ilength (clause
) >= 2, s_clauses
, s_case
);
567 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
568 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
569 && SCM_NULLP (SCM_CDR (clauses
))),
571 clauses
= SCM_CDR (clauses
);
573 return scm_cons (SCM_IM_CASE
, cdrx
);
577 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
578 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
581 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
583 SCM cdrx
= SCM_CDR (xorig
);
585 SCM_ASSYNT (scm_ilength (clauses
) >= 1, s_clauses
, s_cond
);
586 while (!SCM_NULLP (clauses
))
588 SCM clause
= SCM_CAR (clauses
);
589 long len
= scm_ilength (clause
);
590 SCM_ASSYNT (len
>= 1, s_clauses
, s_cond
);
591 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
593 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
594 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
596 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
598 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
599 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
601 clauses
= SCM_CDR (clauses
);
603 return scm_cons (SCM_IM_COND
, cdrx
);
607 SCM_SYNTAX(s_define
, "define", scm_i_makbimacro
, scm_m_define
);
608 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
610 /* Guile provides an extension to R5RS' define syntax to represent function
611 * currying in a compact way. With this extension, it is allowed to write
612 * (define <nested-variable> <body>), where <nested-variable> has of one of
613 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
614 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
615 * should be either a sequence of zero or more variables, or a sequence of one
616 * or more variables followed by a space-delimited period and another
617 * variable. Each level of argument nesting wraps the <body> within another
618 * lambda expression. For example, the following forms are allowed, each one
619 * followed by an equivalent, more explicit implementation.
621 * (define ((a b . c) . d) <body>) is equivalent to
622 * (define a (lambda (b . c) (lambda d <body>)))
624 * (define (((a) b) c . d) <body>) is equivalent to
625 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
627 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
628 * module that does not implement this extension. */
630 scm_m_define (SCM x
, SCM env
)
634 SCM_ASSYNT (scm_ilength (x
) >= 2, s_expression
, s_define
);
637 while (SCM_CONSP (name
))
639 /* This while loop realizes function currying by variable nesting. */
640 SCM formals
= SCM_CDR (name
);
641 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
642 name
= SCM_CAR (name
);
644 SCM_ASSYNT (SCM_SYMBOLP (name
), s_variable
, s_define
);
645 SCM_ASSYNT (scm_ilength (x
) == 1, s_expression
, s_define
);
646 if (SCM_TOP_LEVEL (env
))
649 x
= scm_eval_car (x
, env
);
650 if (SCM_REC_PROCNAMES_P
)
653 while (SCM_MACROP (tmp
))
654 tmp
= SCM_MACRO_CODE (tmp
);
655 if (SCM_CLOSUREP (tmp
)
656 /* Only the first definition determines the name. */
657 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
658 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
660 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
661 SCM_VARIABLE_SET (var
, x
);
662 return SCM_UNSPECIFIED
;
665 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
669 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
670 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
672 /* Promises are implemented as closures with an empty parameter list. Thus,
673 * (delay <expression>) is transformed into (#@delay '() <expression>), where
674 * the empty list represents the empty parameter list. This representation
675 * allows for easy creation of the closure during evaluation. */
677 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
679 SCM_ASSYNT (scm_ilength (xorig
) == 2, s_expression
, s_delay
);
680 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
684 /* DO gets the most radically altered syntax. The order of the vars is
685 * reversed here. In contrast, the order of the inits and steps is reversed
686 * during the evaluation:
688 (do ((<var1> <init1> <step1>)
696 (#@do (<init1> <init2> ... <initn>)
700 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
703 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
704 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
707 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
710 SCM x
= SCM_CDR (xorig
);
713 SCM
*initloc
= &inits
;
715 SCM
*steploc
= &steps
;
716 SCM_ASSYNT (scm_ilength (x
) >= 2, s_test
, "do");
717 bindings
= SCM_CAR (x
);
718 SCM_ASSYNT (scm_ilength (bindings
) >= 0, s_bindings
, "do");
719 while (!SCM_NULLP (bindings
))
721 SCM binding
= SCM_CAR (bindings
);
722 long len
= scm_ilength (binding
);
723 SCM_ASSYNT (len
== 2 || len
== 3, s_bindings
, "do");
725 SCM name
= SCM_CAR (binding
);
726 SCM init
= SCM_CADR (binding
);
727 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
728 SCM_ASSYNT (SCM_SYMBOLP (name
), s_variable
, "do");
729 vars
= scm_cons (name
, vars
);
730 *initloc
= scm_list_1 (init
);
731 initloc
= SCM_CDRLOC (*initloc
);
732 *steploc
= scm_list_1 (step
);
733 steploc
= SCM_CDRLOC (*steploc
);
734 bindings
= SCM_CDR (bindings
);
738 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, s_test
, "do");
739 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
740 x
= scm_cons2 (inits
, vars
, x
);
741 return scm_cons (SCM_IM_DO
, x
);
745 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
746 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
749 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
751 long len
= scm_ilength (SCM_CDR (xorig
));
752 SCM_ASSYNT (len
>= 2 && len
<= 3, s_expression
, s_if
);
753 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
757 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
758 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
760 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
761 * cdr of the last cons. (Thus, LIST is not required to be a proper
762 * list and OBJ can also be found in the improper ending.) */
764 scm_c_improper_memq (SCM obj
, SCM list
)
766 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
768 if (SCM_EQ_P (SCM_CAR (list
), obj
))
771 return SCM_EQ_P (list
, obj
);
775 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
778 SCM x
= SCM_CDR (xorig
);
780 SCM_ASSYNT (SCM_CONSP (x
), s_formals
, s_lambda
);
782 formals
= SCM_CAR (x
);
783 while (SCM_CONSP (formals
))
785 SCM formal
= SCM_CAR (formals
);
786 SCM_ASSYNT (SCM_SYMBOLP (formal
), s_formals
, s_lambda
);
787 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
788 scm_misc_error (s_lambda
, s_duplicate_formals
, SCM_EOL
);
789 formals
= SCM_CDR (formals
);
791 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
792 scm_misc_error (s_lambda
, s_formals
, SCM_EOL
);
794 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
795 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
799 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
800 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
801 * reversed here, the list of inits gets reversed during evaluation. */
803 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
809 SCM_ASSYNT (scm_ilength (bindings
) >= 1, s_bindings
, what
);
813 SCM binding
= SCM_CAR (bindings
);
814 SCM_ASSYNT (scm_ilength (binding
) == 2, s_bindings
, what
);
815 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), s_variable
, what
);
816 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
817 scm_misc_error (what
, s_duplicate_bindings
, SCM_EOL
);
818 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
819 *initloc
= scm_list_1 (SCM_CADR (binding
));
820 initloc
= SCM_CDRLOC (*initloc
);
821 bindings
= SCM_CDR (bindings
);
823 while (!SCM_NULLP (bindings
));
829 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
830 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
833 scm_m_let (SCM xorig
, SCM env
)
835 SCM x
= SCM_CDR (xorig
);
838 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_let
);
841 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
843 /* null or single binding, let* is faster */
845 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
846 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
848 else if (SCM_CONSP (temp
))
852 SCM rvars
, inits
, body
;
853 transform_bindings (bindings
, &rvars
, &inits
, "let");
854 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
855 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
859 /* named let: Transform (let name ((var init) ...) body ...) into
860 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
866 SCM
*initloc
= &inits
;
869 SCM_ASSYNT (SCM_SYMBOLP (name
), s_bindings
, s_let
);
871 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_let
);
872 bindings
= SCM_CAR (x
);
873 SCM_ASSYNT (scm_ilength (bindings
) >= 0, s_bindings
, s_let
);
874 while (!SCM_NULLP (bindings
))
875 { /* vars and inits both in order */
876 SCM binding
= SCM_CAR (bindings
);
877 SCM_ASSYNT (scm_ilength (binding
) == 2, s_bindings
, s_let
);
878 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), s_variable
, s_let
);
879 *varloc
= scm_list_1 (SCM_CAR (binding
));
880 varloc
= SCM_CDRLOC (*varloc
);
881 *initloc
= scm_list_1 (SCM_CADR (binding
));
882 initloc
= SCM_CDRLOC (*initloc
);
883 bindings
= SCM_CDR (bindings
);
887 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
888 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
889 SCM rvar
= scm_list_1 (name
);
890 SCM init
= scm_list_1 (lambda_form
);
891 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
892 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
893 return scm_cons (letrec
, inits
);
899 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
900 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
902 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
903 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
905 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
908 SCM x
= SCM_CDR (xorig
);
912 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_letstar
);
914 bindings
= SCM_CAR (x
);
915 SCM_ASSYNT (scm_ilength (bindings
) >= 0, s_bindings
, s_letstar
);
916 while (!SCM_NULLP (bindings
))
918 SCM binding
= SCM_CAR (bindings
);
919 SCM_ASSYNT (scm_ilength (binding
) == 2, s_bindings
, s_letstar
);
920 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), s_variable
, s_letstar
);
921 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
922 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
923 bindings
= SCM_CDR (bindings
);
926 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
927 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
931 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
932 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
935 scm_m_letrec (SCM xorig
, SCM env
)
937 SCM x
= SCM_CDR (xorig
);
938 SCM_ASSYNT (SCM_CONSP (x
), s_bindings
, s_letrec
);
940 if (SCM_NULLP (SCM_CAR (x
)))
942 /* null binding, let* faster */
943 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
944 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
948 SCM rvars
, inits
, body
;
949 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
950 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
951 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
956 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
957 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
960 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
962 long len
= scm_ilength (SCM_CDR (xorig
));
963 SCM_ASSYNT (len
>= 0, s_test
, s_or
);
965 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
971 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
972 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
974 /* Internal function to handle a quasiquotation: 'form' is the parameter in
975 * the call (quasiquotation form), 'env' is the environment where unquoted
976 * expressions will be evaluated, and 'depth' is the current quasiquotation
977 * nesting level and is known to be greater than zero. */
979 iqq (SCM form
, SCM env
, unsigned long int depth
)
981 if (SCM_CONSP (form
))
983 SCM tmp
= SCM_CAR (form
);
984 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
986 SCM args
= SCM_CDR (form
);
987 SCM_ASSYNT (scm_ilength (args
) == 1, s_expression
, s_quasiquote
);
988 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
990 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
992 SCM args
= SCM_CDR (form
);
993 SCM_ASSYNT (scm_ilength (args
) == 1, s_expression
, s_quasiquote
);
995 return scm_eval_car (args
, env
);
997 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
999 else if (SCM_CONSP (tmp
)
1000 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1002 SCM args
= SCM_CDR (tmp
);
1003 SCM_ASSYNT (scm_ilength (args
) == 1, s_expression
, s_quasiquote
);
1006 SCM list
= scm_eval_car (args
, env
);
1007 SCM rest
= SCM_CDR (form
);
1008 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
1009 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1012 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1013 iqq (SCM_CDR (form
), env
, depth
));
1016 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1017 iqq (SCM_CDR (form
), env
, depth
));
1019 else if (SCM_VECTORP (form
))
1021 size_t i
= SCM_VECTOR_LENGTH (form
);
1022 SCM
const *const data
= SCM_VELTS (form
);
1025 tmp
= scm_cons (data
[--i
], tmp
);
1026 scm_remember_upto_here_1 (form
);
1027 return scm_vector (iqq (tmp
, env
, depth
));
1034 scm_m_quasiquote (SCM xorig
, SCM env
)
1036 SCM x
= SCM_CDR (xorig
);
1037 SCM_ASSYNT (scm_ilength (x
) == 1, s_expression
, s_quasiquote
);
1038 return iqq (SCM_CAR (x
), env
, 1);
1042 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1043 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1046 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
1048 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, s_expression
, s_quote
);
1049 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
1053 /* Will go into the RnRS module when Guile is factorized.
1054 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1055 static const char s_set_x
[] = "set!";
1056 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1059 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1061 SCM x
= SCM_CDR (xorig
);
1062 SCM_ASSYNT (scm_ilength (x
) == 2, s_expression
, s_set_x
);
1063 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), s_variable
, s_set_x
);
1064 return scm_cons (SCM_IM_SET_X
, x
);
1068 /* Start of the memoizers for non-R5RS builtin macros. */
1071 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1072 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1073 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1076 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1078 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, s_expression
, s_atapply
);
1079 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1083 /* (@bind ((var exp) ...) body ...)
1085 This will assign the values of the `exp's to the global variables
1086 named by `var's (symbols, not evaluated), creating them if they
1087 don't exist, executes body, and then restores the previous values of
1088 the `var's. Additionally, whenever control leaves body, the values
1089 of the `var's are saved and restored when control returns. It is an
1090 error when a symbol appears more than once among the `var's.
1091 All `exp's are evaluated before any `var' is set.
1093 Think of this as `let' for dynamic scope.
1095 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1097 XXX - also implement `@bind*'.
1100 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1103 scm_m_atbind (SCM xorig
, SCM env
)
1105 SCM x
= SCM_CDR (xorig
);
1106 SCM top_level
= scm_env_top_level (env
);
1107 SCM vars
= SCM_EOL
, var
;
1110 SCM_ASSYNT (scm_ilength (x
) > 1, s_expression
, s_atbind
);
1113 while (SCM_NIMP (x
))
1116 SCM sym_exp
= SCM_CAR (x
);
1117 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, s_bindings
, s_atbind
);
1118 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), s_bindings
, s_atbind
);
1120 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1121 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1122 scm_misc_error (s_atbind
, s_duplicate_bindings
, SCM_EOL
);
1123 /* The first call to scm_sym2var will look beyond the current
1124 module, while the second call wont. */
1125 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1126 if (SCM_FALSEP (var
))
1127 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1128 vars
= scm_cons (var
, vars
);
1129 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1131 return scm_cons (SCM_IM_BIND
,
1132 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1137 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1138 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1142 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1144 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1145 s_expression
, s_atcall_cc
);
1146 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1150 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1151 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1154 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1156 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1157 s_expression
, s_at_call_with_values
);
1158 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1162 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1163 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1165 /* Like promises, futures are implemented as closures with an empty
1166 * parameter list. Thus, (future <expression>) is transformed into
1167 * (#@future '() <expression>), where the empty list represents the
1168 * empty parameter list. This representation allows for easy creation
1169 * of the closure during evaluation. */
1171 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
1173 SCM_ASSYNT (scm_ilength (xorig
) == 2, s_expression
, s_future
);
1174 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
1178 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1179 SCM_SYMBOL (scm_sym_setter
, "setter");
1182 scm_m_generalized_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1184 SCM x
= SCM_CDR (xorig
);
1185 SCM_ASSYNT (2 == scm_ilength (x
), s_expression
, s_set_x
);
1186 if (SCM_SYMBOLP (SCM_CAR (x
)))
1187 return scm_cons (SCM_IM_SET_X
, x
);
1188 else if (SCM_CONSP (SCM_CAR (x
)))
1189 return scm_cons (scm_list_2 (scm_sym_setter
, SCM_CAAR (x
)),
1190 scm_append (scm_list_2 (SCM_CDAR (x
), SCM_CDR (x
))));
1192 scm_misc_error (s_set_x
, s_variable
, SCM_EOL
);
1196 static const char* s_atslot_ref
= "@slot-ref";
1198 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1199 * soon as the module system allows us to more freely create bindings in
1200 * arbitrary modules during the startup phase, the code from goops.c should be
1203 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1204 #define FUNC_NAME s_atslot_ref
1206 SCM x
= SCM_CDR (xorig
);
1207 SCM_ASSYNT (scm_ilength (x
) == 2, s_expression
, FUNC_NAME
);
1208 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1209 return scm_cons (SCM_IM_SLOT_REF
, x
);
1214 static const char* s_atslot_set_x
= "@slot-set!";
1216 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1217 * soon as the module system allows us to more freely create bindings in
1218 * arbitrary modules during the startup phase, the code from goops.c should be
1221 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1222 #define FUNC_NAME s_atslot_set_x
1224 SCM x
= SCM_CDR (xorig
);
1225 SCM_ASSYNT (scm_ilength (x
) == 3, s_expression
, FUNC_NAME
);
1226 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1227 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1232 #if SCM_ENABLE_ELISP
1234 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1237 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1239 long len
= scm_ilength (SCM_CDR (xorig
));
1240 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, s_expression
, "nil-cond");
1241 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1245 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1248 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1250 SCM x
= SCM_CDR (xorig
), var
;
1251 SCM_ASSYNT (scm_ilength (x
) >= 1, s_expression
, "@fop");
1252 var
= scm_symbol_fref (SCM_CAR (x
));
1253 /* Passing the symbol name as the `subr' arg here isn't really
1254 right, but without it it can be very difficult to work out from
1255 the error message which function definition was missing. In any
1256 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1257 something equivalent to (signal void-function (list SYM)) in
1259 SCM_ASSYNT (SCM_VARIABLEP (var
),
1260 "Symbol's function definition is void",
1261 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1262 /* Support `defalias'. */
1263 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1265 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1266 SCM_ASSYNT (SCM_VARIABLEP (var
),
1267 "Symbol's function definition is void",
1268 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1270 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1271 former allows for automatically picking up redefinitions of the
1272 corresponding symbol. */
1273 SCM_SETCAR (x
, var
);
1274 /* If the variable contains a procedure, leave the
1275 `transformer-macro' in place so that the procedure's arguments
1276 get properly transformed, and change the initial @fop to
1278 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1280 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1283 /* Otherwise (the variable contains a macro), the arguments should
1284 not be transformed, so cut the `transformer-macro' out and return
1285 the resulting expression starting with the variable. */
1286 SCM_SETCDR (x
, SCM_CDADR (x
));
1290 #endif /* SCM_ENABLE_ELISP */
1293 /* Start of the memoizers for deprecated macros. */
1296 #if (SCM_ENABLE_DEPRECATED == 1)
1298 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1301 scm_m_undefine (SCM x
, SCM env
)
1305 SCM_ASSYNT (SCM_TOP_LEVEL (env
), "bad placement ", s_undefine
);
1306 SCM_ASSYNT (SCM_CONSP (x
) && SCM_NULLP (SCM_CDR (x
)),
1307 s_expression
, s_undefine
);
1309 SCM_ASSYNT (SCM_SYMBOLP (x
), s_variable
, s_undefine
);
1310 arg1
= scm_sym2var (x
, scm_env_top_level (env
), SCM_BOOL_F
);
1311 SCM_ASSYNT (!SCM_FALSEP (arg1
) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1
)),
1312 "variable already unbound ", s_undefine
);
1313 SCM_VARIABLE_SET (arg1
, SCM_UNDEFINED
);
1317 return SCM_UNSPECIFIED
;
1325 scm_m_expand_body (SCM xorig
, SCM env
)
1327 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1328 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1330 while (SCM_NIMP (x
))
1332 SCM form
= SCM_CAR (x
);
1333 if (!SCM_CONSP (form
))
1335 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1338 form
= scm_macroexp (scm_cons_source (form
,
1343 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1345 defs
= scm_cons (SCM_CDR (form
), defs
);
1348 else if (!SCM_IMP (defs
))
1352 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1354 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1358 x
= scm_cons (form
, SCM_CDR (x
));
1363 if (!SCM_NULLP (defs
))
1365 SCM rvars
, inits
, body
, letrec
;
1366 transform_bindings (defs
, &rvars
, &inits
, what
);
1367 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1368 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1369 SCM_SETCAR (xorig
, letrec
);
1370 SCM_SETCDR (xorig
, SCM_EOL
);
1374 SCM_ASSYNT (SCM_CONSP (x
), s_body
, what
);
1375 SCM_SETCAR (xorig
, SCM_CAR (x
));
1376 SCM_SETCDR (xorig
, SCM_CDR (x
));
1383 scm_macroexp (SCM x
, SCM env
)
1385 SCM res
, proc
, orig_sym
;
1387 /* Don't bother to produce error messages here. We get them when we
1388 eventually execute the code for real. */
1391 orig_sym
= SCM_CAR (x
);
1392 if (!SCM_SYMBOLP (orig_sym
))
1396 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1397 if (proc_ptr
== NULL
)
1399 /* We have lost the race. */
1405 /* Only handle memoizing macros. `Acros' and `macros' are really
1406 special forms and should not be evaluated here. */
1408 if (!SCM_MACROP (proc
)
1409 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1412 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1413 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1415 if (scm_ilength (res
) <= 0)
1416 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1419 SCM_SETCAR (x
, SCM_CAR (res
));
1420 SCM_SETCDR (x
, SCM_CDR (res
));
1426 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1428 /* A function object to implement "apply" for non-closure functions. */
1430 /* An endless list consisting of #<undefined> objects: */
1431 static SCM undefineds
;
1433 /* scm_unmemocopy takes a memoized expression together with its
1434 * environment and rewrites it to its original form. Thus, it is the
1435 * inversion of the rewrite rules above. The procedure is not
1436 * optimized for speed. It's used in scm_iprin1 when printing the
1437 * code of a closure, in scm_procedure_source, in display_frame when
1438 * generating the source for a stackframe in a backtrace, and in
1439 * display_expression.
1441 * Unmemoizing is not a reliable process. You cannot in general
1442 * expect to get the original source back.
1444 * However, GOOPS currently relies on this for method compilation.
1445 * This ought to change.
1449 build_binding_list (SCM names
, SCM inits
)
1451 SCM bindings
= SCM_EOL
;
1452 while (!SCM_NULLP (names
))
1454 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1455 bindings
= scm_cons (binding
, bindings
);
1456 names
= SCM_CDR (names
);
1457 inits
= SCM_CDR (inits
);
1463 unmemocopy (SCM x
, SCM env
)
1469 p
= scm_whash_lookup (scm_source_whash
, x
);
1470 switch (SCM_ITAG7 (SCM_CAR (x
)))
1472 case SCM_BIT7 (SCM_IM_AND
):
1473 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1475 case SCM_BIT7 (SCM_IM_BEGIN
):
1476 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1478 case SCM_BIT7 (SCM_IM_CASE
):
1479 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1481 case SCM_BIT7 (SCM_IM_COND
):
1482 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1484 case SCM_BIT7 (SCM_IM_DO
):
1486 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
1487 * where ix is an initializer for a local variable, nx is the name of
1488 * the local variable, test is the test clause of the do loop, body is
1489 * the body of the do loop and sx are the step clauses for the local
1491 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1494 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1496 names
= SCM_CAR (x
);
1497 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1499 test
= unmemocopy (SCM_CAR (x
), env
);
1501 memoized_body
= SCM_CAR (x
);
1503 steps
= scm_reverse (unmemocopy (x
, env
));
1505 /* build transformed binding list */
1507 while (!SCM_NULLP (names
))
1509 SCM name
= SCM_CAR (names
);
1510 SCM init
= SCM_CAR (inits
);
1511 SCM step
= SCM_CAR (steps
);
1512 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1514 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1516 names
= SCM_CDR (names
);
1517 inits
= SCM_CDR (inits
);
1518 steps
= SCM_CDR (steps
);
1520 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1521 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1523 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1526 case SCM_BIT7 (SCM_IM_IF
):
1527 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1529 case SCM_BIT7 (SCM_IM_LET
):
1531 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1532 * where nx is the name of a local variable, ix is an initializer for
1533 * the local variable and by are the body clauses. */
1534 SCM names
, inits
, bindings
;
1537 names
= SCM_CAR (x
);
1539 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1540 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1542 bindings
= build_binding_list (names
, inits
);
1543 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1544 ls
= scm_cons (scm_sym_let
, z
);
1547 case SCM_BIT7 (SCM_IM_LETREC
):
1549 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1550 * where nx is the name of a local variable, ix is an initializer for
1551 * the local variable and by are the body clauses. */
1552 SCM names
, inits
, bindings
;
1555 names
= SCM_CAR (x
);
1556 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1558 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1560 bindings
= build_binding_list (names
, inits
);
1561 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1562 ls
= scm_cons (scm_sym_letrec
, z
);
1565 case SCM_BIT7 (SCM_IM_LETSTAR
):
1573 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1576 y
= z
= scm_acons (SCM_CAR (b
),
1578 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1580 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1584 SCM_SETCDR (y
, SCM_EOL
);
1585 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1586 ls
= scm_cons (scm_sym_let
, z
);
1591 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1593 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1596 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1599 while (SCM_NIMP (b
));
1600 SCM_SETCDR (z
, SCM_EOL
);
1602 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1603 ls
= scm_cons (scm_sym_letstar
, z
);
1606 case SCM_BIT7 (SCM_IM_OR
):
1607 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1609 case SCM_BIT7 (SCM_IM_LAMBDA
):
1611 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1612 ls
= scm_cons (scm_sym_lambda
, z
);
1613 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1615 case SCM_BIT7 (SCM_IM_QUOTE
):
1616 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1618 case SCM_BIT7 (SCM_IM_SET_X
):
1619 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1621 case SCM_BIT7 (SCM_IM_DEFINE
):
1626 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1627 ls
= scm_cons (scm_sym_define
, z
);
1628 if (!SCM_NULLP (env
))
1629 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1634 case SCM_BIT7 (SCM_MAKISYM (0)):
1638 switch (SCM_ISYMNUM (z
))
1640 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1641 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1643 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1644 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1646 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1647 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1650 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1651 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1654 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1655 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1658 /* appease the Sun compiler god: */ ;
1662 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1668 while (SCM_CONSP (x
))
1670 SCM form
= SCM_CAR (x
);
1671 if (!SCM_ISYMP (form
))
1673 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1674 SCM_SETCDR (z
, unmemocar (copy
, env
));
1680 if (!SCM_FALSEP (p
))
1681 scm_whash_insert (scm_source_whash
, ls
, p
);
1687 scm_unmemocopy (SCM x
, SCM env
)
1689 if (!SCM_NULLP (env
))
1690 /* Make a copy of the lowest frame to protect it from
1691 modifications by SCM_IM_DEFINE */
1692 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1694 return unmemocopy (x
, env
);
1699 scm_badargsp (SCM formals
, SCM args
)
1701 while (!SCM_NULLP (formals
))
1703 if (!SCM_CONSP (formals
))
1705 if (SCM_NULLP (args
))
1707 formals
= SCM_CDR (formals
);
1708 args
= SCM_CDR (args
);
1710 return !SCM_NULLP (args
) ? 1 : 0;
1715 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1717 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1718 while (SCM_CONSP (l
))
1720 res
= EVALCAR (l
, env
);
1722 *lloc
= scm_list_1 (res
);
1723 lloc
= SCM_CDRLOC (*lloc
);
1727 scm_wrong_num_args (proc
);
1733 scm_eval_body (SCM code
, SCM env
)
1737 next
= SCM_CDR (code
);
1738 while (!SCM_NULLP (next
))
1740 if (SCM_IMP (SCM_CAR (code
)))
1742 if (SCM_ISYMP (SCM_CAR (code
)))
1744 scm_rec_mutex_lock (&source_mutex
);
1745 /* check for race condition */
1746 if (SCM_ISYMP (SCM_CAR (code
)))
1747 code
= scm_m_expand_body (code
, env
);
1748 scm_rec_mutex_unlock (&source_mutex
);
1753 SCM_XEVAL (SCM_CAR (code
), env
);
1755 next
= SCM_CDR (code
);
1757 return SCM_XEVALCAR (code
, env
);
1763 /* SECTION: This code is specific for the debugging support. One
1764 * branch is read when DEVAL isn't defined, the other when DEVAL is
1770 #define SCM_APPLY scm_apply
1771 #define PREP_APPLY(proc, args)
1773 #define RETURN(x) do { return x; } while (0)
1774 #ifdef STACK_CHECKING
1775 #ifndef NO_CEVAL_STACK_CHECKING
1776 #define EVAL_STACK_CHECKING
1783 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1785 #define SCM_APPLY scm_dapply
1787 #define PREP_APPLY(p, l) \
1788 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1790 #define ENTER_APPLY \
1792 SCM_SET_ARGSREADY (debug);\
1793 if (scm_check_apply_p && SCM_TRAPS_P)\
1794 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1796 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1797 SCM_SET_TRACED_FRAME (debug); \
1799 if (SCM_CHEAPTRAPS_P)\
1801 tmp = scm_make_debugobj (&debug);\
1802 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1807 tmp = scm_make_continuation (&first);\
1809 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1815 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1816 #ifdef STACK_CHECKING
1817 #ifndef EVAL_STACK_CHECKING
1818 #define EVAL_STACK_CHECKING
1822 /* scm_ceval_ptr points to the currently selected evaluator.
1823 * *fixme*: Although efficiency is important here, this state variable
1824 * should probably not be a global. It should be related to the
1829 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1831 /* scm_last_debug_frame contains a pointer to the last debugging
1832 * information stack frame. It is accessed very often from the
1833 * debugging evaluator, so it should probably not be indirectly
1834 * addressed. Better to save and restore it from the current root at
1838 /* scm_debug_eframe_size is the number of slots available for pseudo
1839 * stack frames at each real stack frame.
1842 long scm_debug_eframe_size
;
1844 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1846 long scm_eval_stack
;
1848 scm_t_option scm_eval_opts
[] = {
1849 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1852 scm_t_option scm_debug_opts
[] = {
1853 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1854 "*Flyweight representation of the stack at traps." },
1855 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1856 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1857 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1858 "Record procedure names at definition." },
1859 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1860 "Display backtrace in anti-chronological order." },
1861 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1862 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1863 { SCM_OPTION_INTEGER
, "frames", 3,
1864 "Maximum number of tail-recursive frames in backtrace." },
1865 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1866 "Maximal number of stored backtrace frames." },
1867 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1868 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1869 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1870 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1871 { 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."}
1874 scm_t_option scm_evaluator_trap_table
[] = {
1875 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1876 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1877 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1878 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1879 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1880 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1881 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1884 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1886 "Option interface for the evaluation options. Instead of using\n"
1887 "this procedure directly, use the procedures @code{eval-enable},\n"
1888 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1889 #define FUNC_NAME s_scm_eval_options_interface
1893 ans
= scm_options (setting
,
1897 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1904 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1906 "Option interface for the evaluator trap options.")
1907 #define FUNC_NAME s_scm_evaluator_traps
1911 ans
= scm_options (setting
,
1912 scm_evaluator_trap_table
,
1913 SCM_N_EVALUATOR_TRAPS
,
1915 SCM_RESET_DEBUG_MODE
;
1923 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1925 SCM
*results
= lloc
, res
;
1926 while (SCM_CONSP (l
))
1928 res
= EVALCAR (l
, env
);
1930 *lloc
= scm_list_1 (res
);
1931 lloc
= SCM_CDRLOC (*lloc
);
1935 scm_wrong_num_args (proc
);
1942 /* SECTION: This code is compiled twice.
1946 /* Update the toplevel environment frame ENV so that it refers to the
1947 * current module. */
1948 #define UPDATE_TOPLEVEL_ENV(env) \
1950 SCM p = scm_current_module_lookup_closure (); \
1951 if (p != SCM_CAR (env)) \
1952 env = scm_top_level_env (p); \
1956 /* This is the evaluator. Like any real monster, it has three heads:
1958 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1959 * version. Both are implemented using a common code base, using the
1960 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1961 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1962 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1963 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1964 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1965 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1966 * are enclosed within #ifdef DEVAL ... #endif.
1968 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1969 * take two input parameters, x and env: x is a single expression to be
1970 * evalutated. env is the environment in which bindings are searched.
1972 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1973 * is a single expression, it is necessarily in a tail position. If x is just
1974 * a call to another function like in the expression (foo exp1 exp2 ...), the
1975 * realization of that call therefore _must_not_ increase stack usage (the
1976 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1977 * making extensive use of 'goto' statements within the evaluator: The gotos
1978 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1979 * that SCM_CEVAL was already using. If, however, x represents some form that
1980 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1981 * then recursive calls to SCM_CEVAL are performed for all but the last
1982 * expression of that sequence. */
1986 scm_ceval (SCM x
, SCM env
)
1992 scm_deval (SCM x
, SCM env
)
1997 SCM_CEVAL (SCM x
, SCM env
)
2001 scm_t_debug_frame debug
;
2002 scm_t_debug_info
*debug_info_end
;
2003 debug
.prev
= scm_last_debug_frame
;
2006 * The debug.vect contains twice as much scm_t_debug_info frames as the
2007 * user has specified with (debug-set! frames <n>).
2009 * Even frames are eval frames, odd frames are apply frames.
2011 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2012 * sizeof (scm_t_debug_info
));
2013 debug
.info
= debug
.vect
;
2014 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2015 scm_last_debug_frame
= &debug
;
2017 #ifdef EVAL_STACK_CHECKING
2018 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2021 debug
.info
->e
.exp
= x
;
2022 debug
.info
->e
.env
= env
;
2024 scm_report_stack_overflow ();
2034 SCM_CLEAR_ARGSREADY (debug
);
2035 if (SCM_OVERFLOWP (debug
))
2038 * In theory, this should be the only place where it is necessary to
2039 * check for space in debug.vect since both eval frames and
2040 * available space are even.
2042 * For this to be the case, however, it is necessary that primitive
2043 * special forms which jump back to `loop', `begin' or some similar
2044 * label call PREP_APPLY.
2046 else if (++debug
.info
>= debug_info_end
)
2048 SCM_SET_OVERFLOW (debug
);
2053 debug
.info
->e
.exp
= x
;
2054 debug
.info
->e
.env
= env
;
2055 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2057 if (SCM_ENTER_FRAME_P
2058 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2061 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2062 SCM_SET_TAILREC (debug
);
2063 if (SCM_CHEAPTRAPS_P
)
2064 stackrep
= scm_make_debugobj (&debug
);
2068 SCM val
= scm_make_continuation (&first
);
2078 /* This gives the possibility for the debugger to
2079 modify the source expression before evaluation. */
2084 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2085 scm_sym_enter_frame
,
2088 scm_unmemocopy (x
, env
));
2095 switch (SCM_TYP7 (x
))
2097 case scm_tc7_symbol
:
2098 /* Only happens when called at top level. */
2099 x
= scm_cons (x
, SCM_UNDEFINED
);
2100 RETURN (*scm_lookupcar (x
, env
, 1));
2102 case SCM_BIT7 (SCM_IM_AND
):
2104 while (!SCM_NULLP (SCM_CDR (x
)))
2106 SCM test_result
= EVALCAR (x
, env
);
2107 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2108 RETURN (SCM_BOOL_F
);
2112 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2115 case SCM_BIT7 (SCM_IM_BEGIN
):
2118 RETURN (SCM_UNSPECIFIED
);
2120 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2123 /* If we are on toplevel with a lookup closure, we need to sync
2124 with the current module. */
2125 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2127 UPDATE_TOPLEVEL_ENV (env
);
2128 while (!SCM_NULLP (SCM_CDR (x
)))
2131 UPDATE_TOPLEVEL_ENV (env
);
2137 goto nontoplevel_begin
;
2140 while (!SCM_NULLP (SCM_CDR (x
)))
2142 SCM form
= SCM_CAR (x
);
2145 if (SCM_ISYMP (form
))
2147 scm_rec_mutex_lock (&source_mutex
);
2148 /* check for race condition */
2149 if (SCM_ISYMP (SCM_CAR (x
)))
2150 x
= scm_m_expand_body (x
, env
);
2151 scm_rec_mutex_unlock (&source_mutex
);
2152 goto nontoplevel_begin
;
2155 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2158 SCM_CEVAL (form
, env
);
2164 /* scm_eval last form in list */
2165 SCM last_form
= SCM_CAR (x
);
2167 if (SCM_CONSP (last_form
))
2169 /* This is by far the most frequent case. */
2171 goto loop
; /* tail recurse */
2173 else if (SCM_IMP (last_form
))
2174 RETURN (SCM_EVALIM (last_form
, env
));
2175 else if (SCM_VARIABLEP (last_form
))
2176 RETURN (SCM_VARIABLE_REF (last_form
));
2177 else if (SCM_SYMBOLP (last_form
))
2178 RETURN (*scm_lookupcar (x
, env
, 1));
2184 case SCM_BIT7 (SCM_IM_CASE
):
2187 SCM key
= EVALCAR (x
, env
);
2189 while (!SCM_NULLP (x
))
2191 SCM clause
= SCM_CAR (x
);
2192 SCM labels
= SCM_CAR (clause
);
2193 if (SCM_EQ_P (labels
, scm_sym_else
))
2195 x
= SCM_CDR (clause
);
2196 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2199 while (!SCM_NULLP (labels
))
2201 SCM label
= SCM_CAR (labels
);
2202 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2204 x
= SCM_CDR (clause
);
2205 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2208 labels
= SCM_CDR (labels
);
2213 RETURN (SCM_UNSPECIFIED
);
2216 case SCM_BIT7 (SCM_IM_COND
):
2218 while (!SCM_NULLP (x
))
2220 SCM clause
= SCM_CAR (x
);
2221 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2223 x
= SCM_CDR (clause
);
2224 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2229 arg1
= EVALCAR (clause
, env
);
2230 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2232 x
= SCM_CDR (clause
);
2235 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2237 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2243 proc
= EVALCAR (proc
, env
);
2244 PREP_APPLY (proc
, scm_list_1 (arg1
));
2252 RETURN (SCM_UNSPECIFIED
);
2255 case SCM_BIT7 (SCM_IM_DO
):
2258 /* Compute the initialization values and the initial environment. */
2259 SCM init_forms
= SCM_CAR (x
);
2260 SCM init_values
= SCM_EOL
;
2261 while (!SCM_NULLP (init_forms
))
2263 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2264 init_forms
= SCM_CDR (init_forms
);
2267 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2271 SCM test_form
= SCM_CAR (x
);
2272 SCM body_forms
= SCM_CADR (x
);
2273 SCM step_forms
= SCM_CDDR (x
);
2275 SCM test_result
= EVALCAR (test_form
, env
);
2277 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2280 /* Evaluate body forms. */
2282 for (temp_forms
= body_forms
;
2283 !SCM_NULLP (temp_forms
);
2284 temp_forms
= SCM_CDR (temp_forms
))
2286 SCM form
= SCM_CAR (temp_forms
);
2287 /* Dirk:FIXME: We only need to eval forms, that may have a
2288 * side effect here. This is only true for forms that start
2289 * with a pair. All others are just constants. However,
2290 * since in the common case there is no constant expression
2291 * in a body of a do form, we just check for immediates here
2292 * and have SCM_CEVAL take care of other cases. In the long
2293 * run it would make sense to get rid of this test and have
2294 * the macro transformer of 'do' eliminate all forms that
2295 * have no sideeffect. */
2296 if (!SCM_IMP (form
))
2297 SCM_CEVAL (form
, env
);
2302 /* Evaluate the step expressions. */
2304 SCM step_values
= SCM_EOL
;
2305 for (temp_forms
= step_forms
;
2306 !SCM_NULLP (temp_forms
);
2307 temp_forms
= SCM_CDR (temp_forms
))
2309 SCM value
= EVALCAR (temp_forms
, env
);
2310 step_values
= scm_cons (value
, step_values
);
2312 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2317 test_result
= EVALCAR (test_form
, env
);
2322 RETURN (SCM_UNSPECIFIED
);
2323 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2324 goto nontoplevel_begin
;
2327 case SCM_BIT7 (SCM_IM_IF
):
2330 SCM test_result
= EVALCAR (x
, env
);
2331 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2337 RETURN (SCM_UNSPECIFIED
);
2340 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2344 case SCM_BIT7 (SCM_IM_LET
):
2347 SCM init_forms
= SCM_CADR (x
);
2348 SCM init_values
= SCM_EOL
;
2351 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2352 init_forms
= SCM_CDR (init_forms
);
2354 while (!SCM_NULLP (init_forms
));
2355 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2358 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2359 goto nontoplevel_begin
;
2362 case SCM_BIT7 (SCM_IM_LETREC
):
2364 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2367 SCM init_forms
= SCM_CAR (x
);
2368 SCM init_values
= SCM_EOL
;
2371 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2372 init_forms
= SCM_CDR (init_forms
);
2374 while (!SCM_NULLP (init_forms
));
2375 SCM_SETCDR (SCM_CAR (env
), init_values
);
2378 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2379 goto nontoplevel_begin
;
2382 case SCM_BIT7 (SCM_IM_LETSTAR
):
2385 SCM bindings
= SCM_CAR (x
);
2386 if (SCM_NULLP (bindings
))
2387 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2392 SCM name
= SCM_CAR (bindings
);
2393 SCM init
= SCM_CDR (bindings
);
2394 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2395 bindings
= SCM_CDR (init
);
2397 while (!SCM_NULLP (bindings
));
2401 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2402 goto nontoplevel_begin
;
2405 case SCM_BIT7 (SCM_IM_OR
):
2407 while (!SCM_NULLP (SCM_CDR (x
)))
2409 SCM val
= EVALCAR (x
, env
);
2410 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2415 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2419 case SCM_BIT7 (SCM_IM_LAMBDA
):
2420 RETURN (scm_closure (SCM_CDR (x
), env
));
2423 case SCM_BIT7 (SCM_IM_QUOTE
):
2424 RETURN (SCM_CADR (x
));
2427 case SCM_BIT7 (SCM_IM_SET_X
):
2431 SCM variable
= SCM_CAR (x
);
2432 if (SCM_ILOCP (variable
))
2433 location
= scm_ilookup (variable
, env
);
2434 else if (SCM_VARIABLEP (variable
))
2435 location
= SCM_VARIABLE_LOC (variable
);
2436 else /* (SCM_SYMBOLP (variable)) is known to be true */
2437 location
= scm_lookupcar (x
, env
, 1);
2439 *location
= EVALCAR (x
, env
);
2441 RETURN (SCM_UNSPECIFIED
);
2444 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2445 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2448 /* new syntactic forms go here. */
2449 case SCM_BIT7 (SCM_MAKISYM (0)):
2451 switch (SCM_ISYMNUM (proc
))
2455 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2457 proc
= EVALCAR (x
, env
);
2458 PREP_APPLY (proc
, SCM_EOL
);
2460 arg1
= EVALCAR (x
, env
);
2463 /* Go here to tail-apply a procedure. PROC is the procedure and
2464 * ARG1 is the list of arguments. PREP_APPLY must have been called
2465 * before jumping to apply_proc. */
2466 if (SCM_CLOSUREP (proc
))
2468 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2470 debug
.info
->a
.args
= arg1
;
2472 if (scm_badargsp (formals
, arg1
))
2473 scm_wrong_num_args (proc
);
2475 /* Copy argument list */
2476 if (SCM_NULL_OR_NIL_P (arg1
))
2477 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2480 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2482 arg1
= SCM_CDR (arg1
);
2483 while (!SCM_NULL_OR_NIL_P (arg1
))
2485 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2486 SCM_SETCDR (tail
, new_tail
);
2488 arg1
= SCM_CDR (arg1
);
2490 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2493 x
= SCM_CLOSURE_BODY (proc
);
2494 goto nontoplevel_begin
;
2499 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
2503 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2506 SCM val
= scm_make_continuation (&first
);
2514 proc
= scm_eval_car (proc
, env
);
2515 PREP_APPLY (proc
, scm_list_1 (arg1
));
2522 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2523 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2526 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2527 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2530 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
2531 following code (type_dispatch) is intended to be the tail
2532 of the case clause for the internal macro
2533 SCM_IM_DISPATCH. Please don't remove it from this
2534 location without discussing it with Mikael
2535 <djurfeldt@nada.kth.se> */
2537 /* The type dispatch code is duplicated below
2538 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2539 * cuts down execution time for type dispatch to 50%. */
2540 type_dispatch
: /* inputs: x, arg1 */
2541 /* Type dispatch means to determine from the types of the function
2542 * arguments (i. e. the 'signature' of the call), which method from
2543 * a generic function is to be called. This process of selecting
2544 * the right method takes some time. To speed it up, guile uses
2545 * caching: Together with the macro call to dispatch the signatures
2546 * of some previous calls to that generic function from the same
2547 * place are stored (in the code!) in a cache that we call the
2548 * 'method cache'. This is done since it is likely, that
2549 * consecutive calls to dispatch from that position in the code will
2550 * have the same signature. Thus, the type dispatch works as
2551 * follows: First, determine a hash value from the signature of the
2552 * actual arguments. Second, use this hash value as an index to
2553 * find that same signature in the method cache stored at this
2554 * position in the code. If found, you have also found the
2555 * corresponding method that belongs to that signature. If the
2556 * signature is not found in the method cache, you have to perform a
2557 * full search over all signatures stored with the generic
2560 unsigned long int specializers
;
2561 unsigned long int hash_value
;
2562 unsigned long int cache_end_pos
;
2563 unsigned long int mask
;
2567 SCM z
= SCM_CDDR (x
);
2568 SCM tmp
= SCM_CADR (z
);
2569 specializers
= SCM_INUM (SCM_CAR (z
));
2571 /* Compute a hash value for searching the method cache. There
2572 * are two variants for computing the hash value, a (rather)
2573 * complicated one, and a simple one. For the complicated one
2574 * explained below, tmp holds a number that is used in the
2576 if (SCM_INUMP (tmp
))
2578 /* Use the signature of the actual arguments to determine
2579 * the hash value. This is done as follows: Each class has
2580 * an array of random numbers, that are determined when the
2581 * class is created. The integer 'hashset' is an index into
2582 * that array of random numbers. Now, from all classes that
2583 * are part of the signature of the actual arguments, the
2584 * random numbers at index 'hashset' are taken and summed
2585 * up, giving the hash value. The value of 'hashset' is
2586 * stored at the call to dispatch. This allows to have
2587 * different 'formulas' for calculating the hash value at
2588 * different places where dispatch is called. This allows
2589 * to optimize the hash formula at every individual place
2590 * where dispatch is called, such that hopefully the hash
2591 * value that is computed will directly point to the right
2592 * method in the method cache. */
2593 unsigned long int hashset
= SCM_INUM (tmp
);
2594 unsigned long int counter
= specializers
+ 1;
2597 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2599 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2600 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2601 tmp_arg
= SCM_CDR (tmp_arg
);
2605 method_cache
= SCM_CADR (z
);
2606 mask
= SCM_INUM (SCM_CAR (z
));
2608 cache_end_pos
= hash_value
;
2612 /* This method of determining the hash value is much
2613 * simpler: Set the hash value to zero and just perform a
2614 * linear search through the method cache. */
2616 mask
= (unsigned long int) ((long) -1);
2618 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2623 /* Search the method cache for a method with a matching
2624 * signature. Start the search at position 'hash_value'. The
2625 * hashing implementation uses linear probing for conflict
2626 * resolution, that is, if the signature in question is not
2627 * found at the starting index in the hash table, the next table
2628 * entry is tried, and so on, until in the worst case the whole
2629 * cache has been searched, but still the signature has not been
2634 SCM args
= arg1
; /* list of arguments */
2635 z
= SCM_VELTS (method_cache
)[hash_value
];
2636 while (!SCM_NULLP (args
))
2638 /* More arguments than specifiers => CLASS != ENV */
2639 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2640 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2642 args
= SCM_CDR (args
);
2645 /* Fewer arguments than specifiers => CAR != ENV */
2646 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2649 hash_value
= (hash_value
+ 1) & mask
;
2650 } while (hash_value
!= cache_end_pos
);
2652 /* No appropriate method was found in the cache. */
2653 z
= scm_memoize_method (x
, arg1
);
2655 apply_cmethod
: /* inputs: z, arg1 */
2657 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2658 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2659 x
= SCM_CMETHOD_BODY (z
);
2660 goto nontoplevel_begin
;
2666 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2669 SCM instance
= EVALCAR (x
, env
);
2670 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2671 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2675 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2678 SCM instance
= EVALCAR (x
, env
);
2679 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2680 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2681 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2682 RETURN (SCM_UNSPECIFIED
);
2686 #if SCM_ENABLE_ELISP
2688 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2690 SCM test_form
= SCM_CDR (x
);
2691 x
= SCM_CDR (test_form
);
2692 while (!SCM_NULL_OR_NIL_P (x
))
2694 SCM test_result
= EVALCAR (test_form
, env
);
2695 if (!(SCM_FALSEP (test_result
)
2696 || SCM_NULL_OR_NIL_P (test_result
)))
2698 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2699 RETURN (test_result
);
2700 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2705 test_form
= SCM_CDR (x
);
2706 x
= SCM_CDR (test_form
);
2710 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2714 #endif /* SCM_ENABLE_ELISP */
2716 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2718 SCM vars
, exps
, vals
;
2721 vars
= SCM_CAAR (x
);
2722 exps
= SCM_CDAR (x
);
2726 while (SCM_NIMP (exps
))
2728 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2729 exps
= SCM_CDR (exps
);
2732 scm_swap_bindings (vars
, vals
);
2733 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2735 /* Ignore all but the last evaluation result. */
2736 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2738 if (SCM_CONSP (SCM_CAR (x
)))
2739 SCM_CEVAL (SCM_CAR (x
), env
);
2741 proc
= EVALCAR (x
, env
);
2743 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2744 scm_swap_bindings (vars
, vals
);
2750 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2755 producer
= EVALCAR (x
, env
);
2757 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
2758 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
2759 if (SCM_VALUESP (arg1
))
2760 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2762 arg1
= scm_list_1 (arg1
);
2763 PREP_APPLY (proc
, arg1
);
2775 case scm_tc7_vector
:
2779 case scm_tc7_byvect
:
2786 #if SCM_SIZEOF_LONG_LONG != 0
2787 case scm_tc7_llvect
:
2790 case scm_tc7_string
:
2792 case scm_tcs_closures
:
2796 case scm_tcs_struct
:
2799 case scm_tc7_variable
:
2800 RETURN (SCM_VARIABLE_REF(x
));
2802 case SCM_BIT7 (SCM_ILOC00
):
2803 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2806 case scm_tcs_cons_nimcar
:
2807 if (SCM_SYMBOLP (SCM_CAR (x
)))
2809 SCM orig_sym
= SCM_CAR (x
);
2811 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2812 if (location
== NULL
)
2814 /* we have lost the race, start again. */
2820 if (SCM_MACROP (proc
))
2822 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2824 handle_a_macro
: /* inputs: x, env, proc */
2826 /* Set a flag during macro expansion so that macro
2827 application frames can be deleted from the backtrace. */
2828 SCM_SET_MACROEXP (debug
);
2830 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2831 scm_cons (env
, scm_listofnull
));
2834 SCM_CLEAR_MACROEXP (debug
);
2836 switch (SCM_MACRO_TYPE (proc
))
2840 if (scm_ilength (arg1
) <= 0)
2841 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2843 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2846 SCM_SETCAR (x
, SCM_CAR (arg1
));
2847 SCM_SETCDR (x
, SCM_CDR (arg1
));
2851 /* Prevent memoizing of debug info expression. */
2852 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2857 SCM_SETCAR (x
, SCM_CAR (arg1
));
2858 SCM_SETCDR (x
, SCM_CDR (arg1
));
2860 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2862 #if SCM_ENABLE_DEPRECATED == 1
2867 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2879 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2882 if (SCM_MACROP (proc
))
2883 goto handle_a_macro
;
2887 evapply
: /* inputs: x, proc */
2888 PREP_APPLY (proc
, SCM_EOL
);
2889 if (SCM_NULLP (SCM_CDR (x
))) {
2892 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2893 switch (SCM_TYP7 (proc
))
2894 { /* no arguments given */
2895 case scm_tc7_subr_0
:
2896 RETURN (SCM_SUBRF (proc
) ());
2897 case scm_tc7_subr_1o
:
2898 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2900 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2901 case scm_tc7_rpsubr
:
2902 RETURN (SCM_BOOL_T
);
2904 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2906 if (!SCM_SMOB_APPLICABLE_P (proc
))
2908 RETURN (SCM_SMOB_APPLY_0 (proc
));
2911 proc
= SCM_CCLO_SUBR (proc
);
2913 debug
.info
->a
.proc
= proc
;
2914 debug
.info
->a
.args
= scm_list_1 (arg1
);
2918 proc
= SCM_PROCEDURE (proc
);
2920 debug
.info
->a
.proc
= proc
;
2922 if (!SCM_CLOSUREP (proc
))
2925 case scm_tcs_closures
:
2927 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2928 if (SCM_CONSP (formals
))
2929 goto umwrongnumargs
;
2930 x
= SCM_CLOSURE_BODY (proc
);
2931 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2932 goto nontoplevel_begin
;
2934 case scm_tcs_struct
:
2935 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2937 x
= SCM_ENTITY_PROCEDURE (proc
);
2941 else if (SCM_I_OPERATORP (proc
))
2944 proc
= (SCM_I_ENTITYP (proc
)
2945 ? SCM_ENTITY_PROCEDURE (proc
)
2946 : SCM_OPERATOR_PROCEDURE (proc
));
2948 debug
.info
->a
.proc
= proc
;
2949 debug
.info
->a
.args
= scm_list_1 (arg1
);
2955 case scm_tc7_subr_1
:
2956 case scm_tc7_subr_2
:
2957 case scm_tc7_subr_2o
:
2960 case scm_tc7_subr_3
:
2961 case scm_tc7_lsubr_2
:
2964 scm_wrong_num_args (proc
);
2967 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2971 /* must handle macros by here */
2974 arg1
= EVALCAR (x
, env
);
2976 scm_wrong_num_args (proc
);
2978 debug
.info
->a
.args
= scm_list_1 (arg1
);
2986 evap1
: /* inputs: proc, arg1 */
2987 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2988 switch (SCM_TYP7 (proc
))
2989 { /* have one argument in arg1 */
2990 case scm_tc7_subr_2o
:
2991 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2992 case scm_tc7_subr_1
:
2993 case scm_tc7_subr_1o
:
2994 RETURN (SCM_SUBRF (proc
) (arg1
));
2996 if (SCM_INUMP (arg1
))
2998 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3000 else if (SCM_REALP (arg1
))
3002 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3004 else if (SCM_BIGP (arg1
))
3006 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3008 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3009 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3012 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3015 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3016 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3017 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3022 case scm_tc7_rpsubr
:
3023 RETURN (SCM_BOOL_T
);
3025 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3028 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3030 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3033 if (!SCM_SMOB_APPLICABLE_P (proc
))
3035 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3039 proc
= SCM_CCLO_SUBR (proc
);
3041 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3042 debug
.info
->a
.proc
= proc
;
3046 proc
= SCM_PROCEDURE (proc
);
3048 debug
.info
->a
.proc
= proc
;
3050 if (!SCM_CLOSUREP (proc
))
3053 case scm_tcs_closures
:
3056 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3057 if (SCM_NULLP (formals
)
3058 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3059 goto umwrongnumargs
;
3060 x
= SCM_CLOSURE_BODY (proc
);
3062 env
= SCM_EXTEND_ENV (formals
,
3066 env
= SCM_EXTEND_ENV (formals
,
3070 goto nontoplevel_begin
;
3072 case scm_tcs_struct
:
3073 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3075 x
= SCM_ENTITY_PROCEDURE (proc
);
3077 arg1
= debug
.info
->a
.args
;
3079 arg1
= scm_list_1 (arg1
);
3083 else if (SCM_I_OPERATORP (proc
))
3087 proc
= (SCM_I_ENTITYP (proc
)
3088 ? SCM_ENTITY_PROCEDURE (proc
)
3089 : SCM_OPERATOR_PROCEDURE (proc
));
3091 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3092 debug
.info
->a
.proc
= proc
;
3098 case scm_tc7_subr_2
:
3099 case scm_tc7_subr_0
:
3100 case scm_tc7_subr_3
:
3101 case scm_tc7_lsubr_2
:
3102 scm_wrong_num_args (proc
);
3108 arg2
= EVALCAR (x
, env
);
3110 scm_wrong_num_args (proc
);
3112 { /* have two or more arguments */
3114 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3117 if (SCM_NULLP (x
)) {
3120 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3121 switch (SCM_TYP7 (proc
))
3122 { /* have two arguments */
3123 case scm_tc7_subr_2
:
3124 case scm_tc7_subr_2o
:
3125 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3128 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3130 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3132 case scm_tc7_lsubr_2
:
3133 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3134 case scm_tc7_rpsubr
:
3136 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3138 if (!SCM_SMOB_APPLICABLE_P (proc
))
3140 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3144 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3145 scm_cons (proc
, debug
.info
->a
.args
),
3148 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3149 scm_cons2 (proc
, arg1
,
3156 case scm_tcs_struct
:
3157 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3159 x
= SCM_ENTITY_PROCEDURE (proc
);
3161 arg1
= debug
.info
->a
.args
;
3163 arg1
= scm_list_2 (arg1
, arg2
);
3167 else if (SCM_I_OPERATORP (proc
))
3171 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3172 ? SCM_ENTITY_PROCEDURE (proc
)
3173 : SCM_OPERATOR_PROCEDURE (proc
),
3174 scm_cons (proc
, debug
.info
->a
.args
),
3177 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3178 ? SCM_ENTITY_PROCEDURE (proc
)
3179 : SCM_OPERATOR_PROCEDURE (proc
),
3180 scm_cons2 (proc
, arg1
,
3190 case scm_tc7_subr_0
:
3193 case scm_tc7_subr_1o
:
3194 case scm_tc7_subr_1
:
3195 case scm_tc7_subr_3
:
3196 scm_wrong_num_args (proc
);
3200 proc
= SCM_PROCEDURE (proc
);
3202 debug
.info
->a
.proc
= proc
;
3204 if (!SCM_CLOSUREP (proc
))
3207 case scm_tcs_closures
:
3210 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3211 if (SCM_NULLP (formals
)
3212 || (SCM_CONSP (formals
)
3213 && (SCM_NULLP (SCM_CDR (formals
))
3214 || (SCM_CONSP (SCM_CDR (formals
))
3215 && SCM_CONSP (SCM_CDDR (formals
))))))
3216 goto umwrongnumargs
;
3218 env
= SCM_EXTEND_ENV (formals
,
3222 env
= SCM_EXTEND_ENV (formals
,
3223 scm_list_2 (arg1
, arg2
),
3226 x
= SCM_CLOSURE_BODY (proc
);
3227 goto nontoplevel_begin
;
3232 scm_wrong_num_args (proc
);
3234 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3235 deval_args (x
, env
, proc
,
3236 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3240 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3241 switch (SCM_TYP7 (proc
))
3242 { /* have 3 or more arguments */
3244 case scm_tc7_subr_3
:
3245 if (!SCM_NULLP (SCM_CDR (x
)))
3246 scm_wrong_num_args (proc
);
3248 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3249 SCM_CADDR (debug
.info
->a
.args
)));
3251 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3252 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3255 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3256 arg2
= SCM_CDR (arg2
);
3258 while (SCM_NIMP (arg2
));
3260 case scm_tc7_rpsubr
:
3261 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3262 RETURN (SCM_BOOL_F
);
3263 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3266 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3267 RETURN (SCM_BOOL_F
);
3268 arg2
= SCM_CAR (arg1
);
3269 arg1
= SCM_CDR (arg1
);
3271 while (SCM_NIMP (arg1
));
3272 RETURN (SCM_BOOL_T
);
3273 case scm_tc7_lsubr_2
:
3274 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3275 SCM_CDDR (debug
.info
->a
.args
)));
3277 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3279 if (!SCM_SMOB_APPLICABLE_P (proc
))
3281 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3282 SCM_CDDR (debug
.info
->a
.args
)));
3286 proc
= SCM_PROCEDURE (proc
);
3287 debug
.info
->a
.proc
= proc
;
3288 if (!SCM_CLOSUREP (proc
))
3291 case scm_tcs_closures
:
3293 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3294 if (SCM_NULLP (formals
)
3295 || (SCM_CONSP (formals
)
3296 && (SCM_NULLP (SCM_CDR (formals
))
3297 || (SCM_CONSP (SCM_CDR (formals
))
3298 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3299 goto umwrongnumargs
;
3300 SCM_SET_ARGSREADY (debug
);
3301 env
= SCM_EXTEND_ENV (formals
,
3304 x
= SCM_CLOSURE_BODY (proc
);
3305 goto nontoplevel_begin
;
3308 case scm_tc7_subr_3
:
3309 if (!SCM_NULLP (SCM_CDR (x
)))
3310 scm_wrong_num_args (proc
);
3312 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3314 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3317 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3320 while (SCM_NIMP (x
));
3322 case scm_tc7_rpsubr
:
3323 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3324 RETURN (SCM_BOOL_F
);
3327 arg1
= EVALCAR (x
, env
);
3328 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3329 RETURN (SCM_BOOL_F
);
3333 while (SCM_NIMP (x
));
3334 RETURN (SCM_BOOL_T
);
3335 case scm_tc7_lsubr_2
:
3336 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3338 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3340 scm_eval_args (x
, env
, proc
))));
3342 if (!SCM_SMOB_APPLICABLE_P (proc
))
3344 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3345 scm_eval_args (x
, env
, proc
)));
3349 proc
= SCM_PROCEDURE (proc
);
3350 if (!SCM_CLOSUREP (proc
))
3353 case scm_tcs_closures
:
3355 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3356 if (SCM_NULLP (formals
)
3357 || (SCM_CONSP (formals
)
3358 && (SCM_NULLP (SCM_CDR (formals
))
3359 || (SCM_CONSP (SCM_CDR (formals
))
3360 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3361 goto umwrongnumargs
;
3362 env
= SCM_EXTEND_ENV (formals
,
3365 scm_eval_args (x
, env
, proc
)),
3367 x
= SCM_CLOSURE_BODY (proc
);
3368 goto nontoplevel_begin
;
3371 case scm_tcs_struct
:
3372 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3375 arg1
= debug
.info
->a
.args
;
3377 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3379 x
= SCM_ENTITY_PROCEDURE (proc
);
3382 else if (SCM_I_OPERATORP (proc
))
3386 case scm_tc7_subr_2
:
3387 case scm_tc7_subr_1o
:
3388 case scm_tc7_subr_2o
:
3389 case scm_tc7_subr_0
:
3392 case scm_tc7_subr_1
:
3393 scm_wrong_num_args (proc
);
3401 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3402 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3404 SCM_CLEAR_TRACED_FRAME (debug
);
3405 if (SCM_CHEAPTRAPS_P
)
3406 arg1
= scm_make_debugobj (&debug
);
3410 SCM val
= scm_make_continuation (&first
);
3421 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3425 scm_last_debug_frame
= debug
.prev
;
3431 /* SECTION: This code is compiled once.
3438 /* Simple procedure calls
3442 scm_call_0 (SCM proc
)
3444 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3448 scm_call_1 (SCM proc
, SCM arg1
)
3450 return scm_apply (proc
, arg1
, scm_listofnull
);
3454 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3456 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3460 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3462 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3466 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3468 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3469 scm_cons (arg4
, scm_listofnull
)));
3472 /* Simple procedure applies
3476 scm_apply_0 (SCM proc
, SCM args
)
3478 return scm_apply (proc
, args
, SCM_EOL
);
3482 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3484 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3488 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3490 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3494 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3496 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3500 /* This code processes the arguments to apply:
3502 (apply PROC ARG1 ... ARGS)
3504 Given a list (ARG1 ... ARGS), this function conses the ARG1
3505 ... arguments onto the front of ARGS, and returns the resulting
3506 list. Note that ARGS is a list; thus, the argument to this
3507 function is a list whose last element is a list.
3509 Apply calls this function, and applies PROC to the elements of the
3510 result. apply:nconc2last takes care of building the list of
3511 arguments, given (ARG1 ... ARGS).
3513 Rather than do new consing, apply:nconc2last destroys its argument.
3514 On that topic, this code came into my care with the following
3515 beautifully cryptic comment on that topic: "This will only screw
3516 you if you do (scm_apply scm_apply '( ... ))" If you know what
3517 they're referring to, send me a patch to this comment. */
3519 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3521 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3522 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3523 "@var{args}, and returns the resulting list. Note that\n"
3524 "@var{args} is a list; thus, the argument to this function is\n"
3525 "a list whose last element is a list.\n"
3526 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3527 "destroys its argument, so use with care.")
3528 #define FUNC_NAME s_scm_nconc2last
3531 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3533 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3534 SCM_NULL_OR_NIL_P, but not
3535 needed in 99.99% of cases,
3536 and it could seriously hurt
3537 performance. - Neil */
3538 lloc
= SCM_CDRLOC (*lloc
);
3539 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3540 *lloc
= SCM_CAR (*lloc
);
3548 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3549 * It is compiled twice.
3554 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3560 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3565 /* Apply a function to a list of arguments.
3567 This function is exported to the Scheme level as taking two
3568 required arguments and a tail argument, as if it were:
3569 (lambda (proc arg1 . args) ...)
3570 Thus, if you just have a list of arguments to pass to a procedure,
3571 pass the list as ARG1, and '() for ARGS. If you have some fixed
3572 args, pass the first as ARG1, then cons any remaining fixed args
3573 onto the front of your argument list, and pass that as ARGS. */
3576 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3579 scm_t_debug_frame debug
;
3580 scm_t_debug_info debug_vect_body
;
3581 debug
.prev
= scm_last_debug_frame
;
3582 debug
.status
= SCM_APPLYFRAME
;
3583 debug
.vect
= &debug_vect_body
;
3584 debug
.vect
[0].a
.proc
= proc
;
3585 debug
.vect
[0].a
.args
= SCM_EOL
;
3586 scm_last_debug_frame
= &debug
;
3589 return scm_dapply (proc
, arg1
, args
);
3592 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3594 /* If ARGS is the empty list, then we're calling apply with only two
3595 arguments --- ARG1 is the list of arguments for PROC. Whatever
3596 the case, futz with things so that ARG1 is the first argument to
3597 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3600 Setting the debug apply frame args this way is pretty messy.
3601 Perhaps we should store arg1 and args directly in the frame as
3602 received, and let scm_frame_arguments unpack them, because that's
3603 a relatively rare operation. This works for now; if the Guile
3604 developer archives are still around, see Mikael's post of
3606 if (SCM_NULLP (args
))
3608 if (SCM_NULLP (arg1
))
3610 arg1
= SCM_UNDEFINED
;
3612 debug
.vect
[0].a
.args
= SCM_EOL
;
3618 debug
.vect
[0].a
.args
= arg1
;
3620 args
= SCM_CDR (arg1
);
3621 arg1
= SCM_CAR (arg1
);
3626 args
= scm_nconc2last (args
);
3628 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3632 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3635 if (SCM_CHEAPTRAPS_P
)
3636 tmp
= scm_make_debugobj (&debug
);
3641 tmp
= scm_make_continuation (&first
);
3646 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3653 switch (SCM_TYP7 (proc
))
3655 case scm_tc7_subr_2o
:
3656 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3657 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3658 case scm_tc7_subr_2
:
3659 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3660 scm_wrong_num_args (proc
);
3661 args
= SCM_CAR (args
);
3662 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3663 case scm_tc7_subr_0
:
3664 if (!SCM_UNBNDP (arg1
))
3665 scm_wrong_num_args (proc
);
3667 RETURN (SCM_SUBRF (proc
) ());
3668 case scm_tc7_subr_1
:
3669 if (SCM_UNBNDP (arg1
))
3670 scm_wrong_num_args (proc
);
3671 case scm_tc7_subr_1o
:
3672 if (!SCM_NULLP (args
))
3673 scm_wrong_num_args (proc
);
3675 RETURN (SCM_SUBRF (proc
) (arg1
));
3677 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3678 scm_wrong_num_args (proc
);
3679 if (SCM_INUMP (arg1
))
3681 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3683 else if (SCM_REALP (arg1
))
3685 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3687 else if (SCM_BIGP (arg1
))
3688 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3689 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3690 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3692 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3693 scm_wrong_num_args (proc
);
3695 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3698 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3699 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3700 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3705 case scm_tc7_subr_3
:
3706 if (SCM_NULLP (args
)
3707 || SCM_NULLP (SCM_CDR (args
))
3708 || !SCM_NULLP (SCM_CDDR (args
)))
3709 scm_wrong_num_args (proc
);
3711 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3714 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3716 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3718 case scm_tc7_lsubr_2
:
3719 if (!SCM_CONSP (args
))
3720 scm_wrong_num_args (proc
);
3722 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3724 if (SCM_NULLP (args
))
3725 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3726 while (SCM_NIMP (args
))
3728 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3729 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3730 args
= SCM_CDR (args
);
3733 case scm_tc7_rpsubr
:
3734 if (SCM_NULLP (args
))
3735 RETURN (SCM_BOOL_T
);
3736 while (SCM_NIMP (args
))
3738 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3739 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3740 RETURN (SCM_BOOL_F
);
3741 arg1
= SCM_CAR (args
);
3742 args
= SCM_CDR (args
);
3744 RETURN (SCM_BOOL_T
);
3745 case scm_tcs_closures
:
3747 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3749 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3751 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3752 scm_wrong_num_args (proc
);
3754 /* Copy argument list */
3759 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3760 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
3762 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
3765 SCM_SETCDR (tl
, arg1
);
3768 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3771 proc
= SCM_CLOSURE_BODY (proc
);
3773 arg1
= SCM_CDR (proc
);
3774 while (!SCM_NULLP (arg1
))
3776 if (SCM_IMP (SCM_CAR (proc
)))
3778 if (SCM_ISYMP (SCM_CAR (proc
)))
3780 scm_rec_mutex_lock (&source_mutex
);
3781 /* check for race condition */
3782 if (SCM_ISYMP (SCM_CAR (proc
)))
3783 proc
= scm_m_expand_body (proc
, args
);
3784 scm_rec_mutex_unlock (&source_mutex
);
3788 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3791 SCM_CEVAL (SCM_CAR (proc
), args
);
3793 arg1
= SCM_CDR (proc
);
3795 RETURN (EVALCAR (proc
, args
));
3797 if (!SCM_SMOB_APPLICABLE_P (proc
))
3799 if (SCM_UNBNDP (arg1
))
3800 RETURN (SCM_SMOB_APPLY_0 (proc
));
3801 else if (SCM_NULLP (args
))
3802 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3803 else if (SCM_NULLP (SCM_CDR (args
)))
3804 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3806 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3809 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3811 proc
= SCM_CCLO_SUBR (proc
);
3812 debug
.vect
[0].a
.proc
= proc
;
3813 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3815 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3817 proc
= SCM_CCLO_SUBR (proc
);
3821 proc
= SCM_PROCEDURE (proc
);
3823 debug
.vect
[0].a
.proc
= proc
;
3826 case scm_tcs_struct
:
3827 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3830 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3832 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3834 RETURN (scm_apply_generic (proc
, args
));
3836 else if (SCM_I_OPERATORP (proc
))
3840 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3842 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3845 proc
= (SCM_I_ENTITYP (proc
)
3846 ? SCM_ENTITY_PROCEDURE (proc
)
3847 : SCM_OPERATOR_PROCEDURE (proc
));
3849 debug
.vect
[0].a
.proc
= proc
;
3850 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3852 if (SCM_NIMP (proc
))
3861 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3865 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3866 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3868 SCM_CLEAR_TRACED_FRAME (debug
);
3869 if (SCM_CHEAPTRAPS_P
)
3870 arg1
= scm_make_debugobj (&debug
);
3874 SCM val
= scm_make_continuation (&first
);
3885 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3889 scm_last_debug_frame
= debug
.prev
;
3895 /* SECTION: The rest of this file is only read once.
3902 * Trampolines make it possible to move procedure application dispatch
3903 * outside inner loops. The motivation was clean implementation of
3904 * efficient replacements of R5RS primitives in SRFI-1.
3906 * The semantics is clear: scm_trampoline_N returns an optimized
3907 * version of scm_call_N (or NULL if the procedure isn't applicable
3910 * Applying the optimization to map and for-each increased efficiency
3911 * noticeably. For example, (map abs ls) is now 8 times faster than
3916 call_subr0_0 (SCM proc
)
3918 return SCM_SUBRF (proc
) ();
3922 call_subr1o_0 (SCM proc
)
3924 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3928 call_lsubr_0 (SCM proc
)
3930 return SCM_SUBRF (proc
) (SCM_EOL
);
3934 scm_i_call_closure_0 (SCM proc
)
3936 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3939 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3944 scm_trampoline_0 (SCM proc
)
3950 switch (SCM_TYP7 (proc
))
3952 case scm_tc7_subr_0
:
3953 return call_subr0_0
;
3954 case scm_tc7_subr_1o
:
3955 return call_subr1o_0
;
3957 return call_lsubr_0
;
3958 case scm_tcs_closures
:
3960 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3961 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3962 return scm_i_call_closure_0
;
3966 case scm_tcs_struct
:
3967 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3968 return scm_call_generic_0
;
3969 else if (SCM_I_OPERATORP (proc
))
3973 if (SCM_SMOB_APPLICABLE_P (proc
))
3974 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3978 case scm_tc7_rpsubr
:
3983 return NULL
; /* not applicable on one arg */
3988 call_subr1_1 (SCM proc
, SCM arg1
)
3990 return SCM_SUBRF (proc
) (arg1
);
3994 call_subr2o_1 (SCM proc
, SCM arg1
)
3996 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4000 call_lsubr_1 (SCM proc
, SCM arg1
)
4002 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4006 call_dsubr_1 (SCM proc
, SCM arg1
)
4008 if (SCM_INUMP (arg1
))
4010 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4012 else if (SCM_REALP (arg1
))
4014 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4016 else if (SCM_BIGP (arg1
))
4017 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4018 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4019 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4023 call_cxr_1 (SCM proc
, SCM arg1
)
4025 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4028 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4029 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4030 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4037 call_closure_1 (SCM proc
, SCM arg1
)
4039 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4042 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4047 scm_trampoline_1 (SCM proc
)
4053 switch (SCM_TYP7 (proc
))
4055 case scm_tc7_subr_1
:
4056 case scm_tc7_subr_1o
:
4057 return call_subr1_1
;
4058 case scm_tc7_subr_2o
:
4059 return call_subr2o_1
;
4061 return call_lsubr_1
;
4063 return call_dsubr_1
;
4066 case scm_tcs_closures
:
4068 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4069 if (!SCM_NULLP (formals
)
4070 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4071 return call_closure_1
;
4075 case scm_tcs_struct
:
4076 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4077 return scm_call_generic_1
;
4078 else if (SCM_I_OPERATORP (proc
))
4082 if (SCM_SMOB_APPLICABLE_P (proc
))
4083 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4087 case scm_tc7_rpsubr
:
4092 return NULL
; /* not applicable on one arg */
4097 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4099 return SCM_SUBRF (proc
) (arg1
, arg2
);
4103 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4105 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4109 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4111 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4115 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4117 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4118 scm_list_2 (arg1
, arg2
),
4120 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4125 scm_trampoline_2 (SCM proc
)
4131 switch (SCM_TYP7 (proc
))
4133 case scm_tc7_subr_2
:
4134 case scm_tc7_subr_2o
:
4135 case scm_tc7_rpsubr
:
4137 return call_subr2_2
;
4138 case scm_tc7_lsubr_2
:
4139 return call_lsubr2_2
;
4141 return call_lsubr_2
;
4142 case scm_tcs_closures
:
4144 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4145 if (!SCM_NULLP (formals
)
4146 && (!SCM_CONSP (formals
)
4147 || (!SCM_NULLP (SCM_CDR (formals
))
4148 && (!SCM_CONSP (SCM_CDR (formals
))
4149 || !SCM_CONSP (SCM_CDDR (formals
))))))
4150 return call_closure_2
;
4154 case scm_tcs_struct
:
4155 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4156 return scm_call_generic_2
;
4157 else if (SCM_I_OPERATORP (proc
))
4161 if (SCM_SMOB_APPLICABLE_P (proc
))
4162 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4169 return NULL
; /* not applicable on two args */
4173 /* Typechecking for multi-argument MAP and FOR-EACH.
4175 Verify that each element of the vector ARGV, except for the first,
4176 is a proper list whose length is LEN. Attribute errors to WHO,
4177 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4179 check_map_args (SCM argv
,
4186 SCM
const *ve
= SCM_VELTS (argv
);
4189 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4191 long elt_len
= scm_ilength (ve
[i
]);
4196 scm_apply_generic (gf
, scm_cons (proc
, args
));
4198 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4202 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4205 scm_remember_upto_here_1 (argv
);
4209 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4211 /* Note: Currently, scm_map applies PROC to the argument list(s)
4212 sequentially, starting with the first element(s). This is used in
4213 evalext.c where the Scheme procedure `map-in-order', which guarantees
4214 sequential behaviour, is implemented using scm_map. If the
4215 behaviour changes, we need to update `map-in-order'.
4219 scm_map (SCM proc
, SCM arg1
, SCM args
)
4220 #define FUNC_NAME s_map
4225 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4227 len
= scm_ilength (arg1
);
4228 SCM_GASSERTn (len
>= 0,
4229 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4230 SCM_VALIDATE_REST_ARGUMENT (args
);
4231 if (SCM_NULLP (args
))
4233 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4234 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4235 while (SCM_NIMP (arg1
))
4237 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4238 pres
= SCM_CDRLOC (*pres
);
4239 arg1
= SCM_CDR (arg1
);
4243 if (SCM_NULLP (SCM_CDR (args
)))
4245 SCM arg2
= SCM_CAR (args
);
4246 int len2
= scm_ilength (arg2
);
4247 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4249 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4250 SCM_GASSERTn (len2
>= 0,
4251 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4253 SCM_OUT_OF_RANGE (3, arg2
);
4254 while (SCM_NIMP (arg1
))
4256 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4257 pres
= SCM_CDRLOC (*pres
);
4258 arg1
= SCM_CDR (arg1
);
4259 arg2
= SCM_CDR (arg2
);
4263 arg1
= scm_cons (arg1
, args
);
4264 args
= scm_vector (arg1
);
4265 ve
= SCM_VELTS (args
);
4266 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4270 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4272 if (SCM_IMP (ve
[i
]))
4274 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4275 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4277 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4278 pres
= SCM_CDRLOC (*pres
);
4284 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4287 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4288 #define FUNC_NAME s_for_each
4290 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4292 len
= scm_ilength (arg1
);
4293 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4294 SCM_ARG2
, s_for_each
);
4295 SCM_VALIDATE_REST_ARGUMENT (args
);
4296 if (SCM_NULLP (args
))
4298 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4299 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4300 while (SCM_NIMP (arg1
))
4302 call (proc
, SCM_CAR (arg1
));
4303 arg1
= SCM_CDR (arg1
);
4305 return SCM_UNSPECIFIED
;
4307 if (SCM_NULLP (SCM_CDR (args
)))
4309 SCM arg2
= SCM_CAR (args
);
4310 int len2
= scm_ilength (arg2
);
4311 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4312 SCM_GASSERTn (call
, g_for_each
,
4313 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4314 SCM_GASSERTn (len2
>= 0, g_for_each
,
4315 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4317 SCM_OUT_OF_RANGE (3, arg2
);
4318 while (SCM_NIMP (arg1
))
4320 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4321 arg1
= SCM_CDR (arg1
);
4322 arg2
= SCM_CDR (arg2
);
4324 return SCM_UNSPECIFIED
;
4326 arg1
= scm_cons (arg1
, args
);
4327 args
= scm_vector (arg1
);
4328 ve
= SCM_VELTS (args
);
4329 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4333 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4335 if (SCM_IMP (ve
[i
]))
4336 return SCM_UNSPECIFIED
;
4337 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4338 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4340 scm_apply (proc
, arg1
, SCM_EOL
);
4347 scm_closure (SCM code
, SCM env
)
4350 SCM closcar
= scm_cons (code
, SCM_EOL
);
4351 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4352 scm_remember_upto_here (closcar
);
4357 scm_t_bits scm_tc16_promise
;
4360 scm_makprom (SCM code
)
4362 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4364 scm_make_rec_mutex ());
4368 promise_free (SCM promise
)
4370 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4375 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4377 int writingp
= SCM_WRITINGP (pstate
);
4378 scm_puts ("#<promise ", port
);
4379 SCM_SET_WRITINGP (pstate
, 1);
4380 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4381 SCM_SET_WRITINGP (pstate
, writingp
);
4382 scm_putc ('>', port
);
4386 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4388 "If the promise @var{x} has not been computed yet, compute and\n"
4389 "return @var{x}, otherwise just return the previously computed\n"
4391 #define FUNC_NAME s_scm_force
4393 SCM_VALIDATE_SMOB (1, promise
, promise
);
4394 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4395 if (!SCM_PROMISE_COMPUTED_P (promise
))
4397 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4398 if (!SCM_PROMISE_COMPUTED_P (promise
))
4400 SCM_SET_PROMISE_DATA (promise
, ans
);
4401 SCM_SET_PROMISE_COMPUTED (promise
);
4404 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4405 return SCM_PROMISE_DATA (promise
);
4410 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4412 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4413 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4414 #define FUNC_NAME s_scm_promise_p
4416 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4421 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4422 (SCM xorig
, SCM x
, SCM y
),
4423 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4424 "Any source properties associated with @var{xorig} are also associated\n"
4425 "with the new pair.")
4426 #define FUNC_NAME s_scm_cons_source
4429 z
= scm_cons (x
, y
);
4430 /* Copy source properties possibly associated with xorig. */
4431 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4433 scm_whash_insert (scm_source_whash
, z
, p
);
4439 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4441 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4442 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4443 "contents of both pairs and vectors (since both cons cells and vector\n"
4444 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4445 "any other object.")
4446 #define FUNC_NAME s_scm_copy_tree
4451 if (SCM_VECTORP (obj
))
4453 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4454 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4456 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4459 if (!SCM_CONSP (obj
))
4461 ans
= tl
= scm_cons_source (obj
,
4462 scm_copy_tree (SCM_CAR (obj
)),
4464 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4466 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4470 SCM_SETCDR (tl
, obj
);
4476 /* We have three levels of EVAL here:
4478 - scm_i_eval (exp, env)
4480 evaluates EXP in environment ENV. ENV is a lexical environment
4481 structure as used by the actual tree code evaluator. When ENV is
4482 a top-level environment, then changes to the current module are
4483 tracked by updating ENV so that it continues to be in sync with
4486 - scm_primitive_eval (exp)
4488 evaluates EXP in the top-level environment as determined by the
4489 current module. This is done by constructing a suitable
4490 environment and calling scm_i_eval. Thus, changes to the
4491 top-level module are tracked normally.
4493 - scm_eval (exp, mod)
4495 evaluates EXP while MOD is the current module. This is done by
4496 setting the current module to MOD, invoking scm_primitive_eval on
4497 EXP, and then restoring the current module to the value it had
4498 previously. That is, while EXP is evaluated, changes to the
4499 current module are tracked, but these changes do not persist when
4502 For each level of evals, there are two variants, distinguished by a
4503 _x suffix: the ordinary variant does not modify EXP while the _x
4504 variant can destructively modify EXP into something completely
4505 unintelligible. A Scheme data structure passed as EXP to one of the
4506 _x variants should not ever be used again for anything. So when in
4507 doubt, use the ordinary variant.
4512 scm_i_eval_x (SCM exp
, SCM env
)
4514 return SCM_XEVAL (exp
, env
);
4518 scm_i_eval (SCM exp
, SCM env
)
4520 exp
= scm_copy_tree (exp
);
4521 return SCM_XEVAL (exp
, env
);
4525 scm_primitive_eval_x (SCM exp
)
4528 SCM transformer
= scm_current_module_transformer ();
4529 if (SCM_NIMP (transformer
))
4530 exp
= scm_call_1 (transformer
, exp
);
4531 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4532 return scm_i_eval_x (exp
, env
);
4535 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4537 "Evaluate @var{exp} in the top-level environment specified by\n"
4538 "the current module.")
4539 #define FUNC_NAME s_scm_primitive_eval
4542 SCM transformer
= scm_current_module_transformer ();
4543 if (SCM_NIMP (transformer
))
4544 exp
= scm_call_1 (transformer
, exp
);
4545 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4546 return scm_i_eval (exp
, env
);
4550 /* Eval does not take the second arg optionally. This is intentional
4551 * in order to be R5RS compatible, and to prepare for the new module
4552 * system, where we would like to make the choice of evaluation
4553 * environment explicit. */
4556 change_environment (void *data
)
4558 SCM pair
= SCM_PACK (data
);
4559 SCM new_module
= SCM_CAR (pair
);
4560 SCM old_module
= scm_current_module ();
4561 SCM_SETCDR (pair
, old_module
);
4562 scm_set_current_module (new_module
);
4567 restore_environment (void *data
)
4569 SCM pair
= SCM_PACK (data
);
4570 SCM old_module
= SCM_CDR (pair
);
4571 SCM new_module
= scm_current_module ();
4572 SCM_SETCAR (pair
, new_module
);
4573 scm_set_current_module (old_module
);
4577 inner_eval_x (void *data
)
4579 return scm_primitive_eval_x (SCM_PACK(data
));
4583 scm_eval_x (SCM exp
, SCM module
)
4584 #define FUNC_NAME "eval!"
4586 SCM_VALIDATE_MODULE (2, module
);
4588 return scm_internal_dynamic_wind
4589 (change_environment
, inner_eval_x
, restore_environment
,
4590 (void *) SCM_UNPACK (exp
),
4591 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4596 inner_eval (void *data
)
4598 return scm_primitive_eval (SCM_PACK(data
));
4601 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4602 (SCM exp
, SCM module
),
4603 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4604 "in the top-level environment specified by @var{module}.\n"
4605 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4606 "@var{module} is made the current module. The current module\n"
4607 "is reset to its previous value when @var{eval} returns.")
4608 #define FUNC_NAME s_scm_eval
4610 SCM_VALIDATE_MODULE (2, module
);
4612 return scm_internal_dynamic_wind
4613 (change_environment
, inner_eval
, restore_environment
,
4614 (void *) SCM_UNPACK (exp
),
4615 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4620 /* At this point, scm_deval and scm_dapply are generated.
4630 scm_init_opts (scm_evaluator_traps
,
4631 scm_evaluator_trap_table
,
4632 SCM_N_EVALUATOR_TRAPS
);
4633 scm_init_opts (scm_eval_options_interface
,
4635 SCM_N_EVAL_OPTIONS
);
4637 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4638 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4639 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4640 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4642 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4643 SCM_SETCDR (undefineds
, undefineds
);
4644 scm_permanent_object (undefineds
);
4646 scm_listofnull
= scm_list_1 (SCM_EOL
);
4648 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4649 scm_permanent_object (f_apply
);
4651 #include "libguile/eval.x"
4653 scm_add_feature ("delay");