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_arrow
, "=>");
409 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
410 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
411 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
413 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
414 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
415 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
416 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
419 /* Check that the body denoted by XORIG is valid and rewrite it into
420 its internal form. The internal form of a body is just the body
421 itself, but prefixed with an ISYM that denotes to what kind of
422 outer construct this body belongs. A lambda body starts with
423 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
424 etc. The one exception is a body that belongs to a letrec that has
425 been formed by rewriting internal defines: it starts with
428 /* XXX - Besides controlling the rewriting of internal defines, the
429 additional ISYM could be used for improved error messages.
430 This is not done yet. */
433 scm_m_body (SCM op
, SCM xorig
, const char *what
)
435 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
437 /* Don't add another ISYM if one is present already. */
438 if (SCM_ISYMP (SCM_CAR (xorig
)))
441 /* Retain possible doc string. */
442 if (!SCM_CONSP (SCM_CAR (xorig
)))
444 if (!SCM_NULLP (SCM_CDR (xorig
)))
445 return scm_cons (SCM_CAR (xorig
),
446 scm_m_body (op
, SCM_CDR (xorig
), what
));
450 return scm_cons (op
, xorig
);
454 /* Start of the memoizers for the standard R5RS builtin macros. */
457 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
458 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
461 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
463 long len
= scm_ilength (SCM_CDR (xorig
));
464 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
466 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
472 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
473 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
476 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
478 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
479 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
483 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
484 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
487 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
490 SCM cdrx
= SCM_CDR (xorig
);
491 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
492 clauses
= SCM_CDR (cdrx
);
493 while (!SCM_NULLP (clauses
))
495 SCM clause
= SCM_CAR (clauses
);
496 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
497 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
498 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
499 && SCM_NULLP (SCM_CDR (clauses
))),
500 scm_s_clauses
, s_case
);
501 clauses
= SCM_CDR (clauses
);
503 return scm_cons (SCM_IM_CASE
, cdrx
);
507 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
508 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
511 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
513 SCM cdrx
= SCM_CDR (xorig
);
515 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
516 while (!SCM_NULLP (clauses
))
518 SCM clause
= SCM_CAR (clauses
);
519 long len
= scm_ilength (clause
);
520 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
521 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
523 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
524 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
526 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
528 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
529 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
531 clauses
= SCM_CDR (clauses
);
533 return scm_cons (SCM_IM_COND
, cdrx
);
537 SCM_SYNTAX(s_define
, "define", scm_i_makbimacro
, scm_m_define
);
538 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
540 /* Guile provides an extension to R5RS' define syntax to represent function
541 * currying in a compact way. With this extension, it is allowed to write
542 * (define <nested-variable> <body>), where <nested-variable> has of one of
543 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
544 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
545 * should be either a sequence of zero or more variables, or a sequence of one
546 * or more variables followed by a space-delimited period and another
547 * variable. Each level of argument nesting wraps the <body> within another
548 * lambda expression. For example, the following forms are allowed, each one
549 * followed by an equivalent, more explicit implementation.
551 * (define ((a b . c) . d) <body>) is equivalent to
552 * (define a (lambda (b . c) (lambda d <body>)))
554 * (define (((a) b) c . d) <body>) is equivalent to
555 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
557 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
558 * module that does not implement this extension. */
560 scm_m_define (SCM x
, SCM env
)
564 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
567 while (SCM_CONSP (name
))
569 /* This while loop realizes function currying by variable nesting. */
570 SCM formals
= SCM_CDR (name
);
571 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
572 name
= SCM_CAR (name
);
574 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
575 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
576 if (SCM_TOP_LEVEL (env
))
579 x
= scm_eval_car (x
, env
);
580 if (SCM_REC_PROCNAMES_P
)
583 while (SCM_MACROP (tmp
))
584 tmp
= SCM_MACRO_CODE (tmp
);
585 if (SCM_CLOSUREP (tmp
)
586 /* Only the first definition determines the name. */
587 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
588 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
590 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
591 SCM_VARIABLE_SET (var
, x
);
592 return SCM_UNSPECIFIED
;
595 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
599 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
600 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
602 /* Promises are implemented as closures with an empty parameter list. Thus,
603 * (delay <expression>) is transformed into (#@delay '() <expression>), where
604 * the empty list represents the empty parameter list. This representation
605 * allows for easy creation of the closure during evaluation. */
607 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
609 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
610 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
614 /* DO gets the most radically altered syntax. The order of the vars is
615 * reversed here. In contrast, the order of the inits and steps is reversed
616 * during the evaluation:
618 (do ((<var1> <init1> <step1>)
626 (#@do (<init1> <init2> ... <initn>)
630 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
633 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
634 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
637 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
640 SCM x
= SCM_CDR (xorig
);
643 SCM
*initloc
= &inits
;
645 SCM
*steploc
= &steps
;
646 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
647 bindings
= SCM_CAR (x
);
648 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
649 while (!SCM_NULLP (bindings
))
651 SCM binding
= SCM_CAR (bindings
);
652 long len
= scm_ilength (binding
);
653 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
655 SCM name
= SCM_CAR (binding
);
656 SCM init
= SCM_CADR (binding
);
657 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
658 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
659 vars
= scm_cons (name
, vars
);
660 *initloc
= scm_list_1 (init
);
661 initloc
= SCM_CDRLOC (*initloc
);
662 *steploc
= scm_list_1 (step
);
663 steploc
= SCM_CDRLOC (*steploc
);
664 bindings
= SCM_CDR (bindings
);
668 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
669 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
670 x
= scm_cons2 (inits
, vars
, x
);
671 return scm_cons (SCM_IM_DO
, x
);
675 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
676 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
679 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
681 long len
= scm_ilength (SCM_CDR (xorig
));
682 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
683 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
687 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
688 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
690 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
691 * cdr of the last cons. (Thus, LIST is not required to be a proper
692 * list and OBJ can also be found in the improper ending.) */
694 scm_c_improper_memq (SCM obj
, SCM list
)
696 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
698 if (SCM_EQ_P (SCM_CAR (list
), obj
))
701 return SCM_EQ_P (list
, obj
);
705 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
708 SCM x
= SCM_CDR (xorig
);
710 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
712 formals
= SCM_CAR (x
);
713 while (SCM_CONSP (formals
))
715 SCM formal
= SCM_CAR (formals
);
716 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
717 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
718 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
719 formals
= SCM_CDR (formals
);
721 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
722 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
724 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
725 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
729 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
730 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
731 * reversed here, the list of inits gets reversed during evaluation. */
733 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
739 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
743 SCM binding
= SCM_CAR (bindings
);
744 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
745 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
746 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
747 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
748 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
749 *initloc
= scm_list_1 (SCM_CADR (binding
));
750 initloc
= SCM_CDRLOC (*initloc
);
751 bindings
= SCM_CDR (bindings
);
753 while (!SCM_NULLP (bindings
));
759 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
760 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
763 scm_m_let (SCM xorig
, SCM env
)
765 SCM x
= SCM_CDR (xorig
);
768 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
771 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
773 /* null or single binding, let* is faster */
775 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
776 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
778 else if (SCM_CONSP (temp
))
782 SCM rvars
, inits
, body
;
783 transform_bindings (bindings
, &rvars
, &inits
, "let");
784 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
785 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
789 /* named let: Transform (let name ((var init) ...) body ...) into
790 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
796 SCM
*initloc
= &inits
;
799 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
801 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
802 bindings
= SCM_CAR (x
);
803 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
804 while (!SCM_NULLP (bindings
))
805 { /* vars and inits both in order */
806 SCM binding
= SCM_CAR (bindings
);
807 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
808 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
809 *varloc
= scm_list_1 (SCM_CAR (binding
));
810 varloc
= SCM_CDRLOC (*varloc
);
811 *initloc
= scm_list_1 (SCM_CADR (binding
));
812 initloc
= SCM_CDRLOC (*initloc
);
813 bindings
= SCM_CDR (bindings
);
817 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
818 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
819 SCM rvar
= scm_list_1 (name
);
820 SCM init
= scm_list_1 (lambda_form
);
821 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
822 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
823 return scm_cons (letrec
, inits
);
829 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
830 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
832 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
833 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
835 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
838 SCM x
= SCM_CDR (xorig
);
842 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
844 bindings
= SCM_CAR (x
);
845 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
846 while (!SCM_NULLP (bindings
))
848 SCM binding
= SCM_CAR (bindings
);
849 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
850 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
851 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
852 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
853 bindings
= SCM_CDR (bindings
);
856 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
857 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
861 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
862 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
865 scm_m_letrec (SCM xorig
, SCM env
)
867 SCM x
= SCM_CDR (xorig
);
868 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
870 if (SCM_NULLP (SCM_CAR (x
)))
872 /* null binding, let* faster */
873 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
874 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
878 SCM rvars
, inits
, body
;
879 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
880 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
881 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
886 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
887 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
890 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
892 long len
= scm_ilength (SCM_CDR (xorig
));
893 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
895 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
901 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
902 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
904 /* Internal function to handle a quasiquotation: 'form' is the parameter in
905 * the call (quasiquotation form), 'env' is the environment where unquoted
906 * expressions will be evaluated, and 'depth' is the current quasiquotation
907 * nesting level and is known to be greater than zero. */
909 iqq (SCM form
, SCM env
, unsigned long int depth
)
911 if (SCM_CONSP (form
))
913 SCM tmp
= SCM_CAR (form
);
914 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
916 SCM args
= SCM_CDR (form
);
917 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
918 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
920 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
922 SCM args
= SCM_CDR (form
);
923 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
925 return scm_eval_car (args
, env
);
927 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
929 else if (SCM_CONSP (tmp
)
930 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
932 SCM args
= SCM_CDR (tmp
);
933 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
936 SCM list
= scm_eval_car (args
, env
);
937 SCM rest
= SCM_CDR (form
);
938 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
939 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
942 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
943 iqq (SCM_CDR (form
), env
, depth
));
946 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
947 iqq (SCM_CDR (form
), env
, depth
));
949 else if (SCM_VECTORP (form
))
951 size_t i
= SCM_VECTOR_LENGTH (form
);
952 SCM
const *const data
= SCM_VELTS (form
);
955 tmp
= scm_cons (data
[--i
], tmp
);
956 scm_remember_upto_here_1 (form
);
957 return scm_vector (iqq (tmp
, env
, depth
));
964 scm_m_quasiquote (SCM xorig
, SCM env
)
966 SCM x
= SCM_CDR (xorig
);
967 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
968 return iqq (SCM_CAR (x
), env
, 1);
972 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
973 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
976 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
978 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
979 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
983 /* Will go into the RnRS module when Guile is factorized.
984 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
985 static const char s_set_x
[] = "set!";
986 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
989 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
991 SCM x
= SCM_CDR (xorig
);
992 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, s_set_x
);
993 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, s_set_x
);
994 return scm_cons (SCM_IM_SET_X
, x
);
998 /* Start of the memoizers for non-R5RS builtin macros. */
1001 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1002 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1003 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1006 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1008 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1009 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1013 /* (@bind ((var exp) ...) body ...)
1015 This will assign the values of the `exp's to the global variables
1016 named by `var's (symbols, not evaluated), creating them if they
1017 don't exist, executes body, and then restores the previous values of
1018 the `var's. Additionally, whenever control leaves body, the values
1019 of the `var's are saved and restored when control returns. It is an
1020 error when a symbol appears more than once among the `var's.
1021 All `exp's are evaluated before any `var' is set.
1023 Think of this as `let' for dynamic scope.
1025 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1027 XXX - also implement `@bind*'.
1030 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1033 scm_m_atbind (SCM xorig
, SCM env
)
1035 SCM x
= SCM_CDR (xorig
);
1036 SCM top_level
= scm_env_top_level (env
);
1037 SCM vars
= SCM_EOL
, var
;
1040 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1043 while (SCM_NIMP (x
))
1046 SCM sym_exp
= SCM_CAR (x
);
1047 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1048 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1050 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1051 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1052 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1053 /* The first call to scm_sym2var will look beyond the current
1054 module, while the second call wont. */
1055 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1056 if (SCM_FALSEP (var
))
1057 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1058 vars
= scm_cons (var
, vars
);
1059 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1061 return scm_cons (SCM_IM_BIND
,
1062 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1067 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1068 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1072 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1074 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1075 scm_s_expression
, s_atcall_cc
);
1076 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1080 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1081 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1084 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1086 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1087 scm_s_expression
, s_at_call_with_values
);
1088 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1093 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1095 /* Like promises, futures are implemented as closures with an empty
1096 * parameter list. Thus, (future <expression>) is transformed into
1097 * (#@future '() <expression>), where the empty list represents the
1098 * empty parameter list. This representation allows for easy creation
1099 * of the closure during evaluation. */
1101 scm_m_future (SCM xorig
, SCM env SCM_UNUSED
)
1103 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_future
);
1104 return scm_cons2 (SCM_IM_FUTURE
, SCM_EOL
, SCM_CDR (xorig
));
1108 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1109 SCM_SYMBOL (scm_sym_setter
, "setter");
1112 scm_m_generalized_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1114 SCM x
= SCM_CDR (xorig
);
1115 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, s_set_x
);
1116 if (SCM_SYMBOLP (SCM_CAR (x
)))
1117 return scm_cons (SCM_IM_SET_X
, x
);
1118 else if (SCM_CONSP (SCM_CAR (x
)))
1119 return scm_cons (scm_list_2 (scm_sym_setter
, SCM_CAAR (x
)),
1120 scm_append (scm_list_2 (SCM_CDAR (x
), SCM_CDR (x
))));
1122 scm_misc_error (s_set_x
, scm_s_variable
, SCM_EOL
);
1126 static const char* s_atslot_ref
= "@slot-ref";
1128 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1129 * soon as the module system allows us to more freely create bindings in
1130 * arbitrary modules during the startup phase, the code from goops.c should be
1133 scm_m_atslot_ref (SCM xorig
, SCM env SCM_UNUSED
)
1134 #define FUNC_NAME s_atslot_ref
1136 SCM x
= SCM_CDR (xorig
);
1137 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, FUNC_NAME
);
1138 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1139 return scm_cons (SCM_IM_SLOT_REF
, x
);
1144 static const char* s_atslot_set_x
= "@slot-set!";
1146 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1147 * soon as the module system allows us to more freely create bindings in
1148 * arbitrary modules during the startup phase, the code from goops.c should be
1151 scm_m_atslot_set_x (SCM xorig
, SCM env SCM_UNUSED
)
1152 #define FUNC_NAME s_atslot_set_x
1154 SCM x
= SCM_CDR (xorig
);
1155 SCM_ASSYNT (scm_ilength (x
) == 3, scm_s_expression
, FUNC_NAME
);
1156 SCM_VALIDATE_INUM (SCM_ARG2
, SCM_CADR (x
));
1157 return scm_cons (SCM_IM_SLOT_SET_X
, x
);
1162 #if SCM_ENABLE_ELISP
1164 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
1167 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1169 long len
= scm_ilength (SCM_CDR (xorig
));
1170 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1171 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1175 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
1178 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1180 SCM x
= SCM_CDR (xorig
), var
;
1181 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1182 var
= scm_symbol_fref (SCM_CAR (x
));
1183 /* Passing the symbol name as the `subr' arg here isn't really
1184 right, but without it it can be very difficult to work out from
1185 the error message which function definition was missing. In any
1186 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1187 something equivalent to (signal void-function (list SYM)) in
1189 SCM_ASSYNT (SCM_VARIABLEP (var
),
1190 "Symbol's function definition is void",
1191 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1192 /* Support `defalias'. */
1193 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1195 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1196 SCM_ASSYNT (SCM_VARIABLEP (var
),
1197 "Symbol's function definition is void",
1198 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1200 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1201 former allows for automatically picking up redefinitions of the
1202 corresponding symbol. */
1203 SCM_SETCAR (x
, var
);
1204 /* If the variable contains a procedure, leave the
1205 `transformer-macro' in place so that the procedure's arguments
1206 get properly transformed, and change the initial @fop to
1208 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1210 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1213 /* Otherwise (the variable contains a macro), the arguments should
1214 not be transformed, so cut the `transformer-macro' out and return
1215 the resulting expression starting with the variable. */
1216 SCM_SETCDR (x
, SCM_CDADR (x
));
1220 #endif /* SCM_ENABLE_ELISP */
1223 /* Start of the memoizers for deprecated macros. */
1226 #if (SCM_ENABLE_DEPRECATED == 1)
1228 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
1231 scm_m_undefine (SCM x
, SCM env
)
1235 SCM_ASSYNT (SCM_TOP_LEVEL (env
), "bad placement ", s_undefine
);
1236 SCM_ASSYNT (SCM_CONSP (x
) && SCM_NULLP (SCM_CDR (x
)),
1237 scm_s_expression
, s_undefine
);
1239 SCM_ASSYNT (SCM_SYMBOLP (x
), scm_s_variable
, s_undefine
);
1240 arg1
= scm_sym2var (x
, scm_env_top_level (env
), SCM_BOOL_F
);
1241 SCM_ASSYNT (!SCM_FALSEP (arg1
) && !SCM_UNBNDP (SCM_VARIABLE_REF (arg1
)),
1242 "variable already unbound ", s_undefine
);
1243 SCM_VARIABLE_SET (arg1
, SCM_UNDEFINED
);
1247 return SCM_UNSPECIFIED
;
1255 scm_m_expand_body (SCM xorig
, SCM env
)
1257 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1258 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1260 while (SCM_NIMP (x
))
1262 SCM form
= SCM_CAR (x
);
1263 if (!SCM_CONSP (form
))
1265 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1268 form
= scm_macroexp (scm_cons_source (form
,
1273 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1275 defs
= scm_cons (SCM_CDR (form
), defs
);
1278 else if (!SCM_IMP (defs
))
1282 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1284 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1288 x
= scm_cons (form
, SCM_CDR (x
));
1293 if (!SCM_NULLP (defs
))
1295 SCM rvars
, inits
, body
, letrec
;
1296 transform_bindings (defs
, &rvars
, &inits
, what
);
1297 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1298 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1299 SCM_SETCAR (xorig
, letrec
);
1300 SCM_SETCDR (xorig
, SCM_EOL
);
1304 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1305 SCM_SETCAR (xorig
, SCM_CAR (x
));
1306 SCM_SETCDR (xorig
, SCM_CDR (x
));
1313 scm_macroexp (SCM x
, SCM env
)
1315 SCM res
, proc
, orig_sym
;
1317 /* Don't bother to produce error messages here. We get them when we
1318 eventually execute the code for real. */
1321 orig_sym
= SCM_CAR (x
);
1322 if (!SCM_SYMBOLP (orig_sym
))
1326 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1327 if (proc_ptr
== NULL
)
1329 /* We have lost the race. */
1335 /* Only handle memoizing macros. `Acros' and `macros' are really
1336 special forms and should not be evaluated here. */
1338 if (!SCM_MACROP (proc
)
1339 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
1342 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1343 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1345 if (scm_ilength (res
) <= 0)
1346 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1349 SCM_SETCAR (x
, SCM_CAR (res
));
1350 SCM_SETCDR (x
, SCM_CDR (res
));
1356 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
1358 /* A function object to implement "apply" for non-closure functions. */
1360 /* An endless list consisting of #<undefined> objects: */
1361 static SCM undefineds
;
1363 /* scm_unmemocopy takes a memoized expression together with its
1364 * environment and rewrites it to its original form. Thus, it is the
1365 * inversion of the rewrite rules above. The procedure is not
1366 * optimized for speed. It's used in scm_iprin1 when printing the
1367 * code of a closure, in scm_procedure_source, in display_frame when
1368 * generating the source for a stackframe in a backtrace, and in
1369 * display_expression.
1371 * Unmemoizing is not a reliable process. You cannot in general
1372 * expect to get the original source back.
1374 * However, GOOPS currently relies on this for method compilation.
1375 * This ought to change.
1379 build_binding_list (SCM names
, SCM inits
)
1381 SCM bindings
= SCM_EOL
;
1382 while (!SCM_NULLP (names
))
1384 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1385 bindings
= scm_cons (binding
, bindings
);
1386 names
= SCM_CDR (names
);
1387 inits
= SCM_CDR (inits
);
1393 unmemocopy (SCM x
, SCM env
)
1399 p
= scm_whash_lookup (scm_source_whash
, x
);
1400 switch (SCM_ITAG7 (SCM_CAR (x
)))
1402 case SCM_BIT7 (SCM_IM_AND
):
1403 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1405 case SCM_BIT7 (SCM_IM_BEGIN
):
1406 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1408 case SCM_BIT7 (SCM_IM_CASE
):
1409 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1411 case SCM_BIT7 (SCM_IM_COND
):
1412 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1414 case SCM_BIT7 (SCM_IM_DO
):
1416 /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk),
1417 * where ix is an initializer for a local variable, nx is the name of
1418 * the local variable, test is the test clause of the do loop, body is
1419 * the body of the do loop and sx are the step clauses for the local
1421 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1424 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1426 names
= SCM_CAR (x
);
1427 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1429 test
= unmemocopy (SCM_CAR (x
), env
);
1431 memoized_body
= SCM_CAR (x
);
1433 steps
= scm_reverse (unmemocopy (x
, env
));
1435 /* build transformed binding list */
1437 while (!SCM_NULLP (names
))
1439 SCM name
= SCM_CAR (names
);
1440 SCM init
= SCM_CAR (inits
);
1441 SCM step
= SCM_CAR (steps
);
1442 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1444 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1446 names
= SCM_CDR (names
);
1447 inits
= SCM_CDR (inits
);
1448 steps
= SCM_CDR (steps
);
1450 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1451 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1453 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1456 case SCM_BIT7 (SCM_IM_IF
):
1457 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1459 case SCM_BIT7 (SCM_IM_LET
):
1461 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1462 * where nx is the name of a local variable, ix is an initializer for
1463 * the local variable and by are the body clauses. */
1464 SCM names
, inits
, bindings
;
1467 names
= SCM_CAR (x
);
1469 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1470 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1472 bindings
= build_binding_list (names
, inits
);
1473 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1474 ls
= scm_cons (scm_sym_let
, z
);
1477 case SCM_BIT7 (SCM_IM_LETREC
):
1479 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1480 * where nx is the name of a local variable, ix is an initializer for
1481 * the local variable and by are the body clauses. */
1482 SCM names
, inits
, bindings
;
1485 names
= SCM_CAR (x
);
1486 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
1488 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1490 bindings
= build_binding_list (names
, inits
);
1491 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1492 ls
= scm_cons (scm_sym_letrec
, z
);
1495 case SCM_BIT7 (SCM_IM_LETSTAR
):
1503 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1506 y
= z
= scm_acons (SCM_CAR (b
),
1508 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1510 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1514 SCM_SETCDR (y
, SCM_EOL
);
1515 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1516 ls
= scm_cons (scm_sym_let
, z
);
1521 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1523 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1526 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1529 while (SCM_NIMP (b
));
1530 SCM_SETCDR (z
, SCM_EOL
);
1532 z
= scm_cons (y
, SCM_UNSPECIFIED
);
1533 ls
= scm_cons (scm_sym_letstar
, z
);
1536 case SCM_BIT7 (SCM_IM_OR
):
1537 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1539 case SCM_BIT7 (SCM_IM_LAMBDA
):
1541 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1542 ls
= scm_cons (scm_sym_lambda
, z
);
1543 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1545 case SCM_BIT7 (SCM_IM_QUOTE
):
1546 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1548 case SCM_BIT7 (SCM_IM_SET_X
):
1549 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1551 case SCM_BIT7 (SCM_IM_DEFINE
):
1556 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1557 ls
= scm_cons (scm_sym_define
, z
);
1558 if (!SCM_NULLP (env
))
1559 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1564 case SCM_BIT7 (SCM_MAKISYM (0)):
1568 switch (SCM_ISYMNUM (z
))
1570 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1571 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1573 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1574 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1576 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1577 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1580 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
1581 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
1584 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1585 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1588 /* appease the Sun compiler god: */ ;
1592 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1598 while (SCM_CONSP (x
))
1600 SCM form
= SCM_CAR (x
);
1601 if (!SCM_ISYMP (form
))
1603 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1604 SCM_SETCDR (z
, unmemocar (copy
, env
));
1610 if (!SCM_FALSEP (p
))
1611 scm_whash_insert (scm_source_whash
, ls
, p
);
1617 scm_unmemocopy (SCM x
, SCM env
)
1619 if (!SCM_NULLP (env
))
1620 /* Make a copy of the lowest frame to protect it from
1621 modifications by SCM_IM_DEFINE */
1622 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1624 return unmemocopy (x
, env
);
1629 scm_badargsp (SCM formals
, SCM args
)
1631 while (!SCM_NULLP (formals
))
1633 if (!SCM_CONSP (formals
))
1635 if (SCM_NULLP (args
))
1637 formals
= SCM_CDR (formals
);
1638 args
= SCM_CDR (args
);
1640 return !SCM_NULLP (args
) ? 1 : 0;
1645 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1647 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1648 while (SCM_CONSP (l
))
1650 res
= EVALCAR (l
, env
);
1652 *lloc
= scm_list_1 (res
);
1653 lloc
= SCM_CDRLOC (*lloc
);
1657 scm_wrong_num_args (proc
);
1663 scm_eval_body (SCM code
, SCM env
)
1667 next
= SCM_CDR (code
);
1668 while (!SCM_NULLP (next
))
1670 if (SCM_IMP (SCM_CAR (code
)))
1672 if (SCM_ISYMP (SCM_CAR (code
)))
1674 scm_rec_mutex_lock (&source_mutex
);
1675 /* check for race condition */
1676 if (SCM_ISYMP (SCM_CAR (code
)))
1677 code
= scm_m_expand_body (code
, env
);
1678 scm_rec_mutex_unlock (&source_mutex
);
1683 SCM_XEVAL (SCM_CAR (code
), env
);
1685 next
= SCM_CDR (code
);
1687 return SCM_XEVALCAR (code
, env
);
1693 /* SECTION: This code is specific for the debugging support. One
1694 * branch is read when DEVAL isn't defined, the other when DEVAL is
1700 #define SCM_APPLY scm_apply
1701 #define PREP_APPLY(proc, args)
1703 #define RETURN(x) do { return x; } while (0)
1704 #ifdef STACK_CHECKING
1705 #ifndef NO_CEVAL_STACK_CHECKING
1706 #define EVAL_STACK_CHECKING
1713 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1715 #define SCM_APPLY scm_dapply
1717 #define PREP_APPLY(p, l) \
1718 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1720 #define ENTER_APPLY \
1722 SCM_SET_ARGSREADY (debug);\
1723 if (scm_check_apply_p && SCM_TRAPS_P)\
1724 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1726 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1727 SCM_SET_TRACED_FRAME (debug); \
1729 if (SCM_CHEAPTRAPS_P)\
1731 tmp = scm_make_debugobj (&debug);\
1732 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1737 tmp = scm_make_continuation (&first);\
1739 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1745 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1746 #ifdef STACK_CHECKING
1747 #ifndef EVAL_STACK_CHECKING
1748 #define EVAL_STACK_CHECKING
1752 /* scm_ceval_ptr points to the currently selected evaluator.
1753 * *fixme*: Although efficiency is important here, this state variable
1754 * should probably not be a global. It should be related to the
1759 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1761 /* scm_last_debug_frame contains a pointer to the last debugging
1762 * information stack frame. It is accessed very often from the
1763 * debugging evaluator, so it should probably not be indirectly
1764 * addressed. Better to save and restore it from the current root at
1768 /* scm_debug_eframe_size is the number of slots available for pseudo
1769 * stack frames at each real stack frame.
1772 long scm_debug_eframe_size
;
1774 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1776 long scm_eval_stack
;
1778 scm_t_option scm_eval_opts
[] = {
1779 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1782 scm_t_option scm_debug_opts
[] = {
1783 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1784 "*Flyweight representation of the stack at traps." },
1785 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1786 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1787 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1788 "Record procedure names at definition." },
1789 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1790 "Display backtrace in anti-chronological order." },
1791 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1792 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1793 { SCM_OPTION_INTEGER
, "frames", 3,
1794 "Maximum number of tail-recursive frames in backtrace." },
1795 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1796 "Maximal number of stored backtrace frames." },
1797 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1798 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1799 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1800 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1801 { 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."}
1804 scm_t_option scm_evaluator_trap_table
[] = {
1805 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1806 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1807 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1808 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1809 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1810 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1811 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1814 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1816 "Option interface for the evaluation options. Instead of using\n"
1817 "this procedure directly, use the procedures @code{eval-enable},\n"
1818 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1819 #define FUNC_NAME s_scm_eval_options_interface
1823 ans
= scm_options (setting
,
1827 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1834 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1836 "Option interface for the evaluator trap options.")
1837 #define FUNC_NAME s_scm_evaluator_traps
1841 ans
= scm_options (setting
,
1842 scm_evaluator_trap_table
,
1843 SCM_N_EVALUATOR_TRAPS
,
1845 SCM_RESET_DEBUG_MODE
;
1853 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1855 SCM
*results
= lloc
, res
;
1856 while (SCM_CONSP (l
))
1858 res
= EVALCAR (l
, env
);
1860 *lloc
= scm_list_1 (res
);
1861 lloc
= SCM_CDRLOC (*lloc
);
1865 scm_wrong_num_args (proc
);
1872 /* SECTION: This code is compiled twice.
1876 /* Update the toplevel environment frame ENV so that it refers to the
1877 * current module. */
1878 #define UPDATE_TOPLEVEL_ENV(env) \
1880 SCM p = scm_current_module_lookup_closure (); \
1881 if (p != SCM_CAR (env)) \
1882 env = scm_top_level_env (p); \
1886 /* This is the evaluator. Like any real monster, it has three heads:
1888 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1889 * version. Both are implemented using a common code base, using the
1890 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1891 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1892 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1893 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1894 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1895 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1896 * are enclosed within #ifdef DEVAL ... #endif.
1898 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1899 * take two input parameters, x and env: x is a single expression to be
1900 * evalutated. env is the environment in which bindings are searched.
1902 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1903 * is a single expression, it is necessarily in a tail position. If x is just
1904 * a call to another function like in the expression (foo exp1 exp2 ...), the
1905 * realization of that call therefore _must_not_ increase stack usage (the
1906 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1907 * making extensive use of 'goto' statements within the evaluator: The gotos
1908 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1909 * that SCM_CEVAL was already using. If, however, x represents some form that
1910 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1911 * then recursive calls to SCM_CEVAL are performed for all but the last
1912 * expression of that sequence. */
1916 scm_ceval (SCM x
, SCM env
)
1922 scm_deval (SCM x
, SCM env
)
1927 SCM_CEVAL (SCM x
, SCM env
)
1931 scm_t_debug_frame debug
;
1932 scm_t_debug_info
*debug_info_end
;
1933 debug
.prev
= scm_last_debug_frame
;
1936 * The debug.vect contains twice as much scm_t_debug_info frames as the
1937 * user has specified with (debug-set! frames <n>).
1939 * Even frames are eval frames, odd frames are apply frames.
1941 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1942 * sizeof (scm_t_debug_info
));
1943 debug
.info
= debug
.vect
;
1944 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1945 scm_last_debug_frame
= &debug
;
1947 #ifdef EVAL_STACK_CHECKING
1948 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
1951 debug
.info
->e
.exp
= x
;
1952 debug
.info
->e
.env
= env
;
1954 scm_report_stack_overflow ();
1964 SCM_CLEAR_ARGSREADY (debug
);
1965 if (SCM_OVERFLOWP (debug
))
1968 * In theory, this should be the only place where it is necessary to
1969 * check for space in debug.vect since both eval frames and
1970 * available space are even.
1972 * For this to be the case, however, it is necessary that primitive
1973 * special forms which jump back to `loop', `begin' or some similar
1974 * label call PREP_APPLY.
1976 else if (++debug
.info
>= debug_info_end
)
1978 SCM_SET_OVERFLOW (debug
);
1983 debug
.info
->e
.exp
= x
;
1984 debug
.info
->e
.env
= env
;
1985 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1987 if (SCM_ENTER_FRAME_P
1988 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1991 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1992 SCM_SET_TAILREC (debug
);
1993 if (SCM_CHEAPTRAPS_P
)
1994 stackrep
= scm_make_debugobj (&debug
);
1998 SCM val
= scm_make_continuation (&first
);
2008 /* This gives the possibility for the debugger to
2009 modify the source expression before evaluation. */
2014 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2015 scm_sym_enter_frame
,
2018 scm_unmemocopy (x
, env
));
2025 switch (SCM_TYP7 (x
))
2027 case scm_tc7_symbol
:
2028 /* Only happens when called at top level. */
2029 x
= scm_cons (x
, SCM_UNDEFINED
);
2030 RETURN (*scm_lookupcar (x
, env
, 1));
2032 case SCM_BIT7 (SCM_IM_AND
):
2034 while (!SCM_NULLP (SCM_CDR (x
)))
2036 SCM test_result
= EVALCAR (x
, env
);
2037 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2038 RETURN (SCM_BOOL_F
);
2042 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2045 case SCM_BIT7 (SCM_IM_BEGIN
):
2048 RETURN (SCM_UNSPECIFIED
);
2050 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2053 /* If we are on toplevel with a lookup closure, we need to sync
2054 with the current module. */
2055 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2057 UPDATE_TOPLEVEL_ENV (env
);
2058 while (!SCM_NULLP (SCM_CDR (x
)))
2061 UPDATE_TOPLEVEL_ENV (env
);
2067 goto nontoplevel_begin
;
2070 while (!SCM_NULLP (SCM_CDR (x
)))
2072 SCM form
= SCM_CAR (x
);
2075 if (SCM_ISYMP (form
))
2077 scm_rec_mutex_lock (&source_mutex
);
2078 /* check for race condition */
2079 if (SCM_ISYMP (SCM_CAR (x
)))
2080 x
= scm_m_expand_body (x
, env
);
2081 scm_rec_mutex_unlock (&source_mutex
);
2082 goto nontoplevel_begin
;
2085 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2088 SCM_CEVAL (form
, env
);
2094 /* scm_eval last form in list */
2095 SCM last_form
= SCM_CAR (x
);
2097 if (SCM_CONSP (last_form
))
2099 /* This is by far the most frequent case. */
2101 goto loop
; /* tail recurse */
2103 else if (SCM_IMP (last_form
))
2104 RETURN (SCM_EVALIM (last_form
, env
));
2105 else if (SCM_VARIABLEP (last_form
))
2106 RETURN (SCM_VARIABLE_REF (last_form
));
2107 else if (SCM_SYMBOLP (last_form
))
2108 RETURN (*scm_lookupcar (x
, env
, 1));
2114 case SCM_BIT7 (SCM_IM_CASE
):
2117 SCM key
= EVALCAR (x
, env
);
2119 while (!SCM_NULLP (x
))
2121 SCM clause
= SCM_CAR (x
);
2122 SCM labels
= SCM_CAR (clause
);
2123 if (SCM_EQ_P (labels
, scm_sym_else
))
2125 x
= SCM_CDR (clause
);
2126 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2129 while (!SCM_NULLP (labels
))
2131 SCM label
= SCM_CAR (labels
);
2132 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2134 x
= SCM_CDR (clause
);
2135 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2138 labels
= SCM_CDR (labels
);
2143 RETURN (SCM_UNSPECIFIED
);
2146 case SCM_BIT7 (SCM_IM_COND
):
2148 while (!SCM_NULLP (x
))
2150 SCM clause
= SCM_CAR (x
);
2151 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2153 x
= SCM_CDR (clause
);
2154 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2159 arg1
= EVALCAR (clause
, env
);
2160 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2162 x
= SCM_CDR (clause
);
2165 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2167 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2173 proc
= EVALCAR (proc
, env
);
2174 PREP_APPLY (proc
, scm_list_1 (arg1
));
2182 RETURN (SCM_UNSPECIFIED
);
2185 case SCM_BIT7 (SCM_IM_DO
):
2188 /* Compute the initialization values and the initial environment. */
2189 SCM init_forms
= SCM_CAR (x
);
2190 SCM init_values
= SCM_EOL
;
2191 while (!SCM_NULLP (init_forms
))
2193 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2194 init_forms
= SCM_CDR (init_forms
);
2197 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2201 SCM test_form
= SCM_CAR (x
);
2202 SCM body_forms
= SCM_CADR (x
);
2203 SCM step_forms
= SCM_CDDR (x
);
2205 SCM test_result
= EVALCAR (test_form
, env
);
2207 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2210 /* Evaluate body forms. */
2212 for (temp_forms
= body_forms
;
2213 !SCM_NULLP (temp_forms
);
2214 temp_forms
= SCM_CDR (temp_forms
))
2216 SCM form
= SCM_CAR (temp_forms
);
2217 /* Dirk:FIXME: We only need to eval forms, that may have a
2218 * side effect here. This is only true for forms that start
2219 * with a pair. All others are just constants. However,
2220 * since in the common case there is no constant expression
2221 * in a body of a do form, we just check for immediates here
2222 * and have SCM_CEVAL take care of other cases. In the long
2223 * run it would make sense to get rid of this test and have
2224 * the macro transformer of 'do' eliminate all forms that
2225 * have no sideeffect. */
2226 if (!SCM_IMP (form
))
2227 SCM_CEVAL (form
, env
);
2232 /* Evaluate the step expressions. */
2234 SCM step_values
= SCM_EOL
;
2235 for (temp_forms
= step_forms
;
2236 !SCM_NULLP (temp_forms
);
2237 temp_forms
= SCM_CDR (temp_forms
))
2239 SCM value
= EVALCAR (temp_forms
, env
);
2240 step_values
= scm_cons (value
, step_values
);
2242 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
2247 test_result
= EVALCAR (test_form
, env
);
2252 RETURN (SCM_UNSPECIFIED
);
2253 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2254 goto nontoplevel_begin
;
2257 case SCM_BIT7 (SCM_IM_IF
):
2260 SCM test_result
= EVALCAR (x
, env
);
2261 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2267 RETURN (SCM_UNSPECIFIED
);
2270 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2274 case SCM_BIT7 (SCM_IM_LET
):
2277 SCM init_forms
= SCM_CADR (x
);
2278 SCM init_values
= SCM_EOL
;
2281 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2282 init_forms
= SCM_CDR (init_forms
);
2284 while (!SCM_NULLP (init_forms
));
2285 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2288 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2289 goto nontoplevel_begin
;
2292 case SCM_BIT7 (SCM_IM_LETREC
):
2294 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
2297 SCM init_forms
= SCM_CAR (x
);
2298 SCM init_values
= SCM_EOL
;
2301 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2302 init_forms
= SCM_CDR (init_forms
);
2304 while (!SCM_NULLP (init_forms
));
2305 SCM_SETCDR (SCM_CAR (env
), init_values
);
2308 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2309 goto nontoplevel_begin
;
2312 case SCM_BIT7 (SCM_IM_LETSTAR
):
2315 SCM bindings
= SCM_CAR (x
);
2316 if (SCM_NULLP (bindings
))
2317 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2322 SCM name
= SCM_CAR (bindings
);
2323 SCM init
= SCM_CDR (bindings
);
2324 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2325 bindings
= SCM_CDR (init
);
2327 while (!SCM_NULLP (bindings
));
2331 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2332 goto nontoplevel_begin
;
2335 case SCM_BIT7 (SCM_IM_OR
):
2337 while (!SCM_NULLP (SCM_CDR (x
)))
2339 SCM val
= EVALCAR (x
, env
);
2340 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2345 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2349 case SCM_BIT7 (SCM_IM_LAMBDA
):
2350 RETURN (scm_closure (SCM_CDR (x
), env
));
2353 case SCM_BIT7 (SCM_IM_QUOTE
):
2354 RETURN (SCM_CADR (x
));
2357 case SCM_BIT7 (SCM_IM_SET_X
):
2361 SCM variable
= SCM_CAR (x
);
2362 if (SCM_ILOCP (variable
))
2363 location
= scm_ilookup (variable
, env
);
2364 else if (SCM_VARIABLEP (variable
))
2365 location
= SCM_VARIABLE_LOC (variable
);
2366 else /* (SCM_SYMBOLP (variable)) is known to be true */
2367 location
= scm_lookupcar (x
, env
, 1);
2369 *location
= EVALCAR (x
, env
);
2371 RETURN (SCM_UNSPECIFIED
);
2374 case SCM_BIT7 (SCM_IM_DEFINE
): /* only for internal defines */
2375 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2378 /* new syntactic forms go here. */
2379 case SCM_BIT7 (SCM_MAKISYM (0)):
2381 switch (SCM_ISYMNUM (proc
))
2385 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2387 proc
= EVALCAR (x
, env
);
2388 PREP_APPLY (proc
, SCM_EOL
);
2390 arg1
= EVALCAR (x
, env
);
2393 /* Go here to tail-apply a procedure. PROC is the procedure and
2394 * ARG1 is the list of arguments. PREP_APPLY must have been called
2395 * before jumping to apply_proc. */
2396 if (SCM_CLOSUREP (proc
))
2398 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2400 debug
.info
->a
.args
= arg1
;
2402 if (scm_badargsp (formals
, arg1
))
2403 scm_wrong_num_args (proc
);
2405 /* Copy argument list */
2406 if (SCM_NULL_OR_NIL_P (arg1
))
2407 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2410 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2412 arg1
= SCM_CDR (arg1
);
2413 while (!SCM_NULL_OR_NIL_P (arg1
))
2415 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2416 SCM_SETCDR (tail
, new_tail
);
2418 arg1
= SCM_CDR (arg1
);
2420 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2423 x
= SCM_CLOSURE_BODY (proc
);
2424 goto nontoplevel_begin
;
2429 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
2433 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2436 SCM val
= scm_make_continuation (&first
);
2444 proc
= scm_eval_car (proc
, env
);
2445 PREP_APPLY (proc
, scm_list_1 (arg1
));
2452 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2453 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2456 case (SCM_ISYMNUM (SCM_IM_FUTURE
)):
2457 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
2460 /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The
2461 following code (type_dispatch) is intended to be the tail
2462 of the case clause for the internal macro
2463 SCM_IM_DISPATCH. Please don't remove it from this
2464 location without discussing it with Mikael
2465 <djurfeldt@nada.kth.se> */
2467 /* The type dispatch code is duplicated below
2468 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2469 * cuts down execution time for type dispatch to 50%. */
2470 type_dispatch
: /* inputs: x, arg1 */
2471 /* Type dispatch means to determine from the types of the function
2472 * arguments (i. e. the 'signature' of the call), which method from
2473 * a generic function is to be called. This process of selecting
2474 * the right method takes some time. To speed it up, guile uses
2475 * caching: Together with the macro call to dispatch the signatures
2476 * of some previous calls to that generic function from the same
2477 * place are stored (in the code!) in a cache that we call the
2478 * 'method cache'. This is done since it is likely, that
2479 * consecutive calls to dispatch from that position in the code will
2480 * have the same signature. Thus, the type dispatch works as
2481 * follows: First, determine a hash value from the signature of the
2482 * actual arguments. Second, use this hash value as an index to
2483 * find that same signature in the method cache stored at this
2484 * position in the code. If found, you have also found the
2485 * corresponding method that belongs to that signature. If the
2486 * signature is not found in the method cache, you have to perform a
2487 * full search over all signatures stored with the generic
2490 unsigned long int specializers
;
2491 unsigned long int hash_value
;
2492 unsigned long int cache_end_pos
;
2493 unsigned long int mask
;
2497 SCM z
= SCM_CDDR (x
);
2498 SCM tmp
= SCM_CADR (z
);
2499 specializers
= SCM_INUM (SCM_CAR (z
));
2501 /* Compute a hash value for searching the method cache. There
2502 * are two variants for computing the hash value, a (rather)
2503 * complicated one, and a simple one. For the complicated one
2504 * explained below, tmp holds a number that is used in the
2506 if (SCM_INUMP (tmp
))
2508 /* Use the signature of the actual arguments to determine
2509 * the hash value. This is done as follows: Each class has
2510 * an array of random numbers, that are determined when the
2511 * class is created. The integer 'hashset' is an index into
2512 * that array of random numbers. Now, from all classes that
2513 * are part of the signature of the actual arguments, the
2514 * random numbers at index 'hashset' are taken and summed
2515 * up, giving the hash value. The value of 'hashset' is
2516 * stored at the call to dispatch. This allows to have
2517 * different 'formulas' for calculating the hash value at
2518 * different places where dispatch is called. This allows
2519 * to optimize the hash formula at every individual place
2520 * where dispatch is called, such that hopefully the hash
2521 * value that is computed will directly point to the right
2522 * method in the method cache. */
2523 unsigned long int hashset
= SCM_INUM (tmp
);
2524 unsigned long int counter
= specializers
+ 1;
2527 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2529 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2530 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2531 tmp_arg
= SCM_CDR (tmp_arg
);
2535 method_cache
= SCM_CADR (z
);
2536 mask
= SCM_INUM (SCM_CAR (z
));
2538 cache_end_pos
= hash_value
;
2542 /* This method of determining the hash value is much
2543 * simpler: Set the hash value to zero and just perform a
2544 * linear search through the method cache. */
2546 mask
= (unsigned long int) ((long) -1);
2548 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2553 /* Search the method cache for a method with a matching
2554 * signature. Start the search at position 'hash_value'. The
2555 * hashing implementation uses linear probing for conflict
2556 * resolution, that is, if the signature in question is not
2557 * found at the starting index in the hash table, the next table
2558 * entry is tried, and so on, until in the worst case the whole
2559 * cache has been searched, but still the signature has not been
2564 SCM args
= arg1
; /* list of arguments */
2565 z
= SCM_VELTS (method_cache
)[hash_value
];
2566 while (!SCM_NULLP (args
))
2568 /* More arguments than specifiers => CLASS != ENV */
2569 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2570 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2572 args
= SCM_CDR (args
);
2575 /* Fewer arguments than specifiers => CAR != ENV */
2576 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2579 hash_value
= (hash_value
+ 1) & mask
;
2580 } while (hash_value
!= cache_end_pos
);
2582 /* No appropriate method was found in the cache. */
2583 z
= scm_memoize_method (x
, arg1
);
2585 apply_cmethod
: /* inputs: z, arg1 */
2587 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2588 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2589 x
= SCM_CMETHOD_BODY (z
);
2590 goto nontoplevel_begin
;
2596 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2599 SCM instance
= EVALCAR (x
, env
);
2600 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2601 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2605 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2608 SCM instance
= EVALCAR (x
, env
);
2609 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2610 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2611 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2612 RETURN (SCM_UNSPECIFIED
);
2616 #if SCM_ENABLE_ELISP
2618 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2620 SCM test_form
= SCM_CDR (x
);
2621 x
= SCM_CDR (test_form
);
2622 while (!SCM_NULL_OR_NIL_P (x
))
2624 SCM test_result
= EVALCAR (test_form
, env
);
2625 if (!(SCM_FALSEP (test_result
)
2626 || SCM_NULL_OR_NIL_P (test_result
)))
2628 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2629 RETURN (test_result
);
2630 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2635 test_form
= SCM_CDR (x
);
2636 x
= SCM_CDR (test_form
);
2640 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2644 #endif /* SCM_ENABLE_ELISP */
2646 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2648 SCM vars
, exps
, vals
;
2651 vars
= SCM_CAAR (x
);
2652 exps
= SCM_CDAR (x
);
2656 while (SCM_NIMP (exps
))
2658 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2659 exps
= SCM_CDR (exps
);
2662 scm_swap_bindings (vars
, vals
);
2663 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2665 /* Ignore all but the last evaluation result. */
2666 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2668 if (SCM_CONSP (SCM_CAR (x
)))
2669 SCM_CEVAL (SCM_CAR (x
), env
);
2671 proc
= EVALCAR (x
, env
);
2673 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2674 scm_swap_bindings (vars
, vals
);
2680 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2685 producer
= EVALCAR (x
, env
);
2687 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
2688 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
2689 if (SCM_VALUESP (arg1
))
2690 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2692 arg1
= scm_list_1 (arg1
);
2693 PREP_APPLY (proc
, arg1
);
2705 case scm_tc7_vector
:
2709 case scm_tc7_byvect
:
2716 #if SCM_SIZEOF_LONG_LONG != 0
2717 case scm_tc7_llvect
:
2720 case scm_tc7_string
:
2722 case scm_tcs_closures
:
2726 case scm_tcs_struct
:
2729 case scm_tc7_variable
:
2730 RETURN (SCM_VARIABLE_REF(x
));
2732 case SCM_BIT7 (SCM_ILOC00
):
2733 proc
= *scm_ilookup (SCM_CAR (x
), env
);
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. */
2750 if (SCM_MACROP (proc
))
2752 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2754 handle_a_macro
: /* inputs: x, env, proc */
2756 /* Set a flag during macro expansion so that macro
2757 application frames can be deleted from the backtrace. */
2758 SCM_SET_MACROEXP (debug
);
2760 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2761 scm_cons (env
, scm_listofnull
));
2764 SCM_CLEAR_MACROEXP (debug
);
2766 switch (SCM_MACRO_TYPE (proc
))
2770 if (scm_ilength (arg1
) <= 0)
2771 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2773 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2776 SCM_SETCAR (x
, SCM_CAR (arg1
));
2777 SCM_SETCDR (x
, SCM_CDR (arg1
));
2781 /* Prevent memoizing of debug info expression. */
2782 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2787 SCM_SETCAR (x
, SCM_CAR (arg1
));
2788 SCM_SETCDR (x
, SCM_CDR (arg1
));
2790 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2792 #if SCM_ENABLE_DEPRECATED == 1
2797 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2809 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2812 if (SCM_MACROP (proc
))
2813 goto handle_a_macro
;
2817 evapply
: /* inputs: x, proc */
2818 PREP_APPLY (proc
, SCM_EOL
);
2819 if (SCM_NULLP (SCM_CDR (x
))) {
2822 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2823 switch (SCM_TYP7 (proc
))
2824 { /* no arguments given */
2825 case scm_tc7_subr_0
:
2826 RETURN (SCM_SUBRF (proc
) ());
2827 case scm_tc7_subr_1o
:
2828 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2830 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2831 case scm_tc7_rpsubr
:
2832 RETURN (SCM_BOOL_T
);
2834 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2836 if (!SCM_SMOB_APPLICABLE_P (proc
))
2838 RETURN (SCM_SMOB_APPLY_0 (proc
));
2841 proc
= SCM_CCLO_SUBR (proc
);
2843 debug
.info
->a
.proc
= proc
;
2844 debug
.info
->a
.args
= scm_list_1 (arg1
);
2848 proc
= SCM_PROCEDURE (proc
);
2850 debug
.info
->a
.proc
= proc
;
2852 if (!SCM_CLOSUREP (proc
))
2855 case scm_tcs_closures
:
2857 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2858 if (SCM_CONSP (formals
))
2859 goto umwrongnumargs
;
2860 x
= SCM_CLOSURE_BODY (proc
);
2861 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2862 goto nontoplevel_begin
;
2864 case scm_tcs_struct
:
2865 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2867 x
= SCM_ENTITY_PROCEDURE (proc
);
2871 else if (SCM_I_OPERATORP (proc
))
2874 proc
= (SCM_I_ENTITYP (proc
)
2875 ? SCM_ENTITY_PROCEDURE (proc
)
2876 : SCM_OPERATOR_PROCEDURE (proc
));
2878 debug
.info
->a
.proc
= proc
;
2879 debug
.info
->a
.args
= scm_list_1 (arg1
);
2885 case scm_tc7_subr_1
:
2886 case scm_tc7_subr_2
:
2887 case scm_tc7_subr_2o
:
2890 case scm_tc7_subr_3
:
2891 case scm_tc7_lsubr_2
:
2894 scm_wrong_num_args (proc
);
2897 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2901 /* must handle macros by here */
2904 arg1
= EVALCAR (x
, env
);
2906 scm_wrong_num_args (proc
);
2908 debug
.info
->a
.args
= scm_list_1 (arg1
);
2916 evap1
: /* inputs: proc, arg1 */
2917 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2918 switch (SCM_TYP7 (proc
))
2919 { /* have one argument in arg1 */
2920 case scm_tc7_subr_2o
:
2921 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2922 case scm_tc7_subr_1
:
2923 case scm_tc7_subr_1o
:
2924 RETURN (SCM_SUBRF (proc
) (arg1
));
2926 if (SCM_INUMP (arg1
))
2928 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2930 else if (SCM_REALP (arg1
))
2932 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2934 else if (SCM_BIGP (arg1
))
2936 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2938 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2939 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2942 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
2945 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
2946 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2947 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2952 case scm_tc7_rpsubr
:
2953 RETURN (SCM_BOOL_T
);
2955 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2958 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2960 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2963 if (!SCM_SMOB_APPLICABLE_P (proc
))
2965 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2969 proc
= SCM_CCLO_SUBR (proc
);
2971 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2972 debug
.info
->a
.proc
= proc
;
2976 proc
= SCM_PROCEDURE (proc
);
2978 debug
.info
->a
.proc
= proc
;
2980 if (!SCM_CLOSUREP (proc
))
2983 case scm_tcs_closures
:
2986 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2987 if (SCM_NULLP (formals
)
2988 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
2989 goto umwrongnumargs
;
2990 x
= SCM_CLOSURE_BODY (proc
);
2992 env
= SCM_EXTEND_ENV (formals
,
2996 env
= SCM_EXTEND_ENV (formals
,
3000 goto nontoplevel_begin
;
3002 case scm_tcs_struct
:
3003 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3005 x
= SCM_ENTITY_PROCEDURE (proc
);
3007 arg1
= debug
.info
->a
.args
;
3009 arg1
= scm_list_1 (arg1
);
3013 else if (SCM_I_OPERATORP (proc
))
3017 proc
= (SCM_I_ENTITYP (proc
)
3018 ? SCM_ENTITY_PROCEDURE (proc
)
3019 : SCM_OPERATOR_PROCEDURE (proc
));
3021 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3022 debug
.info
->a
.proc
= proc
;
3028 case scm_tc7_subr_2
:
3029 case scm_tc7_subr_0
:
3030 case scm_tc7_subr_3
:
3031 case scm_tc7_lsubr_2
:
3032 scm_wrong_num_args (proc
);
3038 arg2
= EVALCAR (x
, env
);
3040 scm_wrong_num_args (proc
);
3042 { /* have two or more arguments */
3044 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3047 if (SCM_NULLP (x
)) {
3050 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3051 switch (SCM_TYP7 (proc
))
3052 { /* have two arguments */
3053 case scm_tc7_subr_2
:
3054 case scm_tc7_subr_2o
:
3055 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3058 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3060 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3062 case scm_tc7_lsubr_2
:
3063 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3064 case scm_tc7_rpsubr
:
3066 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3068 if (!SCM_SMOB_APPLICABLE_P (proc
))
3070 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3074 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3075 scm_cons (proc
, debug
.info
->a
.args
),
3078 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3079 scm_cons2 (proc
, arg1
,
3086 case scm_tcs_struct
:
3087 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3089 x
= SCM_ENTITY_PROCEDURE (proc
);
3091 arg1
= debug
.info
->a
.args
;
3093 arg1
= scm_list_2 (arg1
, arg2
);
3097 else if (SCM_I_OPERATORP (proc
))
3101 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3102 ? SCM_ENTITY_PROCEDURE (proc
)
3103 : SCM_OPERATOR_PROCEDURE (proc
),
3104 scm_cons (proc
, debug
.info
->a
.args
),
3107 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3108 ? SCM_ENTITY_PROCEDURE (proc
)
3109 : SCM_OPERATOR_PROCEDURE (proc
),
3110 scm_cons2 (proc
, arg1
,
3120 case scm_tc7_subr_0
:
3123 case scm_tc7_subr_1o
:
3124 case scm_tc7_subr_1
:
3125 case scm_tc7_subr_3
:
3126 scm_wrong_num_args (proc
);
3130 proc
= SCM_PROCEDURE (proc
);
3132 debug
.info
->a
.proc
= proc
;
3134 if (!SCM_CLOSUREP (proc
))
3137 case scm_tcs_closures
:
3140 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3141 if (SCM_NULLP (formals
)
3142 || (SCM_CONSP (formals
)
3143 && (SCM_NULLP (SCM_CDR (formals
))
3144 || (SCM_CONSP (SCM_CDR (formals
))
3145 && SCM_CONSP (SCM_CDDR (formals
))))))
3146 goto umwrongnumargs
;
3148 env
= SCM_EXTEND_ENV (formals
,
3152 env
= SCM_EXTEND_ENV (formals
,
3153 scm_list_2 (arg1
, arg2
),
3156 x
= SCM_CLOSURE_BODY (proc
);
3157 goto nontoplevel_begin
;
3162 scm_wrong_num_args (proc
);
3164 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3165 deval_args (x
, env
, proc
,
3166 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3170 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3171 switch (SCM_TYP7 (proc
))
3172 { /* have 3 or more arguments */
3174 case scm_tc7_subr_3
:
3175 if (!SCM_NULLP (SCM_CDR (x
)))
3176 scm_wrong_num_args (proc
);
3178 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3179 SCM_CADDR (debug
.info
->a
.args
)));
3181 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3182 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3185 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3186 arg2
= SCM_CDR (arg2
);
3188 while (SCM_NIMP (arg2
));
3190 case scm_tc7_rpsubr
:
3191 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3192 RETURN (SCM_BOOL_F
);
3193 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3196 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3197 RETURN (SCM_BOOL_F
);
3198 arg2
= SCM_CAR (arg1
);
3199 arg1
= SCM_CDR (arg1
);
3201 while (SCM_NIMP (arg1
));
3202 RETURN (SCM_BOOL_T
);
3203 case scm_tc7_lsubr_2
:
3204 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3205 SCM_CDDR (debug
.info
->a
.args
)));
3207 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3209 if (!SCM_SMOB_APPLICABLE_P (proc
))
3211 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3212 SCM_CDDR (debug
.info
->a
.args
)));
3216 proc
= SCM_PROCEDURE (proc
);
3217 debug
.info
->a
.proc
= proc
;
3218 if (!SCM_CLOSUREP (proc
))
3221 case scm_tcs_closures
:
3223 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3224 if (SCM_NULLP (formals
)
3225 || (SCM_CONSP (formals
)
3226 && (SCM_NULLP (SCM_CDR (formals
))
3227 || (SCM_CONSP (SCM_CDR (formals
))
3228 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3229 goto umwrongnumargs
;
3230 SCM_SET_ARGSREADY (debug
);
3231 env
= SCM_EXTEND_ENV (formals
,
3234 x
= SCM_CLOSURE_BODY (proc
);
3235 goto nontoplevel_begin
;
3238 case scm_tc7_subr_3
:
3239 if (!SCM_NULLP (SCM_CDR (x
)))
3240 scm_wrong_num_args (proc
);
3242 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3244 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3247 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3250 while (SCM_NIMP (x
));
3252 case scm_tc7_rpsubr
:
3253 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3254 RETURN (SCM_BOOL_F
);
3257 arg1
= EVALCAR (x
, env
);
3258 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3259 RETURN (SCM_BOOL_F
);
3263 while (SCM_NIMP (x
));
3264 RETURN (SCM_BOOL_T
);
3265 case scm_tc7_lsubr_2
:
3266 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3268 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3270 scm_eval_args (x
, env
, proc
))));
3272 if (!SCM_SMOB_APPLICABLE_P (proc
))
3274 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3275 scm_eval_args (x
, env
, proc
)));
3279 proc
= SCM_PROCEDURE (proc
);
3280 if (!SCM_CLOSUREP (proc
))
3283 case scm_tcs_closures
:
3285 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3286 if (SCM_NULLP (formals
)
3287 || (SCM_CONSP (formals
)
3288 && (SCM_NULLP (SCM_CDR (formals
))
3289 || (SCM_CONSP (SCM_CDR (formals
))
3290 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3291 goto umwrongnumargs
;
3292 env
= SCM_EXTEND_ENV (formals
,
3295 scm_eval_args (x
, env
, proc
)),
3297 x
= SCM_CLOSURE_BODY (proc
);
3298 goto nontoplevel_begin
;
3301 case scm_tcs_struct
:
3302 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3305 arg1
= debug
.info
->a
.args
;
3307 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3309 x
= SCM_ENTITY_PROCEDURE (proc
);
3312 else if (SCM_I_OPERATORP (proc
))
3316 case scm_tc7_subr_2
:
3317 case scm_tc7_subr_1o
:
3318 case scm_tc7_subr_2o
:
3319 case scm_tc7_subr_0
:
3322 case scm_tc7_subr_1
:
3323 scm_wrong_num_args (proc
);
3331 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3332 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3334 SCM_CLEAR_TRACED_FRAME (debug
);
3335 if (SCM_CHEAPTRAPS_P
)
3336 arg1
= scm_make_debugobj (&debug
);
3340 SCM val
= scm_make_continuation (&first
);
3351 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3355 scm_last_debug_frame
= debug
.prev
;
3361 /* SECTION: This code is compiled once.
3368 /* Simple procedure calls
3372 scm_call_0 (SCM proc
)
3374 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3378 scm_call_1 (SCM proc
, SCM arg1
)
3380 return scm_apply (proc
, arg1
, scm_listofnull
);
3384 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3386 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3390 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3392 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3396 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3398 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3399 scm_cons (arg4
, scm_listofnull
)));
3402 /* Simple procedure applies
3406 scm_apply_0 (SCM proc
, SCM args
)
3408 return scm_apply (proc
, args
, SCM_EOL
);
3412 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3414 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3418 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3420 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3424 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3426 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3430 /* This code processes the arguments to apply:
3432 (apply PROC ARG1 ... ARGS)
3434 Given a list (ARG1 ... ARGS), this function conses the ARG1
3435 ... arguments onto the front of ARGS, and returns the resulting
3436 list. Note that ARGS is a list; thus, the argument to this
3437 function is a list whose last element is a list.
3439 Apply calls this function, and applies PROC to the elements of the
3440 result. apply:nconc2last takes care of building the list of
3441 arguments, given (ARG1 ... ARGS).
3443 Rather than do new consing, apply:nconc2last destroys its argument.
3444 On that topic, this code came into my care with the following
3445 beautifully cryptic comment on that topic: "This will only screw
3446 you if you do (scm_apply scm_apply '( ... ))" If you know what
3447 they're referring to, send me a patch to this comment. */
3449 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3451 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3452 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3453 "@var{args}, and returns the resulting list. Note that\n"
3454 "@var{args} is a list; thus, the argument to this function is\n"
3455 "a list whose last element is a list.\n"
3456 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3457 "destroys its argument, so use with care.")
3458 #define FUNC_NAME s_scm_nconc2last
3461 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3463 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3464 SCM_NULL_OR_NIL_P, but not
3465 needed in 99.99% of cases,
3466 and it could seriously hurt
3467 performance. - Neil */
3468 lloc
= SCM_CDRLOC (*lloc
);
3469 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3470 *lloc
= SCM_CAR (*lloc
);
3478 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3479 * It is compiled twice.
3484 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3490 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3495 /* Apply a function to a list of arguments.
3497 This function is exported to the Scheme level as taking two
3498 required arguments and a tail argument, as if it were:
3499 (lambda (proc arg1 . args) ...)
3500 Thus, if you just have a list of arguments to pass to a procedure,
3501 pass the list as ARG1, and '() for ARGS. If you have some fixed
3502 args, pass the first as ARG1, then cons any remaining fixed args
3503 onto the front of your argument list, and pass that as ARGS. */
3506 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3509 scm_t_debug_frame debug
;
3510 scm_t_debug_info debug_vect_body
;
3511 debug
.prev
= scm_last_debug_frame
;
3512 debug
.status
= SCM_APPLYFRAME
;
3513 debug
.vect
= &debug_vect_body
;
3514 debug
.vect
[0].a
.proc
= proc
;
3515 debug
.vect
[0].a
.args
= SCM_EOL
;
3516 scm_last_debug_frame
= &debug
;
3519 return scm_dapply (proc
, arg1
, args
);
3522 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3524 /* If ARGS is the empty list, then we're calling apply with only two
3525 arguments --- ARG1 is the list of arguments for PROC. Whatever
3526 the case, futz with things so that ARG1 is the first argument to
3527 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3530 Setting the debug apply frame args this way is pretty messy.
3531 Perhaps we should store arg1 and args directly in the frame as
3532 received, and let scm_frame_arguments unpack them, because that's
3533 a relatively rare operation. This works for now; if the Guile
3534 developer archives are still around, see Mikael's post of
3536 if (SCM_NULLP (args
))
3538 if (SCM_NULLP (arg1
))
3540 arg1
= SCM_UNDEFINED
;
3542 debug
.vect
[0].a
.args
= SCM_EOL
;
3548 debug
.vect
[0].a
.args
= arg1
;
3550 args
= SCM_CDR (arg1
);
3551 arg1
= SCM_CAR (arg1
);
3556 args
= scm_nconc2last (args
);
3558 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3562 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3565 if (SCM_CHEAPTRAPS_P
)
3566 tmp
= scm_make_debugobj (&debug
);
3571 tmp
= scm_make_continuation (&first
);
3576 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3583 switch (SCM_TYP7 (proc
))
3585 case scm_tc7_subr_2o
:
3586 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3587 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3588 case scm_tc7_subr_2
:
3589 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3590 scm_wrong_num_args (proc
);
3591 args
= SCM_CAR (args
);
3592 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3593 case scm_tc7_subr_0
:
3594 if (!SCM_UNBNDP (arg1
))
3595 scm_wrong_num_args (proc
);
3597 RETURN (SCM_SUBRF (proc
) ());
3598 case scm_tc7_subr_1
:
3599 if (SCM_UNBNDP (arg1
))
3600 scm_wrong_num_args (proc
);
3601 case scm_tc7_subr_1o
:
3602 if (!SCM_NULLP (args
))
3603 scm_wrong_num_args (proc
);
3605 RETURN (SCM_SUBRF (proc
) (arg1
));
3607 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3608 scm_wrong_num_args (proc
);
3609 if (SCM_INUMP (arg1
))
3611 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3613 else if (SCM_REALP (arg1
))
3615 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3617 else if (SCM_BIGP (arg1
))
3618 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3619 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3620 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3622 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3623 scm_wrong_num_args (proc
);
3625 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3628 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3629 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3630 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3635 case scm_tc7_subr_3
:
3636 if (SCM_NULLP (args
)
3637 || SCM_NULLP (SCM_CDR (args
))
3638 || !SCM_NULLP (SCM_CDDR (args
)))
3639 scm_wrong_num_args (proc
);
3641 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3644 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3646 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3648 case scm_tc7_lsubr_2
:
3649 if (!SCM_CONSP (args
))
3650 scm_wrong_num_args (proc
);
3652 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3654 if (SCM_NULLP (args
))
3655 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3656 while (SCM_NIMP (args
))
3658 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3659 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3660 args
= SCM_CDR (args
);
3663 case scm_tc7_rpsubr
:
3664 if (SCM_NULLP (args
))
3665 RETURN (SCM_BOOL_T
);
3666 while (SCM_NIMP (args
))
3668 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3669 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3670 RETURN (SCM_BOOL_F
);
3671 arg1
= SCM_CAR (args
);
3672 args
= SCM_CDR (args
);
3674 RETURN (SCM_BOOL_T
);
3675 case scm_tcs_closures
:
3677 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3679 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3681 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3682 scm_wrong_num_args (proc
);
3684 /* Copy argument list */
3689 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3690 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
3692 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
3695 SCM_SETCDR (tl
, arg1
);
3698 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3701 proc
= SCM_CLOSURE_BODY (proc
);
3703 arg1
= SCM_CDR (proc
);
3704 while (!SCM_NULLP (arg1
))
3706 if (SCM_IMP (SCM_CAR (proc
)))
3708 if (SCM_ISYMP (SCM_CAR (proc
)))
3710 scm_rec_mutex_lock (&source_mutex
);
3711 /* check for race condition */
3712 if (SCM_ISYMP (SCM_CAR (proc
)))
3713 proc
= scm_m_expand_body (proc
, args
);
3714 scm_rec_mutex_unlock (&source_mutex
);
3718 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3721 SCM_CEVAL (SCM_CAR (proc
), args
);
3723 arg1
= SCM_CDR (proc
);
3725 RETURN (EVALCAR (proc
, args
));
3727 if (!SCM_SMOB_APPLICABLE_P (proc
))
3729 if (SCM_UNBNDP (arg1
))
3730 RETURN (SCM_SMOB_APPLY_0 (proc
));
3731 else if (SCM_NULLP (args
))
3732 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3733 else if (SCM_NULLP (SCM_CDR (args
)))
3734 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3736 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3739 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3741 proc
= SCM_CCLO_SUBR (proc
);
3742 debug
.vect
[0].a
.proc
= proc
;
3743 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3745 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3747 proc
= SCM_CCLO_SUBR (proc
);
3751 proc
= SCM_PROCEDURE (proc
);
3753 debug
.vect
[0].a
.proc
= proc
;
3756 case scm_tcs_struct
:
3757 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3760 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3762 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3764 RETURN (scm_apply_generic (proc
, args
));
3766 else if (SCM_I_OPERATORP (proc
))
3770 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3772 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3775 proc
= (SCM_I_ENTITYP (proc
)
3776 ? SCM_ENTITY_PROCEDURE (proc
)
3777 : SCM_OPERATOR_PROCEDURE (proc
));
3779 debug
.vect
[0].a
.proc
= proc
;
3780 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3782 if (SCM_NIMP (proc
))
3791 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3795 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3796 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3798 SCM_CLEAR_TRACED_FRAME (debug
);
3799 if (SCM_CHEAPTRAPS_P
)
3800 arg1
= scm_make_debugobj (&debug
);
3804 SCM val
= scm_make_continuation (&first
);
3815 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3819 scm_last_debug_frame
= debug
.prev
;
3825 /* SECTION: The rest of this file is only read once.
3832 * Trampolines make it possible to move procedure application dispatch
3833 * outside inner loops. The motivation was clean implementation of
3834 * efficient replacements of R5RS primitives in SRFI-1.
3836 * The semantics is clear: scm_trampoline_N returns an optimized
3837 * version of scm_call_N (or NULL if the procedure isn't applicable
3840 * Applying the optimization to map and for-each increased efficiency
3841 * noticeably. For example, (map abs ls) is now 8 times faster than
3846 call_subr0_0 (SCM proc
)
3848 return SCM_SUBRF (proc
) ();
3852 call_subr1o_0 (SCM proc
)
3854 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
3858 call_lsubr_0 (SCM proc
)
3860 return SCM_SUBRF (proc
) (SCM_EOL
);
3864 scm_i_call_closure_0 (SCM proc
)
3866 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3869 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3874 scm_trampoline_0 (SCM proc
)
3880 switch (SCM_TYP7 (proc
))
3882 case scm_tc7_subr_0
:
3883 return call_subr0_0
;
3884 case scm_tc7_subr_1o
:
3885 return call_subr1o_0
;
3887 return call_lsubr_0
;
3888 case scm_tcs_closures
:
3890 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3891 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
3892 return scm_i_call_closure_0
;
3896 case scm_tcs_struct
:
3897 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3898 return scm_call_generic_0
;
3899 else if (SCM_I_OPERATORP (proc
))
3903 if (SCM_SMOB_APPLICABLE_P (proc
))
3904 return SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
3908 case scm_tc7_rpsubr
:
3913 return NULL
; /* not applicable on one arg */
3918 call_subr1_1 (SCM proc
, SCM arg1
)
3920 return SCM_SUBRF (proc
) (arg1
);
3924 call_subr2o_1 (SCM proc
, SCM arg1
)
3926 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
3930 call_lsubr_1 (SCM proc
, SCM arg1
)
3932 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
3936 call_dsubr_1 (SCM proc
, SCM arg1
)
3938 if (SCM_INUMP (arg1
))
3940 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3942 else if (SCM_REALP (arg1
))
3944 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3946 else if (SCM_BIGP (arg1
))
3947 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3948 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3949 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3953 call_cxr_1 (SCM proc
, SCM arg1
)
3955 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3958 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3959 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3960 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3967 call_closure_1 (SCM proc
, SCM arg1
)
3969 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3972 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
3977 scm_trampoline_1 (SCM proc
)
3983 switch (SCM_TYP7 (proc
))
3985 case scm_tc7_subr_1
:
3986 case scm_tc7_subr_1o
:
3987 return call_subr1_1
;
3988 case scm_tc7_subr_2o
:
3989 return call_subr2o_1
;
3991 return call_lsubr_1
;
3993 return call_dsubr_1
;
3996 case scm_tcs_closures
:
3998 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3999 if (!SCM_NULLP (formals
)
4000 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4001 return call_closure_1
;
4005 case scm_tcs_struct
:
4006 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4007 return scm_call_generic_1
;
4008 else if (SCM_I_OPERATORP (proc
))
4012 if (SCM_SMOB_APPLICABLE_P (proc
))
4013 return SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4017 case scm_tc7_rpsubr
:
4022 return NULL
; /* not applicable on one arg */
4027 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4029 return SCM_SUBRF (proc
) (arg1
, arg2
);
4033 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
4035 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
4039 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
4041 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
4045 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
4047 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4048 scm_list_2 (arg1
, arg2
),
4050 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4055 scm_trampoline_2 (SCM proc
)
4061 switch (SCM_TYP7 (proc
))
4063 case scm_tc7_subr_2
:
4064 case scm_tc7_subr_2o
:
4065 case scm_tc7_rpsubr
:
4067 return call_subr2_2
;
4068 case scm_tc7_lsubr_2
:
4069 return call_lsubr2_2
;
4071 return call_lsubr_2
;
4072 case scm_tcs_closures
:
4074 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4075 if (!SCM_NULLP (formals
)
4076 && (!SCM_CONSP (formals
)
4077 || (!SCM_NULLP (SCM_CDR (formals
))
4078 && (!SCM_CONSP (SCM_CDR (formals
))
4079 || !SCM_CONSP (SCM_CDDR (formals
))))))
4080 return call_closure_2
;
4084 case scm_tcs_struct
:
4085 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4086 return scm_call_generic_2
;
4087 else if (SCM_I_OPERATORP (proc
))
4091 if (SCM_SMOB_APPLICABLE_P (proc
))
4092 return SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
4099 return NULL
; /* not applicable on two args */
4103 /* Typechecking for multi-argument MAP and FOR-EACH.
4105 Verify that each element of the vector ARGV, except for the first,
4106 is a proper list whose length is LEN. Attribute errors to WHO,
4107 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
4109 check_map_args (SCM argv
,
4116 SCM
const *ve
= SCM_VELTS (argv
);
4119 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
4121 long elt_len
= scm_ilength (ve
[i
]);
4126 scm_apply_generic (gf
, scm_cons (proc
, args
));
4128 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
4132 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
4135 scm_remember_upto_here_1 (argv
);
4139 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
4141 /* Note: Currently, scm_map applies PROC to the argument list(s)
4142 sequentially, starting with the first element(s). This is used in
4143 evalext.c where the Scheme procedure `map-in-order', which guarantees
4144 sequential behaviour, is implemented using scm_map. If the
4145 behaviour changes, we need to update `map-in-order'.
4149 scm_map (SCM proc
, SCM arg1
, SCM args
)
4150 #define FUNC_NAME s_map
4155 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4157 len
= scm_ilength (arg1
);
4158 SCM_GASSERTn (len
>= 0,
4159 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
4160 SCM_VALIDATE_REST_ARGUMENT (args
);
4161 if (SCM_NULLP (args
))
4163 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4164 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
4165 while (SCM_NIMP (arg1
))
4167 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
4168 pres
= SCM_CDRLOC (*pres
);
4169 arg1
= SCM_CDR (arg1
);
4173 if (SCM_NULLP (SCM_CDR (args
)))
4175 SCM arg2
= SCM_CAR (args
);
4176 int len2
= scm_ilength (arg2
);
4177 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4179 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
4180 SCM_GASSERTn (len2
>= 0,
4181 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
4183 SCM_OUT_OF_RANGE (3, arg2
);
4184 while (SCM_NIMP (arg1
))
4186 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
4187 pres
= SCM_CDRLOC (*pres
);
4188 arg1
= SCM_CDR (arg1
);
4189 arg2
= SCM_CDR (arg2
);
4193 arg1
= scm_cons (arg1
, args
);
4194 args
= scm_vector (arg1
);
4195 ve
= SCM_VELTS (args
);
4196 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
4200 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4202 if (SCM_IMP (ve
[i
]))
4204 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4205 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4207 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
4208 pres
= SCM_CDRLOC (*pres
);
4214 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
4217 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
4218 #define FUNC_NAME s_for_each
4220 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
4222 len
= scm_ilength (arg1
);
4223 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
4224 SCM_ARG2
, s_for_each
);
4225 SCM_VALIDATE_REST_ARGUMENT (args
);
4226 if (SCM_NULLP (args
))
4228 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
4229 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
4230 while (SCM_NIMP (arg1
))
4232 call (proc
, SCM_CAR (arg1
));
4233 arg1
= SCM_CDR (arg1
);
4235 return SCM_UNSPECIFIED
;
4237 if (SCM_NULLP (SCM_CDR (args
)))
4239 SCM arg2
= SCM_CAR (args
);
4240 int len2
= scm_ilength (arg2
);
4241 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
4242 SCM_GASSERTn (call
, g_for_each
,
4243 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
4244 SCM_GASSERTn (len2
>= 0, g_for_each
,
4245 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
4247 SCM_OUT_OF_RANGE (3, arg2
);
4248 while (SCM_NIMP (arg1
))
4250 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
4251 arg1
= SCM_CDR (arg1
);
4252 arg2
= SCM_CDR (arg2
);
4254 return SCM_UNSPECIFIED
;
4256 arg1
= scm_cons (arg1
, args
);
4257 args
= scm_vector (arg1
);
4258 ve
= SCM_VELTS (args
);
4259 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
4263 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
4265 if (SCM_IMP (ve
[i
]))
4266 return SCM_UNSPECIFIED
;
4267 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
4268 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
4270 scm_apply (proc
, arg1
, SCM_EOL
);
4277 scm_closure (SCM code
, SCM env
)
4280 SCM closcar
= scm_cons (code
, SCM_EOL
);
4281 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
4282 scm_remember_upto_here (closcar
);
4287 scm_t_bits scm_tc16_promise
;
4290 scm_makprom (SCM code
)
4292 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
4294 scm_make_rec_mutex ());
4298 promise_free (SCM promise
)
4300 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
4305 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4307 int writingp
= SCM_WRITINGP (pstate
);
4308 scm_puts ("#<promise ", port
);
4309 SCM_SET_WRITINGP (pstate
, 1);
4310 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
4311 SCM_SET_WRITINGP (pstate
, writingp
);
4312 scm_putc ('>', port
);
4316 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4318 "If the promise @var{x} has not been computed yet, compute and\n"
4319 "return @var{x}, otherwise just return the previously computed\n"
4321 #define FUNC_NAME s_scm_force
4323 SCM_VALIDATE_SMOB (1, promise
, promise
);
4324 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
4325 if (!SCM_PROMISE_COMPUTED_P (promise
))
4327 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
4328 if (!SCM_PROMISE_COMPUTED_P (promise
))
4330 SCM_SET_PROMISE_DATA (promise
, ans
);
4331 SCM_SET_PROMISE_COMPUTED (promise
);
4334 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
4335 return SCM_PROMISE_DATA (promise
);
4340 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4342 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4343 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4344 #define FUNC_NAME s_scm_promise_p
4346 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4351 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4352 (SCM xorig
, SCM x
, SCM y
),
4353 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4354 "Any source properties associated with @var{xorig} are also associated\n"
4355 "with the new pair.")
4356 #define FUNC_NAME s_scm_cons_source
4359 z
= scm_cons (x
, y
);
4360 /* Copy source properties possibly associated with xorig. */
4361 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4363 scm_whash_insert (scm_source_whash
, z
, p
);
4369 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4371 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4372 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4373 "contents of both pairs and vectors (since both cons cells and vector\n"
4374 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4375 "any other object.")
4376 #define FUNC_NAME s_scm_copy_tree
4381 if (SCM_VECTORP (obj
))
4383 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4384 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4386 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
4389 if (!SCM_CONSP (obj
))
4391 ans
= tl
= scm_cons_source (obj
,
4392 scm_copy_tree (SCM_CAR (obj
)),
4394 for (obj
= SCM_CDR (obj
); SCM_CONSP (obj
); obj
= SCM_CDR (obj
))
4396 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4400 SCM_SETCDR (tl
, obj
);
4406 /* We have three levels of EVAL here:
4408 - scm_i_eval (exp, env)
4410 evaluates EXP in environment ENV. ENV is a lexical environment
4411 structure as used by the actual tree code evaluator. When ENV is
4412 a top-level environment, then changes to the current module are
4413 tracked by updating ENV so that it continues to be in sync with
4416 - scm_primitive_eval (exp)
4418 evaluates EXP in the top-level environment as determined by the
4419 current module. This is done by constructing a suitable
4420 environment and calling scm_i_eval. Thus, changes to the
4421 top-level module are tracked normally.
4423 - scm_eval (exp, mod)
4425 evaluates EXP while MOD is the current module. This is done by
4426 setting the current module to MOD, invoking scm_primitive_eval on
4427 EXP, and then restoring the current module to the value it had
4428 previously. That is, while EXP is evaluated, changes to the
4429 current module are tracked, but these changes do not persist when
4432 For each level of evals, there are two variants, distinguished by a
4433 _x suffix: the ordinary variant does not modify EXP while the _x
4434 variant can destructively modify EXP into something completely
4435 unintelligible. A Scheme data structure passed as EXP to one of the
4436 _x variants should not ever be used again for anything. So when in
4437 doubt, use the ordinary variant.
4442 scm_i_eval_x (SCM exp
, SCM env
)
4444 return SCM_XEVAL (exp
, env
);
4448 scm_i_eval (SCM exp
, SCM env
)
4450 exp
= scm_copy_tree (exp
);
4451 return SCM_XEVAL (exp
, env
);
4455 scm_primitive_eval_x (SCM exp
)
4458 SCM transformer
= scm_current_module_transformer ();
4459 if (SCM_NIMP (transformer
))
4460 exp
= scm_call_1 (transformer
, exp
);
4461 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4462 return scm_i_eval_x (exp
, env
);
4465 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4467 "Evaluate @var{exp} in the top-level environment specified by\n"
4468 "the current module.")
4469 #define FUNC_NAME s_scm_primitive_eval
4472 SCM transformer
= scm_current_module_transformer ();
4473 if (SCM_NIMP (transformer
))
4474 exp
= scm_call_1 (transformer
, exp
);
4475 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4476 return scm_i_eval (exp
, env
);
4480 /* Eval does not take the second arg optionally. This is intentional
4481 * in order to be R5RS compatible, and to prepare for the new module
4482 * system, where we would like to make the choice of evaluation
4483 * environment explicit. */
4486 change_environment (void *data
)
4488 SCM pair
= SCM_PACK (data
);
4489 SCM new_module
= SCM_CAR (pair
);
4490 SCM old_module
= scm_current_module ();
4491 SCM_SETCDR (pair
, old_module
);
4492 scm_set_current_module (new_module
);
4497 restore_environment (void *data
)
4499 SCM pair
= SCM_PACK (data
);
4500 SCM old_module
= SCM_CDR (pair
);
4501 SCM new_module
= scm_current_module ();
4502 SCM_SETCAR (pair
, new_module
);
4503 scm_set_current_module (old_module
);
4507 inner_eval_x (void *data
)
4509 return scm_primitive_eval_x (SCM_PACK(data
));
4513 scm_eval_x (SCM exp
, SCM module
)
4514 #define FUNC_NAME "eval!"
4516 SCM_VALIDATE_MODULE (2, module
);
4518 return scm_internal_dynamic_wind
4519 (change_environment
, inner_eval_x
, restore_environment
,
4520 (void *) SCM_UNPACK (exp
),
4521 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4526 inner_eval (void *data
)
4528 return scm_primitive_eval (SCM_PACK(data
));
4531 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4532 (SCM exp
, SCM module
),
4533 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4534 "in the top-level environment specified by @var{module}.\n"
4535 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4536 "@var{module} is made the current module. The current module\n"
4537 "is reset to its previous value when @var{eval} returns.")
4538 #define FUNC_NAME s_scm_eval
4540 SCM_VALIDATE_MODULE (2, module
);
4542 return scm_internal_dynamic_wind
4543 (change_environment
, inner_eval
, restore_environment
,
4544 (void *) SCM_UNPACK (exp
),
4545 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4550 /* At this point, scm_deval and scm_dapply are generated.
4560 scm_init_opts (scm_evaluator_traps
,
4561 scm_evaluator_trap_table
,
4562 SCM_N_EVALUATOR_TRAPS
);
4563 scm_init_opts (scm_eval_options_interface
,
4565 SCM_N_EVAL_OPTIONS
);
4567 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4568 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4569 scm_set_smob_free (scm_tc16_promise
, promise_free
);
4570 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4572 undefineds
= scm_list_1 (SCM_UNDEFINED
);
4573 SCM_SETCDR (undefineds
, undefineds
);
4574 scm_permanent_object (undefineds
);
4576 scm_listofnull
= scm_list_1 (SCM_EOL
);
4578 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4579 scm_permanent_object (f_apply
);
4581 #include "libguile/eval.x"
4583 scm_add_feature ("delay");