1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 /* This file is read twice in order to produce debugging versions of
21 * scm_ceval and scm_apply. These functions, scm_deval and
22 * scm_dapply, are produced when we define the preprocessor macro
23 * DEVAL. The file is divided into sections which are treated
24 * differently with respect to DEVAL. The heads of these sections are
25 * marked with the string "SECTION:".
28 /* SECTION: This code is compiled once.
35 #include "libguile/__scm.h"
39 /* AIX requires this to be the first thing in the file. The #pragma
40 directive is indented so pre-ANSI compilers will ignore it, rather
49 # ifndef alloca /* predefined by HP cc +Olibcalls */
56 #include "libguile/_scm.h"
57 #include "libguile/debug.h"
58 #include "libguile/dynwind.h"
59 #include "libguile/alist.h"
60 #include "libguile/eq.h"
61 #include "libguile/continuations.h"
62 #include "libguile/futures.h"
63 #include "libguile/throw.h"
64 #include "libguile/smob.h"
65 #include "libguile/macros.h"
66 #include "libguile/procprop.h"
67 #include "libguile/hashtab.h"
68 #include "libguile/hash.h"
69 #include "libguile/srcprop.h"
70 #include "libguile/stackchk.h"
71 #include "libguile/objects.h"
72 #include "libguile/async.h"
73 #include "libguile/feature.h"
74 #include "libguile/modules.h"
75 #include "libguile/ports.h"
76 #include "libguile/root.h"
77 #include "libguile/vectors.h"
78 #include "libguile/fluids.h"
79 #include "libguile/goops.h"
80 #include "libguile/values.h"
82 #include "libguile/validate.h"
83 #include "libguile/eval.h"
84 #include "libguile/lang.h"
88 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
90 if (SCM_EQ_P ((x), SCM_EOL)) \
91 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
96 /* The evaluator contains a plethora of EVAL symbols.
97 * This is an attempt at explanation.
99 * The following macros should be used in code which is read twice
100 * (where the choice of evaluator is hard soldered):
102 * SCM_CEVAL is the symbol used within one evaluator to call itself.
103 * Originally, it is defined to scm_ceval, but is redefined to
104 * scm_deval during the second pass.
106 * SCM_EVALIM is used when it is known that the expression is an
107 * immediate. (This macro never calls an evaluator.)
109 * EVALCAR evaluates the car of an expression.
111 * The following macros should be used in code which is read once
112 * (where the choice of evaluator is dynamic):
114 * SCM_XEVAL takes care of immediates without calling an evaluator. It
115 * then calls scm_ceval *or* scm_deval, depending on the debugging
118 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
119 * depending on the debugging mode.
121 * The main motivation for keeping this plethora is efficiency
122 * together with maintainability (=> locality of code).
125 #define SCM_CEVAL scm_ceval
127 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
128 ? SCM_EVALIM (SCM_CAR (x), env) \
129 : (SCM_SYMBOLP (SCM_CAR (x)) \
130 ? *scm_lookupcar (x, env, 1) \
131 : SCM_CEVAL (SCM_CAR (x), env)))
133 SCM_REC_MUTEX (source_mutex
);
136 /* Lookup a given local variable in an environment. The local variable is
137 * given as an iloc, that is a triple <frame, binding, last?>, where frame
138 * indicates the relative number of the environment frame (counting upwards
139 * from the innermost environment frame), binding indicates the number of the
140 * binding within the frame, and last? (which is extracted from the iloc using
141 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
142 * very end of the improper list of bindings. */
144 scm_ilookup (SCM iloc
, SCM env
)
146 unsigned int frame_nr
= SCM_IFRAME (iloc
);
147 unsigned int binding_nr
= SCM_IDIST (iloc
);
151 for (; 0 != frame_nr
; --frame_nr
)
152 frames
= SCM_CDR (frames
);
154 bindings
= SCM_CAR (frames
);
155 for (; 0 != binding_nr
; --binding_nr
)
156 bindings
= SCM_CDR (bindings
);
158 if (SCM_ICDRP (iloc
))
159 return SCM_CDRLOC (bindings
);
160 return SCM_CARLOC (SCM_CDR (bindings
));
164 /* The Lookup Car Race
167 Memoization of variables and special forms is done while executing
168 the code for the first time. As long as there is only one thread
169 everything is fine, but as soon as two threads execute the same
170 code concurrently `for the first time' they can come into conflict.
172 This memoization includes rewriting variable references into more
173 efficient forms and expanding macros. Furthermore, macro expansion
174 includes `compiling' special forms like `let', `cond', etc. into
175 tree-code instructions.
177 There shouldn't normally be a problem with memoizing local and
178 global variable references (into ilocs and variables), because all
179 threads will mutate the code in *exactly* the same way and (if I
180 read the C code correctly) it is not possible to observe a half-way
181 mutated cons cell. The lookup procedure can handle this
182 transparently without any critical sections.
184 It is different with macro expansion, because macro expansion
185 happens outside of the lookup procedure and can't be
186 undone. Therefore the lookup procedure can't cope with it. It has
187 to indicate failure when it detects a lost race and hope that the
188 caller can handle it. Luckily, it turns out that this is the case.
190 An example to illustrate this: Suppose that the following form will
191 be memoized concurrently by two threads
195 Let's first examine the lookup of X in the body. The first thread
196 decides that it has to find the symbol "x" in the environment and
197 starts to scan it. Then the other thread takes over and actually
198 overtakes the first. It looks up "x" and substitutes an
199 appropriate iloc for it. Now the first thread continues and
200 completes its lookup. It comes to exactly the same conclusions as
201 the second one and could - without much ado - just overwrite the
202 iloc with the same iloc.
204 But let's see what will happen when the race occurs while looking
205 up the symbol "let" at the start of the form. It could happen that
206 the second thread interrupts the lookup of the first thread and not
207 only substitutes a variable for it but goes right ahead and
208 replaces it with the compiled form (#@let* (x 12) x). Now, when
209 the first thread completes its lookup, it would replace the #@let*
210 with a variable containing the "let" binding, effectively reverting
211 the form to (let (x 12) x). This is wrong. It has to detect that
212 it has lost the race and the evaluator has to reconsider the
213 changed form completely.
215 This race condition could be resolved with some kind of traffic
216 light (like mutexes) around scm_lookupcar, but I think that it is
217 best to avoid them in this case. They would serialize memoization
218 completely and because lookup involves calling arbitrary Scheme
219 code (via the lookup-thunk), threads could be blocked for an
220 arbitrary amount of time or even deadlock. But with the current
221 solution a lot of unnecessary work is potentially done. */
223 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
224 return NULL to indicate a failed lookup due to some race conditions
225 between threads. This only happens when VLOC is the first cell of
226 a special form that will eventually be memoized (like `let', etc.)
227 In that case the whole lookup is bogus and the caller has to
228 reconsider the complete special form.
230 SCM_LOOKUPCAR is still there, of course. It just calls
231 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
232 should only be called when it is known that VLOC is not the first
233 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
234 for NULL. I think I've found the only places where this
237 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
240 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
243 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
244 register SCM iloc
= SCM_ILOC00
;
245 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
247 if (!SCM_CONSP (SCM_CAR (env
)))
249 al
= SCM_CARLOC (env
);
250 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
254 if (SCM_EQ_P (fl
, var
))
256 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
258 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
259 return SCM_CDRLOC (*al
);
264 al
= SCM_CDRLOC (*al
);
265 if (SCM_EQ_P (SCM_CAR (fl
), var
))
267 if (SCM_UNBNDP (SCM_CAR (*al
)))
272 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
274 SCM_SETCAR (vloc
, iloc
);
275 return SCM_CARLOC (*al
);
277 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
279 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
282 SCM top_thunk
, real_var
;
285 top_thunk
= SCM_CAR (env
); /* env now refers to a
286 top level env thunk */
290 top_thunk
= SCM_BOOL_F
;
291 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
292 if (SCM_FALSEP (real_var
))
295 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
301 scm_error (scm_unbound_variable_key
, NULL
,
302 "Unbound variable: ~S",
303 scm_list_1 (var
), SCM_BOOL_F
);
305 scm_misc_error (NULL
, "Damaged environment: ~S",
310 /* A variable could not be found, but we shall
311 not throw an error. */
312 static SCM undef_object
= SCM_UNDEFINED
;
313 return &undef_object
;
317 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
319 /* Some other thread has changed the very cell we are working
320 on. In effect, it must have done our job or messed it up
323 var
= SCM_CAR (vloc
);
324 if (SCM_VARIABLEP (var
))
325 return SCM_VARIABLE_LOC (var
);
326 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
327 return scm_ilookup (var
, genv
);
328 /* We can't cope with anything else than variables and ilocs. When
329 a special form has been memoized (i.e. `let' into `#@let') we
330 return NULL and expect the calling function to do the right
331 thing. For the evaluator, this means going back and redoing
332 the dispatch on the car of the form. */
336 SCM_SETCAR (vloc
, real_var
);
337 return SCM_VARIABLE_LOC (real_var
);
342 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
344 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
350 #define unmemocar scm_unmemocar
352 SCM_SYMBOL (sym_three_question_marks
, "???");
355 scm_unmemocar (SCM form
, SCM env
)
357 if (!SCM_CONSP (form
))
361 SCM c
= SCM_CAR (form
);
362 if (SCM_VARIABLEP (c
))
364 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
365 if (SCM_FALSEP (sym
))
366 sym
= sym_three_question_marks
;
367 SCM_SETCAR (form
, sym
);
369 else if (SCM_ILOCP (c
))
371 unsigned long int ir
;
373 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
375 env
= SCM_CAAR (env
);
376 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
378 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
386 scm_eval_car (SCM pair
, SCM env
)
388 return SCM_XEVALCAR (pair
, env
);
393 * The following rewrite expressions and
394 * some memoized forms have different syntax
397 const char scm_s_expression
[] = "missing or extra expression";
398 const char scm_s_test
[] = "bad test";
399 const char scm_s_body
[] = "bad body";
400 const char scm_s_bindings
[] = "bad bindings";
401 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
402 const char scm_s_variable
[] = "bad variable";
403 const char scm_s_clauses
[] = "bad or missing clauses";
404 const char scm_s_formals
[] = "bad formals";
405 const char scm_s_duplicate_formals
[] = "duplicate formals";
406 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
408 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
409 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
410 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
411 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
412 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
414 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
415 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
416 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
417 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
420 /* Check that the body denoted by XORIG is valid and rewrite it into
421 its internal form. The internal form of a body is just the body
422 itself, but prefixed with an ISYM that denotes to what kind of
423 outer construct this body belongs. A lambda body starts with
424 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
425 etc. The one exception is a body that belongs to a letrec that has
426 been formed by rewriting internal defines: it starts with
429 /* XXX - Besides controlling the rewriting of internal defines, the
430 additional ISYM could be used for improved error messages.
431 This is not done yet. */
434 scm_m_body (SCM op
, SCM xorig
, const char *what
)
436 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
438 /* Don't add another ISYM if one is present already. */
439 if (SCM_ISYMP (SCM_CAR (xorig
)))
442 /* Retain possible doc string. */
443 if (!SCM_CONSP (SCM_CAR (xorig
)))
445 if (!SCM_NULLP (SCM_CDR (xorig
)))
446 return scm_cons (SCM_CAR (xorig
),
447 scm_m_body (op
, SCM_CDR (xorig
), what
));
451 return scm_cons (op
, xorig
);
455 /* Start of the memoizers for the standard R5RS builtin macros. */
458 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
459 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
462 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
464 long len
= scm_ilength (SCM_CDR (xorig
));
465 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
467 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
473 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
474 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
477 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
479 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
480 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
484 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
485 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
488 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
491 SCM cdrx
= SCM_CDR (xorig
);
492 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
493 clauses
= SCM_CDR (cdrx
);
494 while (!SCM_NULLP (clauses
))
496 SCM clause
= SCM_CAR (clauses
);
497 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
498 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
499 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
500 && SCM_NULLP (SCM_CDR (clauses
))),
501 scm_s_clauses
, s_case
);
502 clauses
= SCM_CDR (clauses
);
504 return scm_cons (SCM_IM_CASE
, cdrx
);
508 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
509 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
512 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
514 SCM cdrx
= SCM_CDR (xorig
);
516 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
517 while (!SCM_NULLP (clauses
))
519 SCM clause
= SCM_CAR (clauses
);
520 long len
= scm_ilength (clause
);
521 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
522 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
524 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
525 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
527 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
529 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
530 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
532 clauses
= SCM_CDR (clauses
);
534 return scm_cons (SCM_IM_COND
, cdrx
);
538 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
539 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
541 /* Guile provides an extension to R5RS' define syntax to represent function
542 * currying in a compact way. With this extension, it is allowed to write
543 * (define <nested-variable> <body>), where <nested-variable> has of one of
544 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
545 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
546 * should be either a sequence of zero or more variables, or a sequence of one
547 * or more variables followed by a space-delimited period and another
548 * variable. Each level of argument nesting wraps the <body> within another
549 * lambda expression. For example, the following forms are allowed, each one
550 * followed by an equivalent, more explicit implementation.
552 * (define ((a b . c) . d) <body>) is equivalent to
553 * (define a (lambda (b . c) (lambda d <body>)))
555 * (define (((a) b) c . d) <body>) is equivalent to
556 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
558 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
559 * module that does not implement this extension. */
561 scm_m_define (SCM x
, SCM env
)
565 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
568 while (SCM_CONSP (name
))
570 /* This while loop realizes function currying by variable nesting. */
571 SCM formals
= SCM_CDR (name
);
572 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
573 name
= SCM_CAR (name
);
575 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
576 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
577 if (SCM_TOP_LEVEL (env
))
580 x
= scm_eval_car (x
, env
);
581 if (SCM_REC_PROCNAMES_P
)
584 while (SCM_MACROP (tmp
))
585 tmp
= SCM_MACRO_CODE (tmp
);
586 if (SCM_CLOSUREP (tmp
)
587 /* Only the first definition determines the name. */
588 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
589 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
591 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
592 SCM_VARIABLE_SET (var
, x
);
593 return SCM_UNSPECIFIED
;
596 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
600 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
601 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
603 /* Promises are implemented as closures with an empty parameter list. Thus,
604 * (delay <expression>) is transformed into (#@delay '() <expression>), where
605 * the empty list represents the empty parameter list. This representation
606 * allows for easy creation of the closure during evaluation. */
608 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
610 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
611 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
615 /* DO gets the most radically altered syntax. The order of the vars is
616 * reversed here. In contrast, the order of the inits and steps is reversed
617 * during the evaluation:
619 (do ((<var1> <init1> <step1>)
627 (#@do (varn ... var2 var1)
628 (<init1> <init2> ... <initn>)
631 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
634 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
635 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
638 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
641 SCM x
= SCM_CDR (xorig
);
644 SCM
*initloc
= &inits
;
646 SCM
*steploc
= &steps
;
647 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
648 bindings
= SCM_CAR (x
);
649 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
650 while (!SCM_NULLP (bindings
))
652 SCM binding
= SCM_CAR (bindings
);
653 long len
= scm_ilength (binding
);
654 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
656 SCM name
= SCM_CAR (binding
);
657 SCM init
= SCM_CADR (binding
);
658 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
659 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
660 vars
= scm_cons (name
, vars
);
661 *initloc
= scm_list_1 (init
);
662 initloc
= SCM_CDRLOC (*initloc
);
663 *steploc
= scm_list_1 (step
);
664 steploc
= SCM_CDRLOC (*steploc
);
665 bindings
= SCM_CDR (bindings
);
669 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
670 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
671 x
= scm_cons2 (vars
, inits
, x
);
672 return scm_cons (SCM_IM_DO
, x
);
676 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
677 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
680 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
682 long len
= scm_ilength (SCM_CDR (xorig
));
683 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
684 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
688 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
689 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
691 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
692 * cdr of the last cons. (Thus, LIST is not required to be a proper
693 * list and OBJ can also be found in the improper ending.) */
695 scm_c_improper_memq (SCM obj
, SCM list
)
697 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
699 if (SCM_EQ_P (SCM_CAR (list
), obj
))
702 return SCM_EQ_P (list
, obj
);
706 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
709 SCM x
= SCM_CDR (xorig
);
711 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
713 formals
= SCM_CAR (x
);
714 while (SCM_CONSP (formals
))
716 SCM formal
= SCM_CAR (formals
);
717 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
718 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
719 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
720 formals
= SCM_CDR (formals
);
722 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
723 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
725 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
726 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
730 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
731 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
732 * reversed here, the list of inits gets reversed during evaluation. */
734 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
740 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
744 SCM binding
= SCM_CAR (bindings
);
745 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
746 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
747 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
748 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
749 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
750 *initloc
= scm_list_1 (SCM_CADR (binding
));
751 initloc
= SCM_CDRLOC (*initloc
);
752 bindings
= SCM_CDR (bindings
);
754 while (!SCM_NULLP (bindings
));
760 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
761 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
764 scm_m_let (SCM xorig
, SCM env
)
766 SCM x
= SCM_CDR (xorig
);
769 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
772 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
774 /* null or single binding, let* is faster */
776 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
777 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
779 else if (SCM_CONSP (temp
))
783 SCM rvars
, inits
, body
;
784 transform_bindings (bindings
, &rvars
, &inits
, "let");
785 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
786 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
790 /* named let: Transform (let name ((var init) ...) body ...) into
791 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
797 SCM
*initloc
= &inits
;
800 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
802 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
803 bindings
= SCM_CAR (x
);
804 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
805 while (!SCM_NULLP (bindings
))
806 { /* vars and inits both in order */
807 SCM binding
= SCM_CAR (bindings
);
808 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
809 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
810 *varloc
= scm_list_1 (SCM_CAR (binding
));
811 varloc
= SCM_CDRLOC (*varloc
);
812 *initloc
= scm_list_1 (SCM_CADR (binding
));
813 initloc
= SCM_CDRLOC (*initloc
);
814 bindings
= SCM_CDR (bindings
);
818 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
819 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
820 SCM rvar
= scm_list_1 (name
);
821 SCM init
= scm_list_1 (lambda_form
);
822 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
823 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
824 return scm_cons (letrec
, inits
);
830 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
831 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
833 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
834 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
836 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
839 SCM x
= SCM_CDR (xorig
);
843 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
845 bindings
= SCM_CAR (x
);
846 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
847 while (!SCM_NULLP (bindings
))
849 SCM binding
= SCM_CAR (bindings
);
850 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
851 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
852 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
853 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
854 bindings
= SCM_CDR (bindings
);
857 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
858 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
862 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
863 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
866 scm_m_letrec (SCM xorig
, SCM env
)
868 SCM x
= SCM_CDR (xorig
);
869 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
871 if (SCM_NULLP (SCM_CAR (x
)))
873 /* null binding, let* faster */
874 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
875 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
879 SCM rvars
, inits
, body
;
880 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
881 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
882 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
887 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
888 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
891 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
893 long len
= scm_ilength (SCM_CDR (xorig
));
894 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
896 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
902 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
903 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
905 /* Internal function to handle a quasiquotation: 'form' is the parameter in
906 * the call (quasiquotation form), 'env' is the environment where unquoted
907 * expressions will be evaluated, and 'depth' is the current quasiquotation
908 * nesting level and is known to be greater than zero. */
910 iqq (SCM form
, SCM env
, unsigned long int depth
)
912 if (SCM_CONSP (form
))
914 SCM tmp
= SCM_CAR (form
);
915 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
917 SCM args
= SCM_CDR (form
);
918 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
919 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
921 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
923 SCM args
= SCM_CDR (form
);
924 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
926 return scm_eval_car (args
, env
);
928 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
930 else if (SCM_CONSP (tmp
)
931 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
933 SCM args
= SCM_CDR (tmp
);
934 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
937 SCM list
= scm_eval_car (args
, env
);
938 SCM rest
= SCM_CDR (form
);
939 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
940 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
943 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
944 iqq (SCM_CDR (form
), env
, depth
));
947 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
948 iqq (SCM_CDR (form
), env
, depth
));
950 else if (SCM_VECTORP (form
))
952 size_t i
= SCM_VECTOR_LENGTH (form
);
953 SCM
const *const data
= SCM_VELTS (form
);
956 tmp
= scm_cons (data
[--i
], tmp
);
957 scm_remember_upto_here_1 (form
);
958 return scm_vector (iqq (tmp
, env
, depth
));
965 scm_m_quasiquote (SCM xorig
, SCM env
)
967 SCM x
= SCM_CDR (xorig
);
968 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
969 return iqq (SCM_CAR (x
), env
, 1);
973 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
974 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
977 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
979 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
980 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
984 /* Will go into the RnRS module when Guile is factorized.
985 SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */
986 static const char s_set_x
[] = "set!";
987 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
990 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
992 SCM x
= SCM_CDR (xorig
);
993 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, s_set_x
);
994 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, s_set_x
);
995 return scm_cons (SCM_IM_SET_X
, x
);
999 /* Start of the memoizers for non-R5RS builtin macros. */
1002 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1003 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1004 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1007 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1009 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1010 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1014 /* (@bind ((var exp) ...) body ...)
1016 This will assign the values of the `exp's to the global variables
1017 named by `var's (symbols, not evaluated), creating them if they
1018 don't exist, executes body, and then restores the previous values of
1019 the `var's. Additionally, whenever control leaves body, the values
1020 of the `var's are saved and restored when control returns. It is an
1021 error when a symbol appears more than once among the `var's.
1022 All `exp's are evaluated before any `var' is set.
1024 Think of this as `let' for dynamic scope.
1026 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1028 XXX - also implement `@bind*'.
1031 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1034 scm_m_atbind (SCM xorig
, SCM env
)
1036 SCM x
= SCM_CDR (xorig
);
1037 SCM top_level
= scm_env_top_level (env
);
1038 SCM vars
= SCM_EOL
, var
;
1041 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1044 while (SCM_NIMP (x
))
1047 SCM sym_exp
= SCM_CAR (x
);
1048 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1049 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1051 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1052 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1053 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1054 /* The first call to scm_sym2var will look beyond the current
1055 module, while the second call wont. */
1056 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1057 if (SCM_FALSEP (var
))
1058 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1059 vars
= scm_cons (var
, vars
);
1060 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1062 return scm_cons (SCM_IM_BIND
,
1063 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1068 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1069 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1073 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1075 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1076 scm_s_expression
, s_atcall_cc
);
1077 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1081 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1082 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1085 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1087 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1088 scm_s_expression
, s_at_call_with_values
);
1089 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1093 SCM_SYNTAX (s_future
, "future", scm_makmmacro
, scm_m_future
);
1094 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1096 /* Like promises, futures are implemented as closures with an empty
1097 * parameter list. Thus, (future <expression>) is transformed into
1098 * (#@future '() <expression>), where the empty list represents the
1099 * empty parameter list. This representation allows for easy creation
1100 * of the closure during evaluation. */
1102 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
1104 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
1105 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
1109 SCM_SYNTAX (s_gset_x
, "set!", scm_makmmacro
, scm_m_generalized_set_x
);
1110 SCM_SYMBOL (scm_sym_setter
, "setter");
1113 scm_m_generalized_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1115 SCM x
= SCM_CDR (xorig
);
1116 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, s_set_x
);
1117 if (SCM_SYMBOLP (SCM_CAR (x
)))
1118 return scm_cons (SCM_IM_SET_X
, x
);
1119 else if (SCM_CONSP (SCM_CAR (x
)))
1120 return scm_cons (scm_list_2 (scm_sym_setter
, SCM_CAAR (x
)),
1121 scm_append (scm_list_2 (SCM_CDAR (x
), SCM_CDR (x
))));
1123 scm_misc_error (s_set_x
, scm_s_variable
, SCM_EOL
);
1127 static const char* s_atslot_ref
= "@slot-ref";
1129 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1130 * soon as the module system allows us to more freely create bindings in
1131 * arbitrary modules during the startup phase, the code from goops.c should be
1134 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1135 #define FUNC_NAME s_atslot_ref
1137 SCM x
= SCM_CDR (xorig
);
1138 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1139 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1140 return scm_cons (SCM_IM_SLOT_REF
, x
);
1145 static const char* s_atslot_set_x
= "@slot-set!";
1147 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1148 * soon as the module system allows us to more freely create bindings in
1149 * arbitrary modules during the startup phase, the code from goops.c should be
1152 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1153 #define FUNC_NAME s_atslot_set_x
1155 SCM x
= SCM_CDR (xorig
);
1156 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1157 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1158 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1163 #if SCM_ENABLE_ELISP
1165 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1168 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1170 long len
= scm_ilength (SCM_CDR (xorig
));
1171 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1172 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1176 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1179 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1181 SCM x
= SCM_CDR (xorig
), var
;
1182 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1183 var
= scm_symbol_fref (SCM_CAR (x
));
1184 /* Passing the symbol name as the `subr' arg here isn't really
1185 right, but without it it can be very difficult to work out from
1186 the error message which function definition was missing. In any
1187 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1188 something equivalent to (signal void-function (list SYM)) in
1190 SCM_ASSYNT (SCM_VARIABLEP (var
),
1191 "Symbol's function definition is void",
1192 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1193 /* Support `defalias'. */
1194 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1196 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1197 SCM_ASSYNT (SCM_VARIABLEP (var
),
1198 "Symbol's function definition is void",
1199 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1201 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1202 former allows for automatically picking up redefinitions of the
1203 corresponding symbol. */
1204 SCM_SETCAR (x
, var
);
1205 /* If the variable contains a procedure, leave the
1206 `transformer-macro' in place so that the procedure's arguments
1207 get properly transformed, and change the initial @fop to
1209 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1211 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1214 /* Otherwise (the variable contains a macro), the arguments should
1215 not be transformed, so cut the `transformer-macro' out and return
1216 the resulting expression starting with the variable. */
1217 SCM_SETCDR (x
, SCM_CDADR (x
));
1221 #endif /* SCM_ENABLE_ELISP */
1225 scm_m_expand_body (SCM xorig
, SCM env
)
1227 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1228 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1230 while (SCM_NIMP (x
))
1232 SCM form
= SCM_CAR (x
);
1233 if (!SCM_CONSP (form
))
1235 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1238 form
= scm_macroexp (scm_cons_source (form
,
1243 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1245 defs
= scm_cons (SCM_CDR (form
), defs
);
1248 else if (!SCM_IMP (defs
))
1252 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1254 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1258 x
= scm_cons (form
, SCM_CDR (x
));
1263 if (!SCM_NULLP (defs
))
1265 SCM rvars
, inits
, body
, letrec
;
1266 transform_bindings (defs
, &rvars
, &inits
, what
);
1267 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1268 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1269 SCM_SETCAR (xorig
, letrec
);
1270 SCM_SETCDR (xorig
, SCM_EOL
);
1274 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1275 SCM_SETCAR (xorig
, SCM_CAR (x
));
1276 SCM_SETCDR (xorig
, SCM_CDR (x
));
1283 scm_macroexp (SCM x
, SCM env
)
1285 SCM res
, proc
, orig_sym
;
1287 /* Don't bother to produce error messages here. We get them when we
1288 eventually execute the code for real. */
1291 orig_sym
= SCM_CAR (x
);
1292 if (!SCM_SYMBOLP (orig_sym
))
1296 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1297 if (proc_ptr
== NULL
)
1299 /* We have lost the race. */
1305 /* Only handle memoizing macros. `Acros' and `macros' are really
1306 special forms and should not be evaluated here. */
1308 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1311 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1312 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1314 if (scm_ilength (res
) <= 0)
1315 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1318 SCM_SETCAR (x
, SCM_CAR (res
));
1319 SCM_SETCDR (x
, SCM_CDR (res
));
1325 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1327 /* A function object to implement "apply" for non-closure functions. */
1329 /* An endless list consisting of #<undefined> objects: */
1330 static SCM undefineds
;
1332 /* scm_unmemocopy takes a memoized expression together with its
1333 * environment and rewrites it to its original form. Thus, it is the
1334 * inversion of the rewrite rules above. The procedure is not
1335 * optimized for speed. It's used in scm_iprin1 when printing the
1336 * code of a closure, in scm_procedure_source, in display_frame when
1337 * generating the source for a stackframe in a backtrace, and in
1338 * display_expression.
1340 * Unmemoizing is not a reliable process. You cannot in general
1341 * expect to get the original source back.
1343 * However, GOOPS currently relies on this for method compilation.
1344 * This ought to change.
1348 build_binding_list (SCM names
, SCM inits
)
1350 SCM bindings
= SCM_EOL
;
1351 while (!SCM_NULLP (names
))
1353 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1354 bindings
= scm_cons (binding
, bindings
);
1355 names
= SCM_CDR (names
);
1356 inits
= SCM_CDR (inits
);
1362 unmemocopy (SCM x
, SCM env
)
1368 p
= scm_whash_lookup (scm_source_whash
, x
);
1369 switch (SCM_ITAG7 (SCM_CAR (x
)))
1371 case SCM_BIT7 (SCM_IM_AND
):
1372 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1374 case SCM_BIT7 (SCM_IM_BEGIN
):
1375 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1377 case SCM_BIT7 (SCM_IM_CASE
):
1378 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1380 case SCM_BIT7 (SCM_IM_COND
):
1381 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1383 case SCM_BIT7 (SCM_IM_DO
):
1385 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1386 * where nx is the name of a local variable, ix is an initializer for
1387 * the local variable, test is the test clause of the do loop, body is
1388 * the body of the do loop and sx are the step clauses for the local
1390 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1393 names
= SCM_CAR (x
);
1395 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1396 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1398 test
= unmemocopy (SCM_CAR (x
), env
);
1400 memoized_body
= SCM_CAR (x
);
1402 steps
= scm_reverse (unmemocopy (x
, env
));
1404 /* build transformed binding list */
1406 while (!SCM_NULLP (names
))
1408 SCM name
= SCM_CAR (names
);
1409 SCM init
= SCM_CAR (inits
);
1410 SCM step
= SCM_CAR (steps
);
1411 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1413 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1415 names
= SCM_CDR (names
);
1416 inits
= SCM_CDR (inits
);
1417 steps
= SCM_CDR (steps
);
1419 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1420 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1422 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1425 case SCM_BIT7 (SCM_IM_IF
):
1426 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1428 case SCM_BIT7 (SCM_IM_LET
):
1430 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1431 * where nx is the name of a local variable, ix is an initializer for
1432 * the local variable and by are the body clauses. */
1433 SCM names
, inits
, bindings
;
1436 names
= SCM_CAR (x
);
1438 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1439 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1441 bindings
= build_binding_list (names
, inits
);
1442 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1443 ls
= scm_cons (scm_sym_let
, z
);
1446 case SCM_BIT7 (SCM_IM_LETREC
):
1448 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1449 * where nx is the name of a local variable, ix is an initializer for
1450 * the local variable and by are the body clauses. */
1451 SCM names
, inits
, bindings
;
1454 names
= SCM_CAR (x
);
1455 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1457 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1459 bindings
= build_binding_list (names
, inits
);
1460 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1461 ls
= scm_cons (scm_sym_letrec
, z
);
1464 case SCM_BIT7 (SCM_IM_LETSTAR
):
1472 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1475 y
= z
= scm_acons (SCM_CAR (b
),
1477 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1479 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1483 SCM_SETCDR (y
, SCM_EOL
);
1484 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1485 ls
= scm_cons (scm_sym_let
, z
);
1490 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1492 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1495 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1498 while (SCM_NIMP (b
));
1499 SCM_SETCDR (z
, SCM_EOL
);
1501 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1502 ls
= scm_cons (scm_sym_letstar
, z
);
1505 case SCM_BIT7 (SCM_IM_OR
):
1506 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1508 case SCM_BIT7 (SCM_IM_LAMBDA
):
1510 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1511 ls
= scm_cons (scm_sym_lambda
, z
);
1512 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1514 case SCM_BIT7 (SCM_IM_QUOTE
):
1515 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1517 case SCM_BIT7 (SCM_IM_SET_X
):
1518 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1520 case SCM_BIT7 (SCM_IM_DEFINE
):
1525 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1526 ls
= scm_cons (scm_sym_define
, z
);
1527 if (!SCM_NULLP (env
))
1528 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1533 case SCM_BIT7 (SCM_MAKISYM (0)):
1537 switch (SCM_ISYMNUM (z
))
1539 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1540 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1542 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1543 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1545 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1546 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1549 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1550 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1553 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1554 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1557 /* appease the Sun compiler god: */ ;
1561 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1567 while (SCM_CONSP (x
))
1569 SCM form
= SCM_CAR (x
);
1570 if (!SCM_ISYMP (form
))
1572 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1573 SCM_SETCDR (z
, unmemocar (copy
, env
));
1579 if (!SCM_FALSEP (p
))
1580 scm_whash_insert (scm_source_whash
, ls
, p
);
1586 scm_unmemocopy (SCM x
, SCM env
)
1588 if (!SCM_NULLP (env
))
1589 /* Make a copy of the lowest frame to protect it from
1590 modifications by SCM_IM_DEFINE */
1591 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1593 return unmemocopy (x
, env
);
1598 scm_badargsp (SCM formals
, SCM args
)
1600 while (!SCM_NULLP (formals
))
1602 if (!SCM_CONSP (formals
))
1604 if (SCM_NULLP (args
))
1606 formals
= SCM_CDR (formals
);
1607 args
= SCM_CDR (args
);
1609 return !SCM_NULLP (args
) ? 1 : 0;
1614 scm_badformalsp (SCM closure
, int n
)
1616 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1617 while (!SCM_NULLP (formals
))
1619 if (!SCM_CONSP (formals
))
1624 formals
= SCM_CDR (formals
);
1631 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1633 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1634 while (SCM_CONSP (l
))
1636 res
= EVALCAR (l
, env
);
1638 *lloc
= scm_list_1 (res
);
1639 lloc
= SCM_CDRLOC (*lloc
);
1643 scm_wrong_num_args (proc
);
1649 scm_eval_body (SCM code
, SCM env
)
1653 next
= SCM_CDR (code
);
1654 while (!SCM_NULLP (next
))
1656 if (SCM_IMP (SCM_CAR (code
)))
1658 if (SCM_ISYMP (SCM_CAR (code
)))
1660 scm_rec_mutex_lock (&source_mutex
);
1661 /* check for race condition */
1662 if (SCM_ISYMP (SCM_CAR (code
)))
1663 code
= scm_m_expand_body (code
, env
);
1664 scm_rec_mutex_unlock (&source_mutex
);
1669 SCM_XEVAL (SCM_CAR (code
), env
);
1671 next
= SCM_CDR (code
);
1673 return SCM_XEVALCAR (code
, env
);
1679 /* SECTION: This code is specific for the debugging support. One
1680 * branch is read when DEVAL isn't defined, the other when DEVAL is
1686 #define SCM_APPLY scm_apply
1687 #define PREP_APPLY(proc, args)
1689 #define RETURN(x) do { return x; } while (0)
1690 #ifdef STACK_CHECKING
1691 #ifndef NO_CEVAL_STACK_CHECKING
1692 #define EVAL_STACK_CHECKING
1699 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1701 #define SCM_APPLY scm_dapply
1703 #define PREP_APPLY(p, l) \
1704 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1706 #define ENTER_APPLY \
1708 SCM_SET_ARGSREADY (debug);\
1709 if (scm_check_apply_p && SCM_TRAPS_P)\
1710 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1712 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1713 SCM_SET_TRACED_FRAME (debug); \
1715 if (SCM_CHEAPTRAPS_P)\
1717 tmp = scm_make_debugobj (&debug);\
1718 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1723 tmp = scm_make_continuation (&first);\
1725 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1731 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1732 #ifdef STACK_CHECKING
1733 #ifndef EVAL_STACK_CHECKING
1734 #define EVAL_STACK_CHECKING
1738 /* scm_ceval_ptr points to the currently selected evaluator.
1739 * *fixme*: Although efficiency is important here, this state variable
1740 * should probably not be a global. It should be related to the
1745 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1747 /* scm_last_debug_frame contains a pointer to the last debugging
1748 * information stack frame. It is accessed very often from the
1749 * debugging evaluator, so it should probably not be indirectly
1750 * addressed. Better to save and restore it from the current root at
1754 /* scm_debug_eframe_size is the number of slots available for pseudo
1755 * stack frames at each real stack frame.
1758 long scm_debug_eframe_size
;
1760 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1762 long scm_eval_stack
;
1764 scm_t_option scm_eval_opts
[] = {
1765 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1768 scm_t_option scm_debug_opts
[] = {
1769 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1770 "*Flyweight representation of the stack at traps." },
1771 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1772 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1773 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1774 "Record procedure names at definition." },
1775 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1776 "Display backtrace in anti-chronological order." },
1777 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1778 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1779 { SCM_OPTION_INTEGER
, "frames", 3,
1780 "Maximum number of tail-recursive frames in backtrace." },
1781 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1782 "Maximal number of stored backtrace frames." },
1783 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1784 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1785 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1786 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1787 { 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."}
1790 scm_t_option scm_evaluator_trap_table
[] = {
1791 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1792 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1793 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1794 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1795 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1796 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1797 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1800 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1802 "Option interface for the evaluation options. Instead of using\n"
1803 "this procedure directly, use the procedures @code{eval-enable},\n"
1804 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1805 #define FUNC_NAME s_scm_eval_options_interface
1809 ans
= scm_options (setting
,
1813 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1820 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1822 "Option interface for the evaluator trap options.")
1823 #define FUNC_NAME s_scm_evaluator_traps
1827 ans
= scm_options (setting
,
1828 scm_evaluator_trap_table
,
1829 SCM_N_EVALUATOR_TRAPS
,
1831 SCM_RESET_DEBUG_MODE
;
1839 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1841 SCM
*results
= lloc
, res
;
1842 while (SCM_CONSP (l
))
1844 res
= EVALCAR (l
, env
);
1846 *lloc
= scm_list_1 (res
);
1847 lloc
= SCM_CDRLOC (*lloc
);
1851 scm_wrong_num_args (proc
);
1858 /* SECTION: This code is compiled twice.
1862 /* Update the toplevel environment frame ENV so that it refers to the
1863 * current module. */
1864 #define UPDATE_TOPLEVEL_ENV(env) \
1866 SCM p = scm_current_module_lookup_closure (); \
1867 if (p != SCM_CAR (env)) \
1868 env = scm_top_level_env (p); \
1872 /* This is the evaluator. Like any real monster, it has three heads:
1874 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1875 * version. Both are implemented using a common code base, using the
1876 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1877 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1878 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1879 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1880 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1881 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1882 * are enclosed within #ifdef DEVAL ... #endif.
1884 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1885 * take two input parameters, x and env: x is a single expression to be
1886 * evalutated. env is the environment in which bindings are searched.
1888 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1889 * is a single expression, it is necessarily in a tail position. If x is just
1890 * a call to another function like in the expression (foo exp1 exp2 ...), the
1891 * realization of that call therefore _must_not_ increase stack usage (the
1892 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1893 * making extensive use of 'goto' statements within the evaluator: The gotos
1894 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1895 * that SCM_CEVAL was already using. If, however, x represents some form that
1896 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1897 * then recursive calls to SCM_CEVAL are performed for all but the last
1898 * expression of that sequence. */
1902 scm_ceval (SCM x
, SCM env
)
1908 scm_deval (SCM x
, SCM env
)
1913 SCM_CEVAL (SCM x
, SCM env
)
1917 scm_t_debug_frame debug
;
1918 scm_t_debug_info
*debug_info_end
;
1919 debug
.prev
= scm_last_debug_frame
;
1922 * The debug.vect contains twice as much scm_t_debug_info frames as the
1923 * user has specified with (debug-set! frames <n>).
1925 * Even frames are eval frames, odd frames are apply frames.
1927 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1928 * sizeof (scm_t_debug_info
));
1929 debug
.info
= debug
.vect
;
1930 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1931 scm_last_debug_frame
= &debug
;
1933 #ifdef EVAL_STACK_CHECKING
1934 if (scm_stack_checking_enabled_p
1935 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1938 debug
.info
->e
.exp
= x
;
1939 debug
.info
->e
.env
= env
;
1941 scm_report_stack_overflow ();
1951 SCM_CLEAR_ARGSREADY (debug
);
1952 if (SCM_OVERFLOWP (debug
))
1955 * In theory, this should be the only place where it is necessary to
1956 * check for space in debug.vect since both eval frames and
1957 * available space are even.
1959 * For this to be the case, however, it is necessary that primitive
1960 * special forms which jump back to `loop', `begin' or some similar
1961 * label call PREP_APPLY.
1963 else if (++debug
.info
>= debug_info_end
)
1965 SCM_SET_OVERFLOW (debug
);
1970 debug
.info
->e
.exp
= x
;
1971 debug
.info
->e
.env
= env
;
1972 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1974 if (SCM_ENTER_FRAME_P
1975 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1978 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1979 SCM_SET_TAILREC (debug
);
1980 if (SCM_CHEAPTRAPS_P
)
1981 stackrep
= scm_make_debugobj (&debug
);
1985 SCM val
= scm_make_continuation (&first
);
1995 /* This gives the possibility for the debugger to
1996 modify the source expression before evaluation. */
2001 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2002 scm_sym_enter_frame
,
2005 scm_unmemocopy (x
, env
));
2012 switch (SCM_TYP7 (x
))
2014 case scm_tc7_symbol
:
2015 /* Only happens when called at top level. */
2016 x
= scm_cons (x
, SCM_UNDEFINED
);
2017 RETURN (*scm_lookupcar (x
, env
, 1));
2019 case SCM_BIT7 (SCM_IM_AND
):
2021 while (!SCM_NULLP (SCM_CDR (x
)))
2023 SCM test_result
= EVALCAR (x
, env
);
2024 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2025 RETURN (SCM_BOOL_F
);
2029 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2032 case SCM_BIT7 (SCM_IM_BEGIN
):
2035 RETURN (SCM_UNSPECIFIED
);
2037 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2040 /* If we are on toplevel with a lookup closure, we need to sync
2041 with the current module. */
2042 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2044 UPDATE_TOPLEVEL_ENV (env
);
2045 while (!SCM_NULLP (SCM_CDR (x
)))
2048 UPDATE_TOPLEVEL_ENV (env
);
2054 goto nontoplevel_begin
;
2057 while (!SCM_NULLP (SCM_CDR (x
)))
2059 SCM form
= SCM_CAR (x
);
2062 if (SCM_ISYMP (form
))
2064 scm_rec_mutex_lock (&source_mutex
);
2065 /* check for race condition */
2066 if (SCM_ISYMP (SCM_CAR (x
)))
2067 x
= scm_m_expand_body (x
, env
);
2068 scm_rec_mutex_unlock (&source_mutex
);
2069 goto nontoplevel_begin
;
2072 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2075 SCM_CEVAL (form
, env
);
2081 /* scm_eval last form in list */
2082 SCM last_form
= SCM_CAR (x
);
2084 if (SCM_CONSP (last_form
))
2086 /* This is by far the most frequent case. */
2088 goto loop
; /* tail recurse */
2090 else if (SCM_IMP (last_form
))
2091 RETURN (SCM_EVALIM (last_form
, env
));
2092 else if (SCM_VARIABLEP (last_form
))
2093 RETURN (SCM_VARIABLE_REF (last_form
));
2094 else if (SCM_SYMBOLP (last_form
))
2095 RETURN (*scm_lookupcar (x
, env
, 1));
2101 case SCM_BIT7 (SCM_IM_CASE
):
2104 SCM key
= EVALCAR (x
, env
);
2106 while (!SCM_NULLP (x
))
2108 SCM clause
= SCM_CAR (x
);
2109 SCM labels
= SCM_CAR (clause
);
2110 if (SCM_EQ_P (labels
, scm_sym_else
))
2112 x
= SCM_CDR (clause
);
2113 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2116 while (!SCM_NULLP (labels
))
2118 SCM label
= SCM_CAR (labels
);
2119 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2121 x
= SCM_CDR (clause
);
2122 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2125 labels
= SCM_CDR (labels
);
2130 RETURN (SCM_UNSPECIFIED
);
2133 case SCM_BIT7 (SCM_IM_COND
):
2135 while (!SCM_NULLP (x
))
2137 SCM clause
= SCM_CAR (x
);
2138 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2140 x
= SCM_CDR (clause
);
2141 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2146 arg1
= EVALCAR (clause
, env
);
2147 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2149 x
= SCM_CDR (clause
);
2152 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2154 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2160 proc
= EVALCAR (proc
, env
);
2161 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2162 PREP_APPLY (proc
, scm_list_1 (arg1
));
2164 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2165 goto umwrongnumargs
;
2173 RETURN (SCM_UNSPECIFIED
);
2176 case SCM_BIT7 (SCM_IM_DO
):
2179 /* Compute the initialization values and the initial environment. */
2180 SCM init_forms
= SCM_CADR (x
);
2181 SCM init_values
= SCM_EOL
;
2182 while (!SCM_NULLP (init_forms
))
2184 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2185 init_forms
= SCM_CDR (init_forms
);
2187 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2191 SCM test_form
= SCM_CAR (x
);
2192 SCM body_forms
= SCM_CADR (x
);
2193 SCM step_forms
= SCM_CDDR (x
);
2195 SCM test_result
= EVALCAR (test_form
, env
);
2197 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2200 /* Evaluate body forms. */
2202 for (temp_forms
= body_forms
;
2203 !SCM_NULLP (temp_forms
);
2204 temp_forms
= SCM_CDR (temp_forms
))
2206 SCM form
= SCM_CAR (temp_forms
);
2207 /* Dirk:FIXME: We only need to eval forms, that may have a
2208 * side effect here. This is only true for forms that start
2209 * with a pair. All others are just constants. However,
2210 * since in the common case there is no constant expression
2211 * in a body of a do form, we just check for immediates here
2212 * and have SCM_CEVAL take care of other cases. In the long
2213 * run it would make sense to get rid of this test and have
2214 * the macro transformer of 'do' eliminate all forms that
2215 * have no sideeffect. */
2216 if (!SCM_IMP (form
))
2217 SCM_CEVAL (form
, env
);
2222 /* Evaluate the step expressions. */
2224 SCM step_values
= SCM_EOL
;
2225 for (temp_forms
= step_forms
;
2226 !SCM_NULLP (temp_forms
);
2227 temp_forms
= SCM_CDR (temp_forms
))
2229 SCM value
= EVALCAR (temp_forms
, env
);
2230 step_values
= scm_cons (value
, step_values
);
2232 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2237 test_result
= EVALCAR (test_form
, env
);
2242 RETURN (SCM_UNSPECIFIED
);
2243 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2244 goto nontoplevel_begin
;
2247 case SCM_BIT7 (SCM_IM_IF
):
2250 SCM test_result
= EVALCAR (x
, env
);
2251 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2257 RETURN (SCM_UNSPECIFIED
);
2260 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2264 case SCM_BIT7 (SCM_IM_LET
):
2267 SCM init_forms
= SCM_CADR (x
);
2268 SCM init_values
= SCM_EOL
;
2271 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2272 init_forms
= SCM_CDR (init_forms
);
2274 while (!SCM_NULLP (init_forms
));
2275 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2278 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2279 goto nontoplevel_begin
;
2282 case SCM_BIT7 (SCM_IM_LETREC
):
2284 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2287 SCM init_forms
= SCM_CAR (x
);
2288 SCM init_values
= SCM_EOL
;
2291 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2292 init_forms
= SCM_CDR (init_forms
);
2294 while (!SCM_NULLP (init_forms
));
2295 SCM_SETCDR (SCM_CAR (env
), init_values
);
2298 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2299 goto nontoplevel_begin
;
2302 case SCM_BIT7 (SCM_IM_LETSTAR
):
2305 SCM bindings
= SCM_CAR (x
);
2306 if (SCM_NULLP (bindings
))
2307 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2312 SCM name
= SCM_CAR (bindings
);
2313 SCM init
= SCM_CDR (bindings
);
2314 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2315 bindings
= SCM_CDR (init
);
2317 while (!SCM_NULLP (bindings
));
2321 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2322 goto nontoplevel_begin
;
2325 case SCM_BIT7 (SCM_IM_OR
):
2327 while (!SCM_NULLP (SCM_CDR (x
)))
2329 SCM val
= EVALCAR (x
, env
);
2330 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2335 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2339 case SCM_BIT7 (SCM_IM_LAMBDA
):
2340 RETURN (scm_closure (SCM_CDR (x
), env
));
2343 case SCM_BIT7 (SCM_IM_QUOTE
):
2344 RETURN (SCM_CADR (x
));
2347 case SCM_BIT7 (SCM_IM_SET_X
):
2351 SCM variable
= SCM_CAR (x
);
2352 if (SCM_ILOCP (variable
))
2353 location
= scm_ilookup (variable
, env
);
2354 else if (SCM_VARIABLEP (variable
))
2355 location
= SCM_VARIABLE_LOC (variable
);
2356 else /* (SCM_SYMBOLP (variable)) is known to be true */
2357 location
= scm_lookupcar (x
, env
, 1);
2359 *location
= EVALCAR (x
, env
);
2361 RETURN (SCM_UNSPECIFIED
);
2364 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2365 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2368 /* new syntactic forms go here. */
2369 case SCM_BIT7 (SCM_MAKISYM (0)):
2371 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2372 switch (SCM_ISYMNUM (proc
))
2376 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2378 proc
= EVALCAR (proc
, env
);
2379 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2380 if (SCM_CLOSUREP (proc
))
2382 PREP_APPLY (proc
, SCM_EOL
);
2383 arg1
= SCM_CDDR (x
);
2384 arg1
= EVALCAR (arg1
, env
);
2386 /* Go here to tail-call a closure. PROC is the closure
2387 and ARG1 is the list of arguments. Do not forget to
2390 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2392 debug
.info
->a
.args
= arg1
;
2394 if (scm_badargsp (formals
, arg1
))
2395 scm_wrong_num_args (proc
);
2397 /* Copy argument list */
2398 if (SCM_NULL_OR_NIL_P (arg1
))
2399 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2402 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2404 arg1
= SCM_CDR (arg1
);
2405 while (!SCM_NULL_OR_NIL_P (arg1
))
2407 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2408 SCM_SETCDR (tail
, new_tail
);
2410 arg1
= SCM_CDR (arg1
);
2412 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2415 x
= SCM_CLOSURE_BODY (proc
);
2416 goto nontoplevel_begin
;
2426 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2429 SCM val
= scm_make_continuation (&first
);
2437 proc
= scm_eval_car (proc
, env
);
2438 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2439 PREP_APPLY (proc
, scm_list_1 (arg1
));
2441 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2442 goto umwrongnumargs
;
2448 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2449 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2452 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2453 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2456 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
2457 following code (type_dispatch) is intended to be the tail
2458 of the case clause for the internal macro
2459 SCM_IM_DISPATCH. Please don't remove it from this
2460 location without discussing it with Mikael
2461 <djurfeldt@nada.kth.se> */
2463 /* The type dispatch code is duplicated below
2464 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2465 * cuts down execution time for type dispatch to 50%. */
2466 type_dispatch
: /* inputs: x, arg1 */
2467 /* Type dispatch means to determine from the types of the function
2468 * arguments (i. e. the 'signature' of the call), which method from
2469 * a generic function is to be called. This process of selecting
2470 * the right method takes some time. To speed it up, guile uses
2471 * caching: Together with the macro call to dispatch the signatures
2472 * of some previous calls to that generic function from the same
2473 * place are stored (in the code!) in a cache that we call the
2474 * 'method cache'. This is done since it is likely, that
2475 * consecutive calls to dispatch from that position in the code will
2476 * have the same signature. Thus, the type dispatch works as
2477 * follows: First, determine a hash value from the signature of the
2478 * actual arguments. Second, use this hash value as an index to
2479 * find that same signature in the method cache stored at this
2480 * position in the code. If found, you have also found the
2481 * corresponding method that belongs to that signature. If the
2482 * signature is not found in the method cache, you have to perform a
2483 * full search over all signatures stored with the generic
2486 unsigned long int specializers
;
2487 unsigned long int hash_value
;
2488 unsigned long int cache_end_pos
;
2489 unsigned long int mask
;
2493 SCM z
= SCM_CDDR (x
);
2494 SCM tmp
= SCM_CADR (z
);
2495 specializers
= SCM_INUM (SCM_CAR (z
));
2497 /* Compute a hash value for searching the method cache. There
2498 * are two variants for computing the hash value, a (rather)
2499 * complicated one, and a simple one. For the complicated one
2500 * explained below, tmp holds a number that is used in the
2502 if (SCM_INUMP (tmp
))
2504 /* Use the signature of the actual arguments to determine
2505 * the hash value. This is done as follows: Each class has
2506 * an array of random numbers, that are determined when the
2507 * class is created. The integer 'hashset' is an index into
2508 * that array of random numbers. Now, from all classes that
2509 * are part of the signature of the actual arguments, the
2510 * random numbers at index 'hashset' are taken and summed
2511 * up, giving the hash value. The value of 'hashset' is
2512 * stored at the call to dispatch. This allows to have
2513 * different 'formulas' for calculating the hash value at
2514 * different places where dispatch is called. This allows
2515 * to optimize the hash formula at every individual place
2516 * where dispatch is called, such that hopefully the hash
2517 * value that is computed will directly point to the right
2518 * method in the method cache. */
2519 unsigned long int hashset
= SCM_INUM (tmp
);
2520 unsigned long int counter
= specializers
+ 1;
2523 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2525 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2526 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2527 tmp_arg
= SCM_CDR (tmp_arg
);
2531 method_cache
= SCM_CADR (z
);
2532 mask
= SCM_INUM (SCM_CAR (z
));
2534 cache_end_pos
= hash_value
;
2538 /* This method of determining the hash value is much
2539 * simpler: Set the hash value to zero and just perform a
2540 * linear search through the method cache. */
2542 mask
= (unsigned long int) ((long) -1);
2544 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2549 /* Search the method cache for a method with a matching
2550 * signature. Start the search at position 'hash_value'. The
2551 * hashing implementation uses linear probing for conflict
2552 * resolution, that is, if the signature in question is not
2553 * found at the starting index in the hash table, the next table
2554 * entry is tried, and so on, until in the worst case the whole
2555 * cache has been searched, but still the signature has not been
2560 SCM args
= arg1
; /* list of arguments */
2561 z
= SCM_VELTS (method_cache
)[hash_value
];
2562 while (!SCM_NULLP (args
))
2564 /* More arguments than specifiers => CLASS != ENV */
2565 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2566 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2568 args
= SCM_CDR (args
);
2571 /* Fewer arguments than specifiers => CAR != ENV */
2572 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2575 hash_value
= (hash_value
+ 1) & mask
;
2576 } while (hash_value
!= cache_end_pos
);
2578 /* No appropriate method was found in the cache. */
2579 z
= scm_memoize_method (x
, arg1
);
2581 apply_cmethod
: /* inputs: z, arg1 */
2583 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2584 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2585 x
= SCM_CMETHOD_BODY (z
);
2586 goto nontoplevel_begin
;
2592 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2595 SCM instance
= EVALCAR (x
, env
);
2596 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2597 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2601 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2604 SCM instance
= EVALCAR (x
, env
);
2605 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2606 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2607 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2608 RETURN (SCM_UNSPECIFIED
);
2612 #if SCM_ENABLE_ELISP
2614 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2616 SCM test_form
= SCM_CDR (x
);
2617 x
= SCM_CDR (test_form
);
2618 while (!SCM_NULL_OR_NIL_P (x
))
2620 SCM test_result
= EVALCAR (test_form
, env
);
2621 if (!(SCM_FALSEP (test_result
)
2622 || SCM_NULL_OR_NIL_P (test_result
)))
2624 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2625 RETURN (test_result
);
2626 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2631 test_form
= SCM_CDR (x
);
2632 x
= SCM_CDR (test_form
);
2636 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2640 #endif /* SCM_ENABLE_ELISP */
2642 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2644 SCM vars
, exps
, vals
;
2647 vars
= SCM_CAAR (x
);
2648 exps
= SCM_CDAR (x
);
2652 while (SCM_NIMP (exps
))
2654 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2655 exps
= SCM_CDR (exps
);
2658 scm_swap_bindings (vars
, vals
);
2659 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2661 /* Ignore all but the last evaluation result. */
2662 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2664 if (SCM_CONSP (SCM_CAR (x
)))
2665 SCM_CEVAL (SCM_CAR (x
), env
);
2667 proc
= EVALCAR (x
, env
);
2669 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2670 scm_swap_bindings (vars
, vals
);
2676 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2679 x
= EVALCAR (proc
, env
);
2680 proc
= SCM_CDR (proc
);
2681 proc
= EVALCAR (proc
, env
);
2682 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2683 if (SCM_VALUESP (arg1
))
2684 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2686 arg1
= scm_list_1 (arg1
);
2687 if (SCM_CLOSUREP (proc
))
2689 PREP_APPLY (proc
, arg1
);
2692 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2703 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2704 case scm_tc7_vector
:
2708 case scm_tc7_byvect
:
2715 #if SCM_SIZEOF_LONG_LONG != 0
2716 case scm_tc7_llvect
:
2719 case scm_tc7_string
:
2721 case scm_tcs_closures
:
2725 case scm_tcs_struct
:
2728 case scm_tc7_variable
:
2729 RETURN (SCM_VARIABLE_REF(x
));
2731 case SCM_BIT7 (SCM_ILOC00
):
2732 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2733 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2736 case scm_tcs_cons_nimcar
:
2737 if (SCM_SYMBOLP (SCM_CAR (x
)))
2739 SCM orig_sym
= SCM_CAR (x
);
2741 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2742 if (location
== NULL
)
2744 /* we have lost the race, start again. */
2752 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2756 if (SCM_MACROP (proc
))
2758 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2760 handle_a_macro
: /* inputs: x, env, proc */
2762 /* Set a flag during macro expansion so that macro
2763 application frames can be deleted from the backtrace. */
2764 SCM_SET_MACROEXP (debug
);
2766 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2767 scm_cons (env
, scm_listofnull
));
2770 SCM_CLEAR_MACROEXP (debug
);
2772 switch (SCM_MACRO_TYPE (proc
))
2775 if (scm_ilength (arg1
) <= 0)
2776 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2778 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2781 SCM_SETCAR (x
, SCM_CAR (arg1
));
2782 SCM_SETCDR (x
, SCM_CDR (arg1
));
2786 /* Prevent memoizing of debug info expression. */
2787 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2792 SCM_SETCAR (x
, SCM_CAR (arg1
));
2793 SCM_SETCDR (x
, SCM_CDR (arg1
));
2795 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2797 #if SCM_ENABLE_DEPRECATED == 1
2802 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2814 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2815 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2818 if (SCM_CLOSUREP (proc
))
2820 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2821 SCM args
= SCM_CDR (x
);
2822 while (!SCM_NULLP (formals
))
2824 if (!SCM_CONSP (formals
))
2827 goto umwrongnumargs
;
2828 formals
= SCM_CDR (formals
);
2829 args
= SCM_CDR (args
);
2831 if (!SCM_NULLP (args
))
2832 goto umwrongnumargs
;
2834 else if (SCM_MACROP (proc
))
2835 goto handle_a_macro
;
2839 evapply
: /* inputs: x, proc */
2840 PREP_APPLY (proc
, SCM_EOL
);
2841 if (SCM_NULLP (SCM_CDR (x
))) {
2844 switch (SCM_TYP7 (proc
))
2845 { /* no arguments given */
2846 case scm_tc7_subr_0
:
2847 RETURN (SCM_SUBRF (proc
) ());
2848 case scm_tc7_subr_1o
:
2849 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2851 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2852 case scm_tc7_rpsubr
:
2853 RETURN (SCM_BOOL_T
);
2855 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2857 if (!SCM_SMOB_APPLICABLE_P (proc
))
2859 RETURN (SCM_SMOB_APPLY_0 (proc
));
2862 proc
= SCM_CCLO_SUBR (proc
);
2864 debug
.info
->a
.proc
= proc
;
2865 debug
.info
->a
.args
= scm_list_1 (arg1
);
2869 proc
= SCM_PROCEDURE (proc
);
2871 debug
.info
->a
.proc
= proc
;
2873 if (!SCM_CLOSUREP (proc
))
2875 if (scm_badformalsp (proc
, 0))
2876 goto umwrongnumargs
;
2877 case scm_tcs_closures
:
2878 x
= SCM_CLOSURE_BODY (proc
);
2879 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
2882 goto nontoplevel_begin
;
2883 case scm_tcs_struct
:
2884 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2886 x
= SCM_ENTITY_PROCEDURE (proc
);
2890 else if (!SCM_I_OPERATORP (proc
))
2895 proc
= (SCM_I_ENTITYP (proc
)
2896 ? SCM_ENTITY_PROCEDURE (proc
)
2897 : SCM_OPERATOR_PROCEDURE (proc
));
2899 debug
.info
->a
.proc
= proc
;
2900 debug
.info
->a
.args
= scm_list_1 (arg1
);
2902 if (SCM_NIMP (proc
))
2907 case scm_tc7_subr_1
:
2908 case scm_tc7_subr_2
:
2909 case scm_tc7_subr_2o
:
2911 case scm_tc7_subr_3
:
2912 case scm_tc7_lsubr_2
:
2915 scm_wrong_num_args (proc
);
2917 /* handle macros here */
2922 /* must handle macros by here */
2925 arg1
= EVALCAR (x
, env
);
2927 scm_wrong_num_args (proc
);
2929 debug
.info
->a
.args
= scm_list_1 (arg1
);
2937 evap1
: /* inputs: proc, arg1 */
2938 switch (SCM_TYP7 (proc
))
2939 { /* have one argument in arg1 */
2940 case scm_tc7_subr_2o
:
2941 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2942 case scm_tc7_subr_1
:
2943 case scm_tc7_subr_1o
:
2944 RETURN (SCM_SUBRF (proc
) (arg1
));
2946 if (SCM_SUBRF (proc
))
2948 if (SCM_INUMP (arg1
))
2950 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2952 else if (SCM_REALP (arg1
))
2954 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2956 else if (SCM_BIGP (arg1
))
2958 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2960 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2961 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2963 proc
= SCM_SNAME (proc
);
2965 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2966 while ('c' != *--chrs
)
2968 SCM_ASSERT (SCM_CONSP (arg1
),
2969 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2970 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2974 case scm_tc7_rpsubr
:
2975 RETURN (SCM_BOOL_T
);
2977 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2980 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2982 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2985 if (!SCM_SMOB_APPLICABLE_P (proc
))
2987 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2991 proc
= SCM_CCLO_SUBR (proc
);
2993 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2994 debug
.info
->a
.proc
= proc
;
2998 proc
= SCM_PROCEDURE (proc
);
3000 debug
.info
->a
.proc
= proc
;
3002 if (!SCM_CLOSUREP (proc
))
3004 if (scm_badformalsp (proc
, 1))
3005 goto umwrongnumargs
;
3006 case scm_tcs_closures
:
3008 x
= SCM_CLOSURE_BODY (proc
);
3010 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3014 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3018 goto nontoplevel_begin
;
3019 case scm_tcs_struct
:
3020 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3022 x
= SCM_ENTITY_PROCEDURE (proc
);
3024 arg1
= debug
.info
->a
.args
;
3026 arg1
= scm_list_1 (arg1
);
3030 else if (!SCM_I_OPERATORP (proc
))
3036 proc
= (SCM_I_ENTITYP (proc
)
3037 ? SCM_ENTITY_PROCEDURE (proc
)
3038 : SCM_OPERATOR_PROCEDURE (proc
));
3040 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3041 debug
.info
->a
.proc
= proc
;
3043 if (SCM_NIMP (proc
))
3048 case scm_tc7_subr_2
:
3049 case scm_tc7_subr_0
:
3050 case scm_tc7_subr_3
:
3051 case scm_tc7_lsubr_2
:
3052 scm_wrong_num_args (proc
);
3058 arg2
= EVALCAR (x
, env
);
3060 scm_wrong_num_args (proc
);
3062 { /* have two or more arguments */
3064 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3067 if (SCM_NULLP (x
)) {
3070 switch (SCM_TYP7 (proc
))
3071 { /* have two arguments */
3072 case scm_tc7_subr_2
:
3073 case scm_tc7_subr_2o
:
3074 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3077 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3079 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3081 case scm_tc7_lsubr_2
:
3082 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3083 case scm_tc7_rpsubr
:
3085 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3087 if (!SCM_SMOB_APPLICABLE_P (proc
))
3089 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3093 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3094 scm_cons (proc
, debug
.info
->a
.args
),
3097 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3098 scm_cons2 (proc
, arg1
,
3105 case scm_tcs_struct
:
3106 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3108 x
= SCM_ENTITY_PROCEDURE (proc
);
3110 arg1
= debug
.info
->a
.args
;
3112 arg1
= scm_list_2 (arg1
, arg2
);
3116 else if (!SCM_I_OPERATORP (proc
))
3122 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3123 ? SCM_ENTITY_PROCEDURE (proc
)
3124 : SCM_OPERATOR_PROCEDURE (proc
),
3125 scm_cons (proc
, debug
.info
->a
.args
),
3128 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3129 ? SCM_ENTITY_PROCEDURE (proc
)
3130 : SCM_OPERATOR_PROCEDURE (proc
),
3131 scm_cons2 (proc
, arg1
,
3139 case scm_tc7_subr_0
:
3141 case scm_tc7_subr_1o
:
3142 case scm_tc7_subr_1
:
3143 case scm_tc7_subr_3
:
3144 scm_wrong_num_args (proc
);
3148 proc
= SCM_PROCEDURE (proc
);
3150 debug
.info
->a
.proc
= proc
;
3152 if (!SCM_CLOSUREP (proc
))
3154 if (scm_badformalsp (proc
, 2))
3155 goto umwrongnumargs
;
3156 case scm_tcs_closures
:
3159 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3163 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3164 scm_list_2 (arg1
, arg2
),
3167 x
= SCM_CLOSURE_BODY (proc
);
3168 goto nontoplevel_begin
;
3172 scm_wrong_num_args (proc
);
3174 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3175 deval_args (x
, env
, proc
,
3176 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3180 switch (SCM_TYP7 (proc
))
3181 { /* have 3 or more arguments */
3183 case scm_tc7_subr_3
:
3184 if (!SCM_NULLP (SCM_CDR (x
)))
3185 scm_wrong_num_args (proc
);
3187 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3188 SCM_CADDR (debug
.info
->a
.args
)));
3190 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3191 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3194 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3195 arg2
= SCM_CDR (arg2
);
3197 while (SCM_NIMP (arg2
));
3199 case scm_tc7_rpsubr
:
3200 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3201 RETURN (SCM_BOOL_F
);
3202 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3205 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3206 RETURN (SCM_BOOL_F
);
3207 arg2
= SCM_CAR (arg1
);
3208 arg1
= SCM_CDR (arg1
);
3210 while (SCM_NIMP (arg1
));
3211 RETURN (SCM_BOOL_T
);
3212 case scm_tc7_lsubr_2
:
3213 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3214 SCM_CDDR (debug
.info
->a
.args
)));
3216 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3218 if (!SCM_SMOB_APPLICABLE_P (proc
))
3220 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3221 SCM_CDDR (debug
.info
->a
.args
)));
3225 proc
= SCM_PROCEDURE (proc
);
3226 debug
.info
->a
.proc
= proc
;
3227 if (!SCM_CLOSUREP (proc
))
3229 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3230 goto umwrongnumargs
;
3231 case scm_tcs_closures
:
3232 SCM_SET_ARGSREADY (debug
);
3233 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3236 x
= SCM_CLOSURE_BODY (proc
);
3237 goto nontoplevel_begin
;
3239 case scm_tc7_subr_3
:
3240 if (!SCM_NULLP (SCM_CDR (x
)))
3241 scm_wrong_num_args (proc
);
3243 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3245 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3248 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3251 while (SCM_NIMP (x
));
3253 case scm_tc7_rpsubr
:
3254 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3255 RETURN (SCM_BOOL_F
);
3258 arg1
= EVALCAR (x
, env
);
3259 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3260 RETURN (SCM_BOOL_F
);
3264 while (SCM_NIMP (x
));
3265 RETURN (SCM_BOOL_T
);
3266 case scm_tc7_lsubr_2
:
3267 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3269 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3271 scm_eval_args (x
, env
, proc
))));
3273 if (!SCM_SMOB_APPLICABLE_P (proc
))
3275 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3276 scm_eval_args (x
, env
, proc
)));
3280 proc
= SCM_PROCEDURE (proc
);
3281 if (!SCM_CLOSUREP (proc
))
3284 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3285 if (SCM_NULLP (formals
)
3286 || (SCM_CONSP (formals
)
3287 && (SCM_NULLP (SCM_CDR (formals
))
3288 || (SCM_CONSP (SCM_CDR (formals
))
3289 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3290 goto umwrongnumargs
;
3292 case scm_tcs_closures
:
3294 SCM_SET_ARGSREADY (debug
);
3296 env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3299 scm_eval_args (x
, env
, proc
)),
3301 x
= SCM_CLOSURE_BODY (proc
);
3302 goto nontoplevel_begin
;
3304 case scm_tcs_struct
:
3305 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3308 arg1
= debug
.info
->a
.args
;
3310 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3312 x
= SCM_ENTITY_PROCEDURE (proc
);
3315 else if (!SCM_I_OPERATORP (proc
))
3319 case scm_tc7_subr_2
:
3320 case scm_tc7_subr_1o
:
3321 case scm_tc7_subr_2o
:
3322 case scm_tc7_subr_0
:
3324 case scm_tc7_subr_1
:
3325 scm_wrong_num_args (proc
);
3333 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3334 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3336 SCM_CLEAR_TRACED_FRAME (debug
);
3337 if (SCM_CHEAPTRAPS_P
)
3338 arg1
= scm_make_debugobj (&debug
);
3342 SCM val
= scm_make_continuation (&first
);
3353 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3357 scm_last_debug_frame
= debug
.prev
;
3363 /* SECTION: This code is compiled once.
3370 /* Simple procedure calls
3374 scm_call_0 (SCM proc
)
3376 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3380 scm_call_1 (SCM proc
, SCM arg1
)
3382 return scm_apply (proc
, arg1
, scm_listofnull
);
3386 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3388 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3392 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3394 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3398 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3400 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3401 scm_cons (arg4
, scm_listofnull
)));
3404 /* Simple procedure applies
3408 scm_apply_0 (SCM proc
, SCM args
)
3410 return scm_apply (proc
, args
, SCM_EOL
);
3414 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3416 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3420 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3422 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3426 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3428 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3432 /* This code processes the arguments to apply:
3434 (apply PROC ARG1 ... ARGS)
3436 Given a list (ARG1 ... ARGS), this function conses the ARG1
3437 ... arguments onto the front of ARGS, and returns the resulting
3438 list. Note that ARGS is a list; thus, the argument to this
3439 function is a list whose last element is a list.
3441 Apply calls this function, and applies PROC to the elements of the
3442 result. apply:nconc2last takes care of building the list of
3443 arguments, given (ARG1 ... ARGS).
3445 Rather than do new consing, apply:nconc2last destroys its argument.
3446 On that topic, this code came into my care with the following
3447 beautifully cryptic comment on that topic: "This will only screw
3448 you if you do (scm_apply scm_apply '( ... ))" If you know what
3449 they're referring to, send me a patch to this comment. */
3451 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3453 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3454 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3455 "@var{args}, and returns the resulting list. Note that\n"
3456 "@var{args} is a list; thus, the argument to this function is\n"
3457 "a list whose last element is a list.\n"
3458 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3459 "destroys its argument, so use with care.")
3460 #define FUNC_NAME s_scm_nconc2last
3463 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3465 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3466 SCM_NULL_OR_NIL_P, but not
3467 needed in 99.99% of cases,
3468 and it could seriously hurt
3469 performance. - Neil */
3470 lloc
= SCM_CDRLOC (*lloc
);
3471 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3472 *lloc
= SCM_CAR (*lloc
);
3480 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3481 * It is compiled twice.
3486 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3492 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3497 /* Apply a function to a list of arguments.
3499 This function is exported to the Scheme level as taking two
3500 required arguments and a tail argument, as if it were:
3501 (lambda (proc arg1 . args) ...)
3502 Thus, if you just have a list of arguments to pass to a procedure,
3503 pass the list as ARG1, and '() for ARGS. If you have some fixed
3504 args, pass the first as ARG1, then cons any remaining fixed args
3505 onto the front of your argument list, and pass that as ARGS. */
3508 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3511 scm_t_debug_frame debug
;
3512 scm_t_debug_info debug_vect_body
;
3513 debug
.prev
= scm_last_debug_frame
;
3514 debug
.status
= SCM_APPLYFRAME
;
3515 debug
.vect
= &debug_vect_body
;
3516 debug
.vect
[0].a
.proc
= proc
;
3517 debug
.vect
[0].a
.args
= SCM_EOL
;
3518 scm_last_debug_frame
= &debug
;
3521 return scm_dapply (proc
, arg1
, args
);
3524 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3526 /* If ARGS is the empty list, then we're calling apply with only two
3527 arguments --- ARG1 is the list of arguments for PROC. Whatever
3528 the case, futz with things so that ARG1 is the first argument to
3529 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3532 Setting the debug apply frame args this way is pretty messy.
3533 Perhaps we should store arg1 and args directly in the frame as
3534 received, and let scm_frame_arguments unpack them, because that's
3535 a relatively rare operation. This works for now; if the Guile
3536 developer archives are still around, see Mikael's post of
3538 if (SCM_NULLP (args
))
3540 if (SCM_NULLP (arg1
))
3542 arg1
= SCM_UNDEFINED
;
3544 debug
.vect
[0].a
.args
= SCM_EOL
;
3550 debug
.vect
[0].a
.args
= arg1
;
3552 args
= SCM_CDR (arg1
);
3553 arg1
= SCM_CAR (arg1
);
3558 args
= scm_nconc2last (args
);
3560 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3564 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3567 if (SCM_CHEAPTRAPS_P
)
3568 tmp
= scm_make_debugobj (&debug
);
3573 tmp
= scm_make_continuation (&first
);
3578 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3585 switch (SCM_TYP7 (proc
))
3587 case scm_tc7_subr_2o
:
3588 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3589 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3590 case scm_tc7_subr_2
:
3591 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3592 scm_wrong_num_args (proc
);
3593 args
= SCM_CAR (args
);
3594 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3595 case scm_tc7_subr_0
:
3596 if (!SCM_UNBNDP (arg1
))
3597 scm_wrong_num_args (proc
);
3599 RETURN (SCM_SUBRF (proc
) ());
3600 case scm_tc7_subr_1
:
3601 if (SCM_UNBNDP (arg1
))
3602 scm_wrong_num_args (proc
);
3603 case scm_tc7_subr_1o
:
3604 if (!SCM_NULLP (args
))
3605 scm_wrong_num_args (proc
);
3607 RETURN (SCM_SUBRF (proc
) (arg1
));
3609 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3610 scm_wrong_num_args (proc
);
3611 if (SCM_SUBRF (proc
))
3613 if (SCM_INUMP (arg1
))
3615 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3617 else if (SCM_REALP (arg1
))
3619 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3621 else if (SCM_BIGP (arg1
))
3622 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3623 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3624 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3626 proc
= SCM_SNAME (proc
);
3628 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3629 while ('c' != *--chrs
)
3631 SCM_ASSERT (SCM_CONSP (arg1
),
3632 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3633 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3637 case scm_tc7_subr_3
:
3638 if (SCM_NULLP (args
)
3639 || SCM_NULLP (SCM_CDR (args
))
3640 || !SCM_NULLP (SCM_CDDR (args
)))
3641 scm_wrong_num_args (proc
);
3643 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3646 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3648 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3650 case scm_tc7_lsubr_2
:
3651 if (!SCM_CONSP (args
))
3652 scm_wrong_num_args (proc
);
3654 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3656 if (SCM_NULLP (args
))
3657 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3658 while (SCM_NIMP (args
))
3660 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3661 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3662 args
= SCM_CDR (args
);
3665 case scm_tc7_rpsubr
:
3666 if (SCM_NULLP (args
))
3667 RETURN (SCM_BOOL_T
);
3668 while (SCM_NIMP (args
))
3670 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3671 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3672 RETURN (SCM_BOOL_F
);
3673 arg1
= SCM_CAR (args
);
3674 args
= SCM_CDR (args
);
3676 RETURN (SCM_BOOL_T
);
3677 case scm_tcs_closures
:
3679 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3681 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3683 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3684 scm_wrong_num_args (proc
);
3686 /* Copy argument list */
3691 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3692 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
3694 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
3697 SCM_SETCDR (tl
, arg1
);
3700 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3703 proc
= SCM_CLOSURE_BODY (proc
);
3705 arg1
= SCM_CDR (proc
);
3706 while (!SCM_NULLP (arg1
))
3708 if (SCM_IMP (SCM_CAR (proc
)))
3710 if (SCM_ISYMP (SCM_CAR (proc
)))
3712 scm_rec_mutex_lock (&source_mutex
);
3713 /* check for race condition */
3714 if (SCM_ISYMP (SCM_CAR (proc
)))
3715 proc
= scm_m_expand_body (proc
, args
);
3716 scm_rec_mutex_unlock (&source_mutex
);
3720 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3723 SCM_CEVAL (SCM_CAR (proc
), args
);
3725 arg1
= SCM_CDR (proc
);
3727 RETURN (EVALCAR (proc
, args
));
3729 if (!SCM_SMOB_APPLICABLE_P (proc
))
3731 if (SCM_UNBNDP (arg1
))
3732 RETURN (SCM_SMOB_APPLY_0 (proc
));
3733 else if (SCM_NULLP (args
))
3734 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3735 else if (SCM_NULLP (SCM_CDR (args
)))
3736 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3738 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3741 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3743 proc
= SCM_CCLO_SUBR (proc
);
3744 debug
.vect
[0].a
.proc
= proc
;
3745 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3747 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3749 proc
= SCM_CCLO_SUBR (proc
);
3753 proc
= SCM_PROCEDURE (proc
);
3755 debug
.vect
[0].a
.proc
= proc
;
3758 case scm_tcs_struct
:
3759 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3762 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3764 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3766 RETURN (scm_apply_generic (proc
, args
));
3768 else if (!SCM_I_OPERATORP (proc
))
3774 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3776 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3779 proc
= (SCM_I_ENTITYP (proc
)
3780 ? SCM_ENTITY_PROCEDURE (proc
)
3781 : SCM_OPERATOR_PROCEDURE (proc
));
3783 debug
.vect
[0].a
.proc
= proc
;
3784 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3786 if (SCM_NIMP (proc
))
3793 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3797 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3798 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3800 SCM_CLEAR_TRACED_FRAME (debug
);
3801 if (SCM_CHEAPTRAPS_P
)
3802 arg1
= scm_make_debugobj (&debug
);
3806 SCM val
= scm_make_continuation (&first
);
3817 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3821 scm_last_debug_frame
= debug
.prev
;
3827 /* SECTION: The rest of this file is only read once.
3834 * Trampolines make it possible to move procedure application dispatch
3835 * outside inner loops. The motivation was clean implementation of
3836 * efficient replacements of R5RS primitives in SRFI-1.
3838 * The semantics is clear: scm_trampoline_N returns an optimized
3839 * version of scm_call_N (or NULL if the procedure isn't applicable
3842 * Applying the optimization to map and for-each increased efficiency
3843 * noticeably. For example, (map abs ls) is now 8 times faster than
3848 call_subr0_0 (SCM proc
)
3850 return SCM_SUBRF (proc
) ();
3854 call_subr1o_0 (SCM proc
)
3856 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3860 call_lsubr_0 (SCM proc
)
3862 return SCM_SUBRF (proc
) (SCM_EOL
);
3866 scm_i_call_closure_0 (SCM proc
)
3868 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3871 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3876 scm_trampoline_0 (SCM proc
)
3882 switch (SCM_TYP7 (proc
))
3884 case scm_tc7_subr_0
:
3885 return call_subr0_0
;
3886 case scm_tc7_subr_1o
:
3887 return call_subr1o_0
;
3889 return call_lsubr_0
;
3890 case scm_tcs_closures
:
3892 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3893 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3894 return scm_i_call_closure_0
;
3898 case scm_tcs_struct
:
3899 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3900 return scm_call_generic_0
;
3901 else if (!SCM_I_OPERATORP (proc
))
3905 if (SCM_SMOB_APPLICABLE_P (proc
))
3906 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3910 case scm_tc7_rpsubr
:
3915 return NULL
; /* not applicable on one arg */
3920 call_subr1_1 (SCM proc
, SCM arg1
)
3922 return SCM_SUBRF (proc
) (arg1
);
3926 call_subr2o_1 (SCM proc
, SCM arg1
)
3928 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3932 call_lsubr_1 (SCM proc
, SCM arg1
)
3934 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3938 call_dsubr_1 (SCM proc
, SCM arg1
)
3940 if (SCM_INUMP (arg1
))
3942 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3944 else if (SCM_REALP (arg1
))
3946 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3948 else if (SCM_BIGP (arg1
))
3949 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3950 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3951 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3955 call_cxr_1 (SCM proc
, SCM arg1
)
3957 proc
= SCM_SNAME (proc
);
3959 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3960 while ('c' != *--chrs
)
3962 SCM_ASSERT (SCM_CONSP (arg1
),
3963 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3964 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3971 call_closure_1 (SCM proc
, SCM arg1
)
3973 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3976 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3981 scm_trampoline_1 (SCM proc
)
3987 switch (SCM_TYP7 (proc
))
3989 case scm_tc7_subr_1
:
3990 case scm_tc7_subr_1o
:
3991 return call_subr1_1
;
3992 case scm_tc7_subr_2o
:
3993 return call_subr2o_1
;
3995 return call_lsubr_1
;
3997 if (SCM_SUBRF (proc
))
3998 return call_dsubr_1
;
4001 case scm_tcs_closures
:
4003 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4004 if (!SCM_NULLP (formals
)
4005 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4006 return call_closure_1
;
4010 case scm_tcs_struct
:
4011 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4012 return scm_call_generic_1
;
4013 else if (!SCM_I_OPERATORP (proc
))
4017 if (SCM_SMOB_APPLICABLE_P (proc
))
4018 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4022 case scm_tc7_rpsubr
:
4027 return NULL
; /* not applicable on one arg */
4032 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4034 return SCM_SUBRF (proc
) (arg1
, arg2
);
4038 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4040 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4044 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4046 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4050 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4052 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4053 scm_list_2 (arg1
, arg2
),
4055 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4060 scm_trampoline_2 (SCM proc
)
4066 switch (SCM_TYP7 (proc
))
4068 case scm_tc7_subr_2
:
4069 case scm_tc7_subr_2o
:
4070 case scm_tc7_rpsubr
:
4072 return call_subr2_2
;
4073 case scm_tc7_lsubr_2
:
4074 return call_lsubr2_2
;
4076 return call_lsubr_2
;
4077 case scm_tcs_closures
:
4079 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4080 if (!SCM_NULLP (formals
)
4081 && (!SCM_CONSP (formals
)
4082 || (!SCM_NULLP (SCM_CDR (formals
))
4083 && (!SCM_CONSP (SCM_CDR (formals
))
4084 || !SCM_CONSP (SCM_CDDR (formals
))))))
4085 return call_closure_2
;
4089 case scm_tcs_struct
:
4090 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4091 return scm_call_generic_2
;
4092 else if (!SCM_I_OPERATORP (proc
))
4096 if (SCM_SMOB_APPLICABLE_P (proc
))
4097 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4104 return NULL
; /* not applicable on two args */
4108 /* Typechecking for multi-argument MAP and FOR-EACH.
4110 Verify that each element of the vector ARGV, except for the first,
4111 is a proper list whose length is LEN. Attribute errors to WHO,
4112 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4114 check_map_args (SCM argv
,
4121 SCM
const *ve
= SCM_VELTS (argv
);
4124 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4126 long elt_len
= scm_ilength (ve
[i
]);
4131 scm_apply_generic (gf
, scm_cons (proc
, args
));
4133 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4137 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4140 scm_remember_upto_here_1 (argv
);
4144 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4146 /* Note: Currently, scm_map applies PROC to the argument list(s)
4147 sequentially, starting with the first element(s). This is used in
4148 evalext.c where the Scheme procedure `map-in-order', which guarantees
4149 sequential behaviour, is implemented using scm_map. If the
4150 behaviour changes, we need to update `map-in-order'.
4154 scm_map (SCM proc
, SCM arg1
, SCM args
)
4155 #define FUNC_NAME s_map
4160 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4162 len
= scm_ilength (arg1
);
4163 SCM_GASSERTn (len
>= 0,
4164 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4165 SCM_VALIDATE_REST_ARGUMENT (args
);
4166 if (SCM_NULLP (args
))
4168 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4169 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4170 while (SCM_NIMP (arg1
))
4172 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4173 pres
= SCM_CDRLOC (*pres
);
4174 arg1
= SCM_CDR (arg1
);
4178 if (SCM_NULLP (SCM_CDR (args
)))
4180 SCM arg2
= SCM_CAR (args
);
4181 int len2
= scm_ilength (arg2
);
4182 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4184 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4185 SCM_GASSERTn (len2
>= 0,
4186 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4188 SCM_OUT_OF_RANGE (3, arg2
);
4189 while (SCM_NIMP (arg1
))
4191 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4192 pres
= SCM_CDRLOC (*pres
);
4193 arg1
= SCM_CDR (arg1
);
4194 arg2
= SCM_CDR (arg2
);
4198 arg1
= scm_cons (arg1
, args
);
4199 args
= scm_vector (arg1
);
4200 ve
= SCM_VELTS (args
);
4201 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4205 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4207 if (SCM_IMP (ve
[i
]))
4209 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4210 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4212 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4213 pres
= SCM_CDRLOC (*pres
);
4219 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4222 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4223 #define FUNC_NAME s_for_each
4225 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4227 len
= scm_ilength (arg1
);
4228 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4229 SCM_ARG2
, s_for_each
);
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_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4235 while (SCM_NIMP (arg1
))
4237 call (proc
, SCM_CAR (arg1
));
4238 arg1
= SCM_CDR (arg1
);
4240 return SCM_UNSPECIFIED
;
4242 if (SCM_NULLP (SCM_CDR (args
)))
4244 SCM arg2
= SCM_CAR (args
);
4245 int len2
= scm_ilength (arg2
);
4246 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4247 SCM_GASSERTn (call
, g_for_each
,
4248 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4249 SCM_GASSERTn (len2
>= 0, g_for_each
,
4250 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4252 SCM_OUT_OF_RANGE (3, arg2
);
4253 while (SCM_NIMP (arg1
))
4255 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4256 arg1
= SCM_CDR (arg1
);
4257 arg2
= SCM_CDR (arg2
);
4259 return SCM_UNSPECIFIED
;
4261 arg1
= scm_cons (arg1
, args
);
4262 args
= scm_vector (arg1
);
4263 ve
= SCM_VELTS (args
);
4264 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4268 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4270 if (SCM_IMP (ve
[i
]))
4271 return SCM_UNSPECIFIED
;
4272 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4273 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4275 scm_apply (proc
, arg1
, SCM_EOL
);
4282 scm_closure (SCM code
, SCM env
)
4285 SCM closcar
= scm_cons (code
, SCM_EOL
);
4286 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4287 scm_remember_upto_here (closcar
);
4292 scm_t_bits scm_tc16_promise
;
4295 scm_makprom (SCM code
)
4297 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4299 scm_make_rec_mutex ());
4303 promise_free (SCM promise
)
4305 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4310 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4312 int writingp
= SCM_WRITINGP (pstate
);
4313 scm_puts ("#<promise ", port
);
4314 SCM_SET_WRITINGP (pstate
, 1);
4315 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4316 SCM_SET_WRITINGP (pstate
, writingp
);
4317 scm_putc ('>', port
);
4321 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4323 "If the promise @var{x} has not been computed yet, compute and\n"
4324 "return @var{x}, otherwise just return the previously computed\n"
4326 #define FUNC_NAME s_scm_force
4328 SCM_VALIDATE_SMOB (1, promise
, promise
);
4329 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4330 if (!SCM_PROMISE_COMPUTED_P (promise
))
4332 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4333 if (!SCM_PROMISE_COMPUTED_P (promise
))
4335 SCM_SET_PROMISE_DATA (promise
, ans
);
4336 SCM_SET_PROMISE_COMPUTED (promise
);
4339 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4340 return SCM_PROMISE_DATA (promise
);
4345 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4347 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4348 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4349 #define FUNC_NAME s_scm_promise_p
4351 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4356 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4357 (SCM xorig
, SCM x
, SCM y
),
4358 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4359 "Any source properties associated with @var{xorig} are also associated\n"
4360 "with the new pair.")
4361 #define FUNC_NAME s_scm_cons_source
4364 z
= scm_cons (x
, y
);
4365 /* Copy source properties possibly associated with xorig. */
4366 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4368 scm_whash_insert (scm_source_whash
, z
, p
);
4374 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4376 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4377 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4378 "contents of both pairs and vectors (since both cons cells and vector\n"
4379 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4380 "any other object.")
4381 #define FUNC_NAME s_scm_copy_tree
4386 if (SCM_VECTORP (obj
))
4388 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4389 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4391 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4394 if (!SCM_CONSP (obj
))
4396 ans
= tl
= scm_cons_source (obj
,
4397 scm_copy_tree (SCM_CAR (obj
)),
4399 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4401 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4405 SCM_SETCDR (tl
, obj
);
4411 /* We have three levels of EVAL here:
4413 - scm_i_eval (exp, env)
4415 evaluates EXP in environment ENV. ENV is a lexical environment
4416 structure as used by the actual tree code evaluator. When ENV is
4417 a top-level environment, then changes to the current module are
4418 tracked by updating ENV so that it continues to be in sync with
4421 - scm_primitive_eval (exp)
4423 evaluates EXP in the top-level environment as determined by the
4424 current module. This is done by constructing a suitable
4425 environment and calling scm_i_eval. Thus, changes to the
4426 top-level module are tracked normally.
4428 - scm_eval (exp, mod)
4430 evaluates EXP while MOD is the current module. This is done by
4431 setting the current module to MOD, invoking scm_primitive_eval on
4432 EXP, and then restoring the current module to the value it had
4433 previously. That is, while EXP is evaluated, changes to the
4434 current module are tracked, but these changes do not persist when
4437 For each level of evals, there are two variants, distinguished by a
4438 _x suffix: the ordinary variant does not modify EXP while the _x
4439 variant can destructively modify EXP into something completely
4440 unintelligible. A Scheme data structure passed as EXP to one of the
4441 _x variants should not ever be used again for anything. So when in
4442 doubt, use the ordinary variant.
4447 scm_i_eval_x (SCM exp
, SCM env
)
4449 return SCM_XEVAL (exp
, env
);
4453 scm_i_eval (SCM exp
, SCM env
)
4455 exp
= scm_copy_tree (exp
);
4456 return SCM_XEVAL (exp
, env
);
4460 scm_primitive_eval_x (SCM exp
)
4463 SCM transformer
= scm_current_module_transformer ();
4464 if (SCM_NIMP (transformer
))
4465 exp
= scm_call_1 (transformer
, exp
);
4466 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4467 return scm_i_eval_x (exp
, env
);
4470 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4472 "Evaluate @var{exp} in the top-level environment specified by\n"
4473 "the current module.")
4474 #define FUNC_NAME s_scm_primitive_eval
4477 SCM transformer
= scm_current_module_transformer ();
4478 if (SCM_NIMP (transformer
))
4479 exp
= scm_call_1 (transformer
, exp
);
4480 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4481 return scm_i_eval (exp
, env
);
4485 /* Eval does not take the second arg optionally. This is intentional
4486 * in order to be R5RS compatible, and to prepare for the new module
4487 * system, where we would like to make the choice of evaluation
4488 * environment explicit. */
4491 change_environment (void *data
)
4493 SCM pair
= SCM_PACK (data
);
4494 SCM new_module
= SCM_CAR (pair
);
4495 SCM old_module
= scm_current_module ();
4496 SCM_SETCDR (pair
, old_module
);
4497 scm_set_current_module (new_module
);
4502 restore_environment (void *data
)
4504 SCM pair
= SCM_PACK (data
);
4505 SCM old_module
= SCM_CDR (pair
);
4506 SCM new_module
= scm_current_module ();
4507 SCM_SETCAR (pair
, new_module
);
4508 scm_set_current_module (old_module
);
4512 inner_eval_x (void *data
)
4514 return scm_primitive_eval_x (SCM_PACK(data
));
4518 scm_eval_x (SCM exp
, SCM module
)
4519 #define FUNC_NAME "eval!"
4521 SCM_VALIDATE_MODULE (2, module
);
4523 return scm_internal_dynamic_wind
4524 (change_environment
, inner_eval_x
, restore_environment
,
4525 (void *) SCM_UNPACK (exp
),
4526 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4531 inner_eval (void *data
)
4533 return scm_primitive_eval (SCM_PACK(data
));
4536 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4537 (SCM exp
, SCM module
),
4538 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4539 "in the top-level environment specified by @var{module}.\n"
4540 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4541 "@var{module} is made the current module. The current module\n"
4542 "is reset to its previous value when @var{eval} returns.")
4543 #define FUNC_NAME s_scm_eval
4545 SCM_VALIDATE_MODULE (2, module
);
4547 return scm_internal_dynamic_wind
4548 (change_environment
, inner_eval
, restore_environment
,
4549 (void *) SCM_UNPACK (exp
),
4550 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4555 /* At this point, scm_deval and scm_dapply are generated.
4565 scm_init_opts (scm_evaluator_traps
,
4566 scm_evaluator_trap_table
,
4567 SCM_N_EVALUATOR_TRAPS
);
4568 scm_init_opts (scm_eval_options_interface
,
4570 SCM_N_EVAL_OPTIONS
);
4572 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4573 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4574 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4575 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4577 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4578 SCM_SETCDR (undefineds
, undefineds
);
4579 scm_permanent_object (undefineds
);
4581 scm_listofnull
= scm_list_1 (SCM_EOL
);
4583 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4584 scm_permanent_object (f_apply
);
4586 #include "libguile/eval.x"
4588 scm_add_feature ("delay");