1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
44 /* This file is read twice in order to produce debugging versions of
45 * scm_ceval and scm_apply. These functions, scm_deval and
46 * scm_dapply, are produced when we define the preprocessor macro
47 * DEVAL. The file is divided into sections which are treated
48 * differently with respect to DEVAL. The heads of these sections are
49 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
57 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
58 #include "libguile/scmconfig.h"
60 /* AIX requires this to be the first thing in the file. The #pragma
61 directive is indented so pre-ANSI compilers will ignore it, rather
70 # ifndef alloca /* predefined by HP cc +Olibcalls */
77 #include "libguile/_scm.h"
78 #include "libguile/debug.h"
79 #include "libguile/dynwind.h"
80 #include "libguile/alist.h"
81 #include "libguile/eq.h"
82 #include "libguile/continuations.h"
83 #include "libguile/throw.h"
84 #include "libguile/smob.h"
85 #include "libguile/macros.h"
86 #include "libguile/procprop.h"
87 #include "libguile/hashtab.h"
88 #include "libguile/hash.h"
89 #include "libguile/srcprop.h"
90 #include "libguile/stackchk.h"
91 #include "libguile/objects.h"
92 #include "libguile/async.h"
93 #include "libguile/feature.h"
94 #include "libguile/modules.h"
95 #include "libguile/ports.h"
96 #include "libguile/root.h"
97 #include "libguile/vectors.h"
98 #include "libguile/fluids.h"
99 #include "libguile/values.h"
101 #include "libguile/validate.h"
102 #include "libguile/eval.h"
106 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
108 if (SCM_EQ_P ((x), SCM_EOL)) \
109 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
114 /* The evaluator contains a plethora of EVAL symbols.
115 * This is an attempt at explanation.
117 * The following macros should be used in code which is read twice
118 * (where the choice of evaluator is hard soldered):
120 * SCM_CEVAL is the symbol used within one evaluator to call itself.
121 * Originally, it is defined to scm_ceval, but is redefined to
122 * scm_deval during the second pass.
124 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
125 * only side effects of expressions matter. All immediates are
128 * SCM_EVALIM is used when it is known that the expression is an
129 * immediate. (This macro never calls an evaluator.)
131 * EVALCAR evaluates the car of an expression.
133 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
134 * car is a lisp cell.
136 * The following macros should be used in code which is read once
137 * (where the choice of evaluator is dynamic):
139 * SCM_XEVAL takes care of immediates without calling an evaluator. It
140 * then calls scm_ceval *or* scm_deval, depending on the debugging
143 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
144 * depending on the debugging mode.
146 * The main motivation for keeping this plethora is efficiency
147 * together with maintainability (=> locality of code).
150 #define SCM_CEVAL scm_ceval
151 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
153 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
154 ? *scm_lookupcar (x, env, 1) \
155 : SCM_CEVAL (SCM_CAR (x), env))
157 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
158 ? SCM_EVALIM (SCM_CAR (x), env) \
159 : EVALCELLCAR (x, env))
161 #define EXTEND_ENV SCM_EXTEND_ENV
163 #ifdef MEMOIZE_LOCALS
166 scm_ilookup (SCM iloc
, SCM env
)
168 register long ir
= SCM_IFRAME (iloc
);
169 register SCM er
= env
;
170 for (; 0 != ir
; --ir
)
173 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
175 if (SCM_ICDRP (iloc
))
176 return SCM_CDRLOC (er
);
177 return SCM_CARLOC (SCM_CDR (er
));
183 /* The Lookup Car Race
186 Memoization of variables and special forms is done while executing
187 the code for the first time. As long as there is only one thread
188 everything is fine, but as soon as two threads execute the same
189 code concurrently `for the first time' they can come into conflict.
191 This memoization includes rewriting variable references into more
192 efficient forms and expanding macros. Furthermore, macro expansion
193 includes `compiling' special forms like `let', `cond', etc. into
194 tree-code instructions.
196 There shouldn't normally be a problem with memoizing local and
197 global variable references (into ilocs and variables), because all
198 threads will mutate the code in *exactly* the same way and (if I
199 read the C code correctly) it is not possible to observe a half-way
200 mutated cons cell. The lookup procedure can handle this
201 transparently without any critical sections.
203 It is different with macro expansion, because macro expansion
204 happens outside of the lookup procedure and can't be
205 undone. Therefore the lookup procedure can't cope with it. It has
206 to indicate failure when it detects a lost race and hope that the
207 caller can handle it. Luckily, it turns out that this is the case.
209 An example to illustrate this: Suppose that the following form will
210 be memoized concurrently by two threads
214 Let's first examine the lookup of X in the body. The first thread
215 decides that it has to find the symbol "x" in the environment and
216 starts to scan it. Then the other thread takes over and actually
217 overtakes the first. It looks up "x" and substitutes an
218 appropriate iloc for it. Now the first thread continues and
219 completes its lookup. It comes to exactly the same conclusions as
220 the second one and could - without much ado - just overwrite the
221 iloc with the same iloc.
223 But let's see what will happen when the race occurs while looking
224 up the symbol "let" at the start of the form. It could happen that
225 the second thread interrupts the lookup of the first thread and not
226 only substitutes a variable for it but goes right ahead and
227 replaces it with the compiled form (#@let* (x 12) x). Now, when
228 the first thread completes its lookup, it would replace the #@let*
229 with a variable containing the "let" binding, effectively reverting
230 the form to (let (x 12) x). This is wrong. It has to detect that
231 it has lost the race and the evaluator has to reconsider the
232 changed form completely.
234 This race condition could be resolved with some kind of traffic
235 light (like mutexes) around scm_lookupcar, but I think that it is
236 best to avoid them in this case. They would serialize memoization
237 completely and because lookup involves calling arbitrary Scheme
238 code (via the lookup-thunk), threads could be blocked for an
239 arbitrary amount of time or even deadlock. But with the current
240 solution a lot of unnecessary work is potentially done. */
242 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
243 return NULL to indicate a failed lookup due to some race conditions
244 between threads. This only happens when VLOC is the first cell of
245 a special form that will eventually be memoized (like `let', etc.)
246 In that case the whole lookup is bogus and the caller has to
247 reconsider the complete special form.
249 SCM_LOOKUPCAR is still there, of course. It just calls
250 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
251 should only be called when it is known that VLOC is not the first
252 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
253 for NULL. I think I've found the only places where this
256 #endif /* USE_THREADS */
258 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
262 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
265 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
269 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
270 #ifdef MEMOIZE_LOCALS
271 register SCM iloc
= SCM_ILOC00
;
273 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
275 if (!SCM_CONSP (SCM_CAR (env
)))
277 al
= SCM_CARLOC (env
);
278 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
282 if (SCM_EQ_P (fl
, var
))
284 #ifdef MEMOIZE_LOCALS
286 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
289 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
291 return SCM_CDRLOC (*al
);
296 al
= SCM_CDRLOC (*al
);
297 if (SCM_EQ_P (SCM_CAR (fl
), var
))
299 #ifdef MEMOIZE_LOCALS
300 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
301 if (SCM_UNBNDP (SCM_CAR (*al
)))
308 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
311 SCM_SETCAR (vloc
, iloc
);
313 return SCM_CARLOC (*al
);
315 #ifdef MEMOIZE_LOCALS
316 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
319 #ifdef MEMOIZE_LOCALS
320 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
324 SCM top_thunk
, real_var
;
327 top_thunk
= SCM_CAR (env
); /* env now refers to a
328 top level env thunk */
332 top_thunk
= SCM_BOOL_F
;
333 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
334 if (SCM_FALSEP (real_var
))
338 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
341 /* scm_everr (vloc, genv,...) */
345 scm_error (scm_unbound_variable_key
, NULL
,
346 "Unbound variable: ~S",
347 scm_list_1 (var
), SCM_BOOL_F
);
349 scm_misc_error (NULL
, "Damaged environment: ~S",
354 /* A variable could not be found, but we shall
355 not throw an error. */
356 static SCM undef_object
= SCM_UNDEFINED
;
357 return &undef_object
;
363 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
365 /* Some other thread has changed the very cell we are working
366 on. In effect, it must have done our job or messed it up
369 var
= SCM_CAR (vloc
);
370 if (SCM_VARIABLEP (var
))
371 return SCM_VARIABLE_LOC (var
);
372 #ifdef MEMOIZE_LOCALS
373 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
374 return scm_ilookup (var
, genv
);
376 /* We can't cope with anything else than variables and ilocs. When
377 a special form has been memoized (i.e. `let' into `#@let') we
378 return NULL and expect the calling function to do the right
379 thing. For the evaluator, this means going back and redoing
380 the dispatch on the car of the form. */
383 #endif /* USE_THREADS */
385 SCM_SETCAR (vloc
, real_var
);
386 return SCM_VARIABLE_LOC (real_var
);
392 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
394 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
401 #define unmemocar scm_unmemocar
403 SCM_SYMBOL (sym_three_question_marks
, "???");
406 scm_unmemocar (SCM form
, SCM env
)
408 if (!SCM_CONSP (form
))
412 SCM c
= SCM_CAR (form
);
413 if (SCM_VARIABLEP (c
))
415 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
416 if (SCM_FALSEP (sym
))
417 sym
= sym_three_question_marks
;
418 SCM_SETCAR (form
, sym
);
420 #ifdef MEMOIZE_LOCALS
421 else if (SCM_ILOCP (c
))
423 unsigned long int ir
;
425 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
427 env
= SCM_CAAR (env
);
428 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
430 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
439 scm_eval_car (SCM pair
, SCM env
)
441 return SCM_XEVALCAR (pair
, env
);
446 * The following rewrite expressions and
447 * some memoized forms have different syntax
450 const char scm_s_expression
[] = "missing or extra expression";
451 const char scm_s_test
[] = "bad test";
452 const char scm_s_body
[] = "bad body";
453 const char scm_s_bindings
[] = "bad bindings";
454 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
455 const char scm_s_variable
[] = "bad variable";
456 const char scm_s_clauses
[] = "bad or missing clauses";
457 const char scm_s_formals
[] = "bad formals";
458 const char scm_s_duplicate_formals
[] = "duplicate formals";
459 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
461 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
462 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
463 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
464 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
465 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
469 #ifdef DEBUG_EXTENSIONS
470 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
471 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
472 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
473 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
477 /* Check that the body denoted by XORIG is valid and rewrite it into
478 its internal form. The internal form of a body is just the body
479 itself, but prefixed with an ISYM that denotes to what kind of
480 outer construct this body belongs. A lambda body starts with
481 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
482 etc. The one exception is a body that belongs to a letrec that has
483 been formed by rewriting internal defines: it starts with
486 /* XXX - Besides controlling the rewriting of internal defines, the
487 additional ISYM could be used for improved error messages.
488 This is not done yet. */
491 scm_m_body (SCM op
, SCM xorig
, const char *what
)
493 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
495 /* Don't add another ISYM if one is present already. */
496 if (SCM_ISYMP (SCM_CAR (xorig
)))
499 /* Retain possible doc string. */
500 if (!SCM_CONSP (SCM_CAR (xorig
)))
502 if (!SCM_NULLP (SCM_CDR (xorig
)))
503 return scm_cons (SCM_CAR (xorig
),
504 scm_m_body (op
, SCM_CDR (xorig
), what
));
508 return scm_cons (op
, xorig
);
512 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
513 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
516 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
518 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
519 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
523 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
524 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
527 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
529 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
530 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
534 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
535 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
538 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
540 long len
= scm_ilength (SCM_CDR (xorig
));
541 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, "if");
542 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
546 /* Will go into the RnRS module when Guile is factorized.
547 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
548 const char scm_s_set_x
[] = "set!";
549 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
552 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
554 SCM x
= SCM_CDR (xorig
);
555 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
556 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
557 return scm_cons (SCM_IM_SET_X
, x
);
561 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
562 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
565 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
567 long len
= scm_ilength (SCM_CDR (xorig
));
568 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
570 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
576 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
577 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
580 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
582 long len
= scm_ilength (SCM_CDR (xorig
));
583 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
585 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
591 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
592 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
595 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
598 SCM cdrx
= SCM_CDR (xorig
);
599 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
600 clauses
= SCM_CDR (cdrx
);
601 while (!SCM_NULLP (clauses
))
603 SCM clause
= SCM_CAR (clauses
);
604 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
605 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
606 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
607 && SCM_NULLP (SCM_CDR (clauses
))),
608 scm_s_clauses
, s_case
);
609 clauses
= SCM_CDR (clauses
);
611 return scm_cons (SCM_IM_CASE
, cdrx
);
615 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
616 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
619 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
621 SCM cdrx
= SCM_CDR (xorig
);
623 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
624 while (!SCM_NULLP (clauses
))
626 SCM clause
= SCM_CAR (clauses
);
627 long len
= scm_ilength (clause
);
628 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
629 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
631 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
632 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
634 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
636 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
637 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
639 clauses
= SCM_CDR (clauses
);
641 return scm_cons (SCM_IM_COND
, cdrx
);
645 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
646 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
648 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
649 * cdr of the last cons. (Thus, LIST is not required to be a proper
650 * list and OBJ can also be found in the improper ending.) */
652 scm_c_improper_memq (SCM obj
, SCM list
)
654 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
656 if (SCM_EQ_P (SCM_CAR (list
), obj
))
659 return SCM_EQ_P (list
, obj
);
663 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
666 SCM x
= SCM_CDR (xorig
);
668 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
670 formals
= SCM_CAR (x
);
671 while (SCM_CONSP (formals
))
673 SCM formal
= SCM_CAR (formals
);
674 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
675 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
676 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
677 formals
= SCM_CDR (formals
);
679 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
680 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
682 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
683 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
687 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
688 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
690 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
691 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
693 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
696 SCM x
= SCM_CDR (xorig
);
700 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
702 bindings
= SCM_CAR (x
);
703 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
704 while (!SCM_NULLP (bindings
))
706 SCM binding
= SCM_CAR (bindings
);
707 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
708 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
709 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
710 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
711 bindings
= SCM_CDR (bindings
);
714 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
715 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
719 /* DO gets the most radically altered syntax. The order of the vars is
720 * reversed here. In contrast, the order of the inits and steps is reversed
721 * during the evaluation:
723 (do ((<var1> <init1> <step1>)
731 (#@do (varn ... var2 var1)
732 (<init1> <init2> ... <initn>)
735 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
738 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
739 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
742 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
745 SCM x
= SCM_CDR (xorig
);
748 SCM
*initloc
= &inits
;
750 SCM
*steploc
= &steps
;
751 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
752 bindings
= SCM_CAR (x
);
753 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
754 while (!SCM_NULLP (bindings
))
756 SCM binding
= SCM_CAR (bindings
);
757 long len
= scm_ilength (binding
);
758 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
760 SCM name
= SCM_CAR (binding
);
761 SCM init
= SCM_CADR (binding
);
762 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
763 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
764 vars
= scm_cons (name
, vars
);
765 *initloc
= scm_list_1 (init
);
766 initloc
= SCM_CDRLOC (*initloc
);
767 *steploc
= scm_list_1 (step
);
768 steploc
= SCM_CDRLOC (*steploc
);
769 bindings
= SCM_CDR (bindings
);
773 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
774 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
775 x
= scm_cons2 (vars
, inits
, x
);
776 return scm_cons (SCM_IM_DO
, x
);
780 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
781 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
783 /* Internal function to handle a quasiquotation: 'form' is the parameter in
784 * the call (quasiquotation form), 'env' is the environment where unquoted
785 * expressions will be evaluated, and 'depth' is the current quasiquotation
786 * nesting level and is known to be greater than zero. */
788 iqq (SCM form
, SCM env
, unsigned long int depth
)
790 if (SCM_CONSP (form
))
792 SCM tmp
= SCM_CAR (form
);
793 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
795 SCM args
= SCM_CDR (form
);
796 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
797 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
799 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
801 SCM args
= SCM_CDR (form
);
802 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
804 return scm_eval_car (args
, env
);
806 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
808 else if (SCM_CONSP (tmp
)
809 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
811 SCM args
= SCM_CDR (tmp
);
812 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
815 SCM list
= scm_eval_car (args
, env
);
816 SCM rest
= SCM_CDR (form
);
817 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
818 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
821 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
822 iqq (SCM_CDR (form
), env
, depth
));
825 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
826 iqq (SCM_CDR (form
), env
, depth
));
828 else if (SCM_VECTORP (form
))
830 size_t i
= SCM_VECTOR_LENGTH (form
);
831 SCM
*data
= SCM_VELTS (form
);
834 tmp
= scm_cons (data
[--i
], tmp
);
835 scm_remember_upto_here_1 (form
);
836 return scm_vector (iqq (tmp
, env
, depth
));
843 scm_m_quasiquote (SCM xorig
, SCM env
)
845 SCM x
= SCM_CDR (xorig
);
846 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
847 return iqq (SCM_CAR (x
), env
, 1);
851 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
852 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
854 /* Promises are implemented as closures with an empty parameter list. Thus,
855 * (delay <expression>) is transformed into (#@delay '() <expression>), where
856 * the empty list represents the empty parameter list. This representation
857 * allows for easy creation of the closure during evaluation. */
859 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
861 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
862 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
866 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
867 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
869 /* Guile provides an extension to R5RS' define syntax to represent function
870 * currying in a compact way. With this extension, it is allowed to write
871 * (define <nested-variable> <body>), where <nested-variable> has of one of
872 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
873 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
874 * should be either a sequence of zero or more variables, or a sequence of one
875 * or more variables followed by a space-delimited period and another
876 * variable. Each level of argument nesting wraps the <body> within another
877 * lambda expression. For example, the following forms are allowed, each one
878 * followed by an equivalent, more explicit implementation.
880 * (define ((a b . c) . d) <body>) is equivalent to
881 * (define a (lambda (b . c) (lambda d <body>)))
883 * (define (((a) b) c . d) <body>) is equivalent to
884 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
886 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
887 * module that does not implement this extension. */
889 scm_m_define (SCM x
, SCM env
)
893 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
896 while (SCM_CONSP (name
))
898 /* This while loop realizes function currying by variable nesting. */
899 SCM formals
= SCM_CDR (name
);
900 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
901 name
= SCM_CAR (name
);
903 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
904 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
905 if (SCM_TOP_LEVEL (env
))
908 x
= scm_eval_car (x
, env
);
909 if (SCM_REC_PROCNAMES_P
)
912 while (SCM_MACROP (tmp
))
913 tmp
= SCM_MACRO_CODE (tmp
);
914 if (SCM_CLOSUREP (tmp
)
915 /* Only the first definition determines the name. */
916 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
917 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
919 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
920 SCM_VARIABLE_SET (var
, x
);
921 return SCM_UNSPECIFIED
;
924 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
928 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
929 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
930 * reversed here, the list of inits gets reversed during evaluation. */
932 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
938 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
942 SCM binding
= SCM_CAR (bindings
);
943 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
944 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
945 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
946 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
947 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
948 *initloc
= scm_list_1 (SCM_CADR (binding
));
949 initloc
= SCM_CDRLOC (*initloc
);
950 bindings
= SCM_CDR (bindings
);
952 while (!SCM_NULLP (bindings
));
958 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
959 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
962 scm_m_letrec (SCM xorig
, SCM env
)
964 SCM x
= SCM_CDR (xorig
);
965 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
967 if (SCM_NULLP (SCM_CAR (x
)))
969 /* null binding, let* faster */
970 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
971 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
975 SCM rvars
, inits
, body
;
976 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
977 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
978 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
983 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
984 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
987 scm_m_let (SCM xorig
, SCM env
)
989 SCM x
= SCM_CDR (xorig
);
992 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
995 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
997 /* null or single binding, let* is faster */
999 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
1000 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
1002 else if (SCM_CONSP (temp
))
1005 SCM bindings
= temp
;
1006 SCM rvars
, inits
, body
;
1007 transform_bindings (bindings
, &rvars
, &inits
, "let");
1008 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1009 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1013 /* named let: Transform (let name ((var init) ...) body ...) into
1014 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1018 SCM
*varloc
= &vars
;
1019 SCM inits
= SCM_EOL
;
1020 SCM
*initloc
= &inits
;
1023 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1025 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1026 bindings
= SCM_CAR (x
);
1027 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1028 while (!SCM_NULLP (bindings
))
1029 { /* vars and inits both in order */
1030 SCM binding
= SCM_CAR (bindings
);
1031 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1032 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1033 *varloc
= scm_list_1 (SCM_CAR (binding
));
1034 varloc
= SCM_CDRLOC (*varloc
);
1035 *initloc
= scm_list_1 (SCM_CADR (binding
));
1036 initloc
= SCM_CDRLOC (*initloc
);
1037 bindings
= SCM_CDR (bindings
);
1041 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1042 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1043 SCM rvar
= scm_list_1 (name
);
1044 SCM init
= scm_list_1 (lambda_form
);
1045 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1046 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1047 return scm_cons (letrec
, inits
);
1053 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1054 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1055 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1058 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1060 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1061 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1065 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1066 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1070 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1072 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1073 scm_s_expression
, s_atcall_cc
);
1074 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1077 /* Multi-language support */
1079 SCM_GLOBAL_SYMBOL (scm_lisp_nil
, "nil");
1080 SCM_GLOBAL_SYMBOL (scm_lisp_t
, "t");
1082 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1085 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1087 long len
= scm_ilength (SCM_CDR (xorig
));
1088 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1089 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1095 scm_m_nil_ify (SCM xorig
, SCM env SCM_UNUSED
)
1097 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1098 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1101 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1104 scm_m_t_ify (SCM xorig
, SCM env SCM_UNUSED
)
1106 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1107 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1110 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1113 scm_m_0_cond (SCM xorig
, SCM env SCM_UNUSED
)
1115 long len
= scm_ilength (SCM_CDR (xorig
));
1116 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1117 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1120 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1123 scm_m_0_ify (SCM xorig
, SCM env SCM_UNUSED
)
1125 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1126 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1129 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1132 scm_m_1_ify (SCM xorig
, SCM env SCM_UNUSED
)
1134 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1135 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1138 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1141 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1143 SCM x
= SCM_CDR (xorig
), var
;
1144 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1145 var
= scm_symbol_fref (SCM_CAR (x
));
1146 SCM_ASSYNT (SCM_VARIABLEP (var
),
1147 "Symbol's function definition is void", NULL
);
1148 SCM_SETCAR (x
, var
);
1152 /* (@bind ((var exp) ...) body ...)
1154 This will assign the values of the `exp's to the global variables
1155 named by `var's (symbols, not evaluated), creating them if they
1156 don't exist, executes body, and then restores the previous values of
1157 the `var's. Additionally, whenever control leaves body, the values
1158 of the `var's are saved and restored when control returns. It is an
1159 error when a symbol appears more than once among the `var's.
1160 All `exp's are evaluated before any `var' is set.
1162 This of this as `let' for dynamic scope.
1164 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1166 XXX - also implement `@bind*'.
1169 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1172 scm_m_atbind (SCM xorig
, SCM env
)
1174 SCM x
= SCM_CDR (xorig
);
1175 SCM top_level
= scm_env_top_level (env
);
1176 SCM vars
= SCM_EOL
, var
;
1179 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1182 while (SCM_NIMP (x
))
1185 SCM sym_exp
= SCM_CAR (x
);
1186 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1187 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1189 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1190 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1191 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1192 /* The first call to scm_sym2var will look beyond the current
1193 module, while the second call wont. */
1194 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1195 if (SCM_FALSEP (var
))
1196 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1197 vars
= scm_cons (var
, vars
);
1198 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1200 return scm_cons (SCM_IM_BIND
,
1201 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1205 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1206 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1209 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1211 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1212 scm_s_expression
, s_at_call_with_values
);
1213 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1217 scm_m_expand_body (SCM xorig
, SCM env
)
1219 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1220 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1222 while (SCM_NIMP (x
))
1224 SCM form
= SCM_CAR (x
);
1225 if (!SCM_CONSP (form
))
1227 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1230 form
= scm_macroexp (scm_cons_source (form
,
1235 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1237 defs
= scm_cons (SCM_CDR (form
), defs
);
1240 else if (!SCM_IMP (defs
))
1244 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1246 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1250 x
= scm_cons (form
, SCM_CDR (x
));
1255 if (!SCM_NULLP (defs
))
1257 SCM rvars
, inits
, body
, letrec
;
1258 transform_bindings (defs
, &rvars
, &inits
, what
);
1259 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1260 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1261 SCM_SETCAR (xorig
, letrec
);
1262 SCM_SETCDR (xorig
, SCM_EOL
);
1266 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1267 SCM_SETCAR (xorig
, SCM_CAR (x
));
1268 SCM_SETCDR (xorig
, SCM_CDR (x
));
1275 scm_macroexp (SCM x
, SCM env
)
1277 SCM res
, proc
, orig_sym
;
1279 /* Don't bother to produce error messages here. We get them when we
1280 eventually execute the code for real. */
1283 orig_sym
= SCM_CAR (x
);
1284 if (!SCM_SYMBOLP (orig_sym
))
1289 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1290 if (proc_ptr
== NULL
)
1292 /* We have lost the race. */
1298 proc
= *scm_lookupcar (x
, env
, 0);
1301 /* Only handle memoizing macros. `Acros' and `macros' are really
1302 special forms and should not be evaluated here. */
1304 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1307 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1308 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1310 if (scm_ilength (res
) <= 0)
1311 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1314 SCM_SETCAR (x
, SCM_CAR (res
));
1315 SCM_SETCDR (x
, SCM_CDR (res
));
1321 /* scm_unmemocopy takes a memoized expression together with its
1322 * environment and rewrites it to its original form. Thus, it is the
1323 * inversion of the rewrite rules above. The procedure is not
1324 * optimized for speed. It's used in scm_iprin1 when printing the
1325 * code of a closure, in scm_procedure_source, in display_frame when
1326 * generating the source for a stackframe in a backtrace, and in
1327 * display_expression.
1329 * Unmemoizing is not a realiable process. You can not in general
1330 * expect to get the original source back.
1332 * However, GOOPS currently relies on this for method compilation.
1333 * This ought to change.
1336 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1339 build_binding_list (SCM names
, SCM inits
)
1341 SCM bindings
= SCM_EOL
;
1342 while (!SCM_NULLP (names
))
1344 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1345 bindings
= scm_cons (binding
, bindings
);
1346 names
= SCM_CDR (names
);
1347 inits
= SCM_CDR (inits
);
1353 unmemocopy (SCM x
, SCM env
)
1356 #ifdef DEBUG_EXTENSIONS
1361 #ifdef DEBUG_EXTENSIONS
1362 p
= scm_whash_lookup (scm_source_whash
, x
);
1364 switch (SCM_ITAG7 (SCM_CAR (x
)))
1366 case SCM_BIT8(SCM_IM_AND
):
1367 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1369 case SCM_BIT8(SCM_IM_BEGIN
):
1370 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1372 case SCM_BIT8(SCM_IM_CASE
):
1373 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1375 case SCM_BIT8(SCM_IM_COND
):
1376 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1378 case SCM_BIT8 (SCM_IM_DO
):
1380 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1381 * where nx is the name of a local variable, ix is an initializer for
1382 * the local variable, test is the test clause of the do loop, body is
1383 * the body of the do loop and sx are the step clauses for the local
1385 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1388 names
= SCM_CAR (x
);
1390 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1391 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1393 test
= unmemocopy (SCM_CAR (x
), env
);
1395 memoized_body
= SCM_CAR (x
);
1397 steps
= scm_reverse (unmemocopy (x
, env
));
1399 /* build transformed binding list */
1401 while (!SCM_NULLP (names
))
1403 SCM name
= SCM_CAR (names
);
1404 SCM init
= SCM_CAR (inits
);
1405 SCM step
= SCM_CAR (steps
);
1406 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1408 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1410 names
= SCM_CDR (names
);
1411 inits
= SCM_CDR (inits
);
1412 steps
= SCM_CDR (steps
);
1414 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1415 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1417 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1420 case SCM_BIT8(SCM_IM_IF
):
1421 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1423 case SCM_BIT8 (SCM_IM_LET
):
1425 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1426 * where nx is the name of a local variable, ix is an initializer for
1427 * the local variable and by are the body clauses. */
1428 SCM names
, inits
, bindings
;
1431 names
= SCM_CAR (x
);
1433 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1434 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1436 bindings
= build_binding_list (names
, inits
);
1437 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1438 ls
= scm_cons (scm_sym_let
, z
);
1441 case SCM_BIT8 (SCM_IM_LETREC
):
1443 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1444 * where nx is the name of a local variable, ix is an initializer for
1445 * the local variable and by are the body clauses. */
1446 SCM names
, inits
, bindings
;
1449 names
= SCM_CAR (x
);
1450 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1452 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1454 bindings
= build_binding_list (names
, inits
);
1455 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1456 ls
= scm_cons (scm_sym_letrec
, z
);
1459 case SCM_BIT8(SCM_IM_LETSTAR
):
1467 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1470 y
= z
= scm_acons (SCM_CAR (b
),
1472 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1474 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1478 SCM_SETCDR (y
, SCM_EOL
);
1479 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1484 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1486 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1489 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1492 while (SCM_NIMP (b
));
1493 SCM_SETCDR (z
, SCM_EOL
);
1495 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1498 case SCM_BIT8(SCM_IM_OR
):
1499 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1501 case SCM_BIT8(SCM_IM_LAMBDA
):
1503 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1504 ls
= scm_cons (scm_sym_lambda
, z
);
1505 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1507 case SCM_BIT8(SCM_IM_QUOTE
):
1508 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1510 case SCM_BIT8(SCM_IM_SET_X
):
1511 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1513 case SCM_BIT8(SCM_IM_DEFINE
):
1518 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1519 ls
= scm_cons (scm_sym_define
, z
);
1520 if (!SCM_NULLP (env
))
1521 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1524 case SCM_BIT8(SCM_MAKISYM (0)):
1528 switch (SCM_ISYMNUM (z
))
1530 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1531 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1533 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1534 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1536 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1537 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1540 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1541 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1544 /* appease the Sun compiler god: */ ;
1548 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1554 while (SCM_CONSP (x
))
1556 SCM form
= SCM_CAR (x
);
1557 if (!SCM_ISYMP (form
))
1559 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1560 SCM_SETCDR (z
, unmemocar (copy
, env
));
1566 #ifdef DEBUG_EXTENSIONS
1567 if (!SCM_FALSEP (p
))
1568 scm_whash_insert (scm_source_whash
, ls
, p
);
1575 scm_unmemocopy (SCM x
, SCM env
)
1577 if (!SCM_NULLP (env
))
1578 /* Make a copy of the lowest frame to protect it from
1579 modifications by SCM_IM_DEFINE */
1580 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1582 return unmemocopy (x
, env
);
1585 #ifndef SCM_RECKLESS
1588 scm_badargsp (SCM formals
, SCM args
)
1590 while (SCM_NIMP (formals
))
1592 if (!SCM_CONSP (formals
))
1596 formals
= SCM_CDR (formals
);
1597 args
= SCM_CDR (args
);
1599 return !SCM_NULLP (args
) ? 1 : 0;
1604 scm_badformalsp (SCM closure
, int n
)
1606 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1607 while (!SCM_NULLP (formals
))
1609 if (!SCM_CONSP (formals
))
1614 formals
= SCM_CDR (formals
);
1621 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1623 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1624 while (SCM_CONSP (l
))
1626 res
= EVALCAR (l
, env
);
1628 *lloc
= scm_list_1 (res
);
1629 lloc
= SCM_CDRLOC (*lloc
);
1634 scm_wrong_num_args (proc
);
1640 scm_eval_body (SCM code
, SCM env
)
1644 next
= SCM_CDR (code
);
1645 while (!SCM_NULLP (next
))
1647 if (SCM_IMP (SCM_CAR (code
)))
1649 if (SCM_ISYMP (SCM_CAR (code
)))
1651 code
= scm_m_expand_body (code
, env
);
1656 SCM_XEVAL (SCM_CAR (code
), env
);
1658 next
= SCM_CDR (code
);
1660 return SCM_XEVALCAR (code
, env
);
1667 /* SECTION: This code is specific for the debugging support. One
1668 * branch is read when DEVAL isn't defined, the other when DEVAL is
1674 #define SCM_APPLY scm_apply
1675 #define PREP_APPLY(proc, args)
1677 #define RETURN(x) do { return x; } while (0)
1678 #ifdef STACK_CHECKING
1679 #ifndef NO_CEVAL_STACK_CHECKING
1680 #define EVAL_STACK_CHECKING
1687 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1689 #define SCM_APPLY scm_dapply
1691 #define PREP_APPLY(p, l) \
1692 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1694 #define ENTER_APPLY \
1696 SCM_SET_ARGSREADY (debug);\
1697 if (CHECK_APPLY && SCM_TRAPS_P)\
1698 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1700 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1701 SCM_SET_TRACED_FRAME (debug); \
1703 if (SCM_CHEAPTRAPS_P)\
1705 tmp = scm_make_debugobj (&debug);\
1706 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1711 tmp = scm_make_continuation (&first);\
1713 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1719 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1720 #ifdef STACK_CHECKING
1721 #ifndef EVAL_STACK_CHECKING
1722 #define EVAL_STACK_CHECKING
1726 /* scm_ceval_ptr points to the currently selected evaluator.
1727 * *fixme*: Although efficiency is important here, this state variable
1728 * should probably not be a global. It should be related to the
1733 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1735 /* scm_last_debug_frame contains a pointer to the last debugging
1736 * information stack frame. It is accessed very often from the
1737 * debugging evaluator, so it should probably not be indirectly
1738 * addressed. Better to save and restore it from the current root at
1743 scm_t_debug_frame
*scm_last_debug_frame
;
1746 /* scm_debug_eframe_size is the number of slots available for pseudo
1747 * stack frames at each real stack frame.
1750 long scm_debug_eframe_size
;
1752 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1754 long scm_eval_stack
;
1756 scm_t_option scm_eval_opts
[] = {
1757 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1760 scm_t_option scm_debug_opts
[] = {
1761 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1762 "*Flyweight representation of the stack at traps." },
1763 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1764 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1765 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1766 "Record procedure names at definition." },
1767 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1768 "Display backtrace in anti-chronological order." },
1769 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1770 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1771 { SCM_OPTION_INTEGER
, "frames", 3,
1772 "Maximum number of tail-recursive frames in backtrace." },
1773 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1774 "Maximal number of stored backtrace frames." },
1775 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1776 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1777 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1778 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1779 { 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."}
1782 scm_t_option scm_evaluator_trap_table
[] = {
1783 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1784 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1785 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1786 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1787 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1788 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1789 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1792 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1794 "Option interface for the evaluation options. Instead of using\n"
1795 "this procedure directly, use the procedures @code{eval-enable},\n"
1796 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1797 #define FUNC_NAME s_scm_eval_options_interface
1801 ans
= scm_options (setting
,
1805 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1811 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1813 "Option interface for the evaluator trap options.")
1814 #define FUNC_NAME s_scm_evaluator_traps
1818 ans
= scm_options (setting
,
1819 scm_evaluator_trap_table
,
1820 SCM_N_EVALUATOR_TRAPS
,
1822 SCM_RESET_DEBUG_MODE
;
1829 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1831 SCM
*results
= lloc
, res
;
1832 while (SCM_CONSP (l
))
1834 res
= EVALCAR (l
, env
);
1836 *lloc
= scm_list_1 (res
);
1837 lloc
= SCM_CDRLOC (*lloc
);
1842 scm_wrong_num_args (proc
);
1850 /* SECTION: Some local definitions for the evaluator.
1853 /* Update the toplevel environment frame ENV so that it refers to the
1856 #define UPDATE_TOPLEVEL_ENV(env) \
1858 SCM p = scm_current_module_lookup_closure (); \
1859 if (p != SCM_CAR(env)) \
1860 env = scm_top_level_env (p); \
1864 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B)))))
1867 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1869 /* SECTION: This is the evaluator. Like any real monster, it has
1870 * three heads. This code is compiled twice.
1876 scm_ceval (SCM x
, SCM env
)
1882 scm_deval (SCM x
, SCM env
)
1887 SCM_CEVAL (SCM x
, SCM env
)
1894 SCM proc
, arg2
, orig_sym
;
1896 scm_t_debug_frame debug
;
1897 scm_t_debug_info
*debug_info_end
;
1898 debug
.prev
= scm_last_debug_frame
;
1899 debug
.status
= scm_debug_eframe_size
;
1901 * The debug.vect contains twice as much scm_t_debug_info frames as the
1902 * user has specified with (debug-set! frames <n>).
1904 * Even frames are eval frames, odd frames are apply frames.
1906 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1907 * sizeof (debug
.vect
[0]));
1908 debug
.info
= debug
.vect
;
1909 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1910 scm_last_debug_frame
= &debug
;
1912 #ifdef EVAL_STACK_CHECKING
1913 if (scm_stack_checking_enabled_p
1914 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1917 debug
.info
->e
.exp
= x
;
1918 debug
.info
->e
.env
= env
;
1920 scm_report_stack_overflow ();
1927 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1930 SCM_CLEAR_ARGSREADY (debug
);
1931 if (SCM_OVERFLOWP (debug
))
1934 * In theory, this should be the only place where it is necessary to
1935 * check for space in debug.vect since both eval frames and
1936 * available space are even.
1938 * For this to be the case, however, it is necessary that primitive
1939 * special forms which jump back to `loop', `begin' or some similar
1940 * label call PREP_APPLY. A convenient way to do this is to jump to
1941 * `loopnoap' or `cdrxnoap'.
1943 else if (++debug
.info
>= debug_info_end
)
1945 SCM_SET_OVERFLOW (debug
);
1949 debug
.info
->e
.exp
= x
;
1950 debug
.info
->e
.env
= env
;
1951 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1952 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1954 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1955 SCM_SET_TAILREC (debug
);
1956 if (SCM_CHEAPTRAPS_P
)
1957 t
.arg1
= scm_make_debugobj (&debug
);
1961 SCM val
= scm_make_continuation (&first
);
1971 /* This gives the possibility for the debugger to
1972 modify the source expression before evaluation. */
1977 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1978 scm_sym_enter_frame
,
1981 scm_unmemocopy (x
, env
));
1985 #if defined (USE_THREADS) || defined (DEVAL)
1989 switch (SCM_TYP7 (x
))
1991 case scm_tc7_symbol
:
1992 /* Only happens when called at top level.
1994 x
= scm_cons (x
, SCM_UNDEFINED
);
1995 RETURN (*scm_lookupcar (x
, env
, 1));
1997 case SCM_BIT8(SCM_IM_AND
):
1999 while (!SCM_NULLP (SCM_CDR (x
)))
2001 if (SCM_FALSEP (EVALCAR (x
, env
)))
2002 RETURN (SCM_BOOL_F
);
2006 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2009 case SCM_BIT8(SCM_IM_BEGIN
):
2010 if (SCM_NULLP (SCM_CDR (x
)))
2011 RETURN (SCM_UNSPECIFIED
);
2013 /* (currently unused)
2015 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2016 /* (currently unused)
2021 /* If we are on toplevel with a lookup closure, we need to sync
2022 with the current module. */
2023 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2025 UPDATE_TOPLEVEL_ENV (env
);
2026 while (!SCM_NULLP (SCM_CDR (x
)))
2029 UPDATE_TOPLEVEL_ENV (env
);
2035 goto nontoplevel_begin
;
2037 nontoplevel_cdrxnoap
:
2038 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2039 nontoplevel_cdrxbegin
:
2042 while (!SCM_NULLP (SCM_CDR (x
)))
2044 if (SCM_IMP (SCM_CAR (x
)))
2046 if (SCM_ISYMP (SCM_CAR (x
)))
2048 x
= scm_m_expand_body (x
, env
);
2049 goto nontoplevel_begin
;
2052 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
2055 SCM_CEVAL (SCM_CAR (x
), env
);
2059 carloop
: /* scm_eval car of last form in list */
2060 if (SCM_IMP (SCM_CAR (x
)))
2063 RETURN (SCM_EVALIM (x
, env
));
2066 if (SCM_SYMBOLP (SCM_CAR (x
)))
2067 RETURN (*scm_lookupcar (x
, env
, 1));
2070 goto loop
; /* tail recurse */
2073 case SCM_BIT8(SCM_IM_CASE
):
2075 t
.arg1
= EVALCAR (x
, env
);
2076 while (SCM_NIMP (x
= SCM_CDR (x
)))
2079 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2082 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2085 proc
= SCM_CAR (proc
);
2086 while (SCM_NIMP (proc
))
2088 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2091 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2094 proc
= SCM_CDR (proc
);
2097 RETURN (SCM_UNSPECIFIED
);
2100 case SCM_BIT8 (SCM_IM_COND
):
2102 while (!SCM_NULLP (x
))
2105 if (SCM_EQ_P (SCM_CAR (proc
), scm_sym_else
))
2108 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2111 t
.arg1
= EVALCAR (proc
, env
);
2112 if (!SCM_FALSEP (t
.arg1
))
2117 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2119 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2123 proc
= EVALCAR (proc
, env
);
2124 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2125 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2127 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2128 goto umwrongnumargs
;
2133 RETURN (SCM_UNSPECIFIED
);
2136 case SCM_BIT8(SCM_IM_DO
):
2138 proc
= SCM_CADR (x
); /* inits */
2139 t
.arg1
= SCM_EOL
; /* values */
2140 while (SCM_NIMP (proc
))
2142 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2143 proc
= SCM_CDR (proc
);
2145 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2147 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2149 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2151 t
.arg1
= SCM_CAR (proc
); /* body */
2152 SIDEVAL (t
.arg1
, env
);
2154 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2156 proc
= SCM_CDR (proc
))
2157 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2158 env
= EXTEND_ENV (SCM_CAAR (env
), t
.arg1
, SCM_CDR (env
));
2162 RETURN (SCM_UNSPECIFIED
);
2163 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2164 goto nontoplevel_begin
;
2167 case SCM_BIT8(SCM_IM_IF
):
2169 if (!SCM_FALSEP (EVALCAR (x
, env
)))
2171 else if (SCM_IMP (x
= SCM_CDDR (x
)))
2172 RETURN (SCM_UNSPECIFIED
);
2173 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2177 case SCM_BIT8(SCM_IM_LET
):
2179 proc
= SCM_CADR (x
);
2183 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2185 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2186 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2188 goto nontoplevel_cdrxnoap
;
2191 case SCM_BIT8(SCM_IM_LETREC
):
2193 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2199 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2201 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2202 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2203 goto nontoplevel_cdrxnoap
;
2206 case SCM_BIT8(SCM_IM_LETSTAR
):
2209 SCM bindings
= SCM_CAR (x
);
2210 if (SCM_NULLP (bindings
))
2211 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2216 SCM name
= SCM_CAR (bindings
);
2217 SCM init
= SCM_CDR (bindings
);
2218 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2219 bindings
= SCM_CDR (init
);
2221 while (!SCM_NULLP (bindings
));
2224 goto nontoplevel_cdrxnoap
;
2227 case SCM_BIT8(SCM_IM_OR
):
2229 while (!SCM_NULLP (SCM_CDR (x
)))
2231 SCM val
= EVALCAR (x
, env
);
2232 if (!SCM_FALSEP (val
))
2237 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2241 case SCM_BIT8(SCM_IM_LAMBDA
):
2242 RETURN (scm_closure (SCM_CDR (x
), env
));
2245 case SCM_BIT8(SCM_IM_QUOTE
):
2246 RETURN (SCM_CADR (x
));
2249 case SCM_BIT8(SCM_IM_SET_X
):
2252 switch (SCM_ITAG3 (proc
))
2255 if (SCM_VARIABLEP (proc
))
2256 t
.lloc
= SCM_VARIABLE_LOC (proc
);
2258 t
.lloc
= scm_lookupcar (x
, env
, 1);
2260 #ifdef MEMOIZE_LOCALS
2262 t
.lloc
= scm_ilookup (proc
, env
);
2267 *t
.lloc
= EVALCAR (x
, env
);
2271 RETURN (SCM_UNSPECIFIED
);
2275 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2276 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2278 /* new syntactic forms go here. */
2279 case SCM_BIT8(SCM_MAKISYM (0)):
2281 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2282 switch SCM_ISYMNUM (proc
)
2284 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2286 proc
= EVALCAR (proc
, env
);
2287 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2288 if (SCM_CLOSUREP (proc
))
2291 PREP_APPLY (proc
, SCM_EOL
);
2292 t
.arg1
= SCM_CDDR (x
);
2293 t
.arg1
= EVALCAR (t
.arg1
, env
);
2295 /* Go here to tail-call a closure. PROC is the closure
2296 and T.ARG1 is the list of arguments. Do not forget to
2299 debug
.info
->a
.args
= t
.arg1
;
2301 #ifndef SCM_RECKLESS
2302 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2306 /* Copy argument list */
2307 if (SCM_IMP (t
.arg1
))
2311 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2312 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2313 && SCM_CONSP (t
.arg1
))
2315 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2319 SCM_SETCDR (tl
, t
.arg1
);
2322 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2323 x
= SCM_CLOSURE_BODY (proc
);
2324 goto nontoplevel_begin
;
2329 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2332 SCM val
= scm_make_continuation (&first
);
2340 proc
= scm_eval_car (proc
, env
);
2341 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2342 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2344 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2345 goto umwrongnumargs
;
2348 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2349 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2351 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2352 proc
= SCM_CADR (x
); /* unevaluated operands */
2353 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2355 arg2
= *scm_ilookup (proc
, env
);
2356 else if (!SCM_CONSP (proc
))
2358 if (SCM_VARIABLEP (proc
))
2359 arg2
= SCM_VARIABLE_REF (proc
);
2361 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2365 arg2
= scm_list_1 (EVALCAR (proc
, env
));
2366 t
.lloc
= SCM_CDRLOC (arg2
);
2367 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2369 *t
.lloc
= scm_list_1 (EVALCAR (proc
, env
));
2370 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2375 /* The type dispatch code is duplicated here
2376 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2377 * cuts down execution time for type dispatch to 50%.
2380 long i
, n
, end
, mask
;
2381 SCM z
= SCM_CDDR (x
);
2382 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2383 proc
= SCM_CADR (z
);
2385 if (SCM_NIMP (proc
))
2387 /* Prepare for linear search */
2390 end
= SCM_VECTOR_LENGTH (proc
);
2394 /* Compute a hash value */
2395 long hashset
= SCM_INUM (proc
);
2398 mask
= SCM_INUM (SCM_CAR (z
));
2399 proc
= SCM_CADR (z
);
2402 if (SCM_NIMP (t
.arg1
))
2405 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2406 [scm_si_hashsets
+ hashset
];
2407 t
.arg1
= SCM_CDR (t
.arg1
);
2409 while (j
-- && SCM_NIMP (t
.arg1
));
2414 /* Search for match */
2418 z
= SCM_VELTS (proc
)[i
];
2419 t
.arg1
= arg2
; /* list of arguments */
2420 if (SCM_NIMP (t
.arg1
))
2423 /* More arguments than specifiers => CLASS != ENV */
2424 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2426 t
.arg1
= SCM_CDR (t
.arg1
);
2429 while (j
-- && SCM_NIMP (t
.arg1
));
2430 /* Fewer arguments than specifiers => CAR != ENV */
2431 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2434 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2436 SCM_CMETHOD_ENV (z
));
2437 x
= SCM_CMETHOD_CODE (z
);
2438 goto nontoplevel_cdrxbegin
;
2443 z
= scm_memoize_method (x
, arg2
);
2447 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2449 t
.arg1
= EVALCAR (x
, env
);
2450 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]));
2452 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2454 t
.arg1
= EVALCAR (x
, env
);
2457 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2458 = SCM_UNPACK (EVALCAR (proc
, env
));
2459 RETURN (SCM_UNSPECIFIED
);
2461 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2463 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2465 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2466 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2468 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2470 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2476 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2479 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2481 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2485 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2487 RETURN (!SCM_FALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
);
2489 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2491 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2493 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2494 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2496 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2498 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2504 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2507 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2509 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2513 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2515 RETURN (!SCM_FALSEP (EVALCAR (x
, env
))
2519 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2521 SCM vars
, exps
, vals
;
2524 vars
= SCM_CAAR (x
);
2525 exps
= SCM_CDAR (x
);
2529 while (SCM_NIMP (exps
))
2531 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2532 exps
= SCM_CDR (exps
);
2535 scm_swap_bindings (vars
, vals
);
2536 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2538 arg2
= x
= SCM_CDR (x
);
2539 while (!SCM_NULLP (arg2
= SCM_CDR (arg2
)))
2541 SIDEVAL (SCM_CAR (x
), env
);
2544 proc
= EVALCAR (x
, env
);
2546 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2547 scm_swap_bindings (vars
, vals
);
2552 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2555 x
= EVALCAR (proc
, env
);
2556 proc
= SCM_CDR (proc
);
2557 proc
= EVALCAR (proc
, env
);
2558 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2559 if (SCM_VALUESP (t
.arg1
))
2560 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2562 t
.arg1
= scm_list_1 (t
.arg1
);
2563 if (SCM_CLOSUREP (proc
))
2565 PREP_APPLY (proc
, t
.arg1
);
2568 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2578 /* scm_everr (x, env,...) */
2579 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2580 case scm_tc7_vector
:
2584 case scm_tc7_byvect
:
2591 #ifdef HAVE_LONG_LONGS
2592 case scm_tc7_llvect
:
2595 case scm_tc7_string
:
2597 case scm_tcs_closures
:
2601 case scm_tcs_struct
:
2604 case scm_tc7_variable
:
2605 RETURN (SCM_VARIABLE_REF(x
));
2607 #ifdef MEMOIZE_LOCALS
2608 case SCM_BIT8(SCM_ILOC00
):
2609 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2610 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2611 #ifndef SCM_RECKLESS
2617 #endif /* ifdef MEMOIZE_LOCALS */
2619 case scm_tcs_cons_nimcar
:
2620 orig_sym
= SCM_CAR (x
);
2621 if (SCM_SYMBOLP (orig_sym
))
2624 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2627 /* we have lost the race, start again. */
2632 proc
= *scm_lookupcar (x
, env
, 1);
2637 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2641 if (SCM_MACROP (proc
))
2643 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2647 /* Set a flag during macro expansion so that macro
2648 application frames can be deleted from the backtrace. */
2649 SCM_SET_MACROEXP (debug
);
2651 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2652 scm_cons (env
, scm_listofnull
));
2655 SCM_CLEAR_MACROEXP (debug
);
2657 switch (SCM_MACRO_TYPE (proc
))
2660 if (scm_ilength (t
.arg1
) <= 0)
2661 t
.arg1
= scm_list_2 (SCM_IM_BEGIN
, t
.arg1
);
2663 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2666 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2667 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2671 /* Prevent memoizing of debug info expression. */
2672 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2677 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2678 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2682 if (SCM_NIMP (x
= t
.arg1
))
2690 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2691 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2692 #ifndef SCM_RECKLESS
2696 if (SCM_CLOSUREP (proc
))
2698 arg2
= SCM_CLOSURE_FORMALS (proc
);
2699 t
.arg1
= SCM_CDR (x
);
2700 while (!SCM_NULLP (arg2
))
2702 if (!SCM_CONSP (arg2
))
2704 if (SCM_IMP (t
.arg1
))
2705 goto umwrongnumargs
;
2706 arg2
= SCM_CDR (arg2
);
2707 t
.arg1
= SCM_CDR (t
.arg1
);
2709 if (!SCM_NULLP (t
.arg1
))
2710 goto umwrongnumargs
;
2712 else if (SCM_MACROP (proc
))
2713 goto handle_a_macro
;
2719 PREP_APPLY (proc
, SCM_EOL
);
2720 if (SCM_NULLP (SCM_CDR (x
))) {
2723 switch (SCM_TYP7 (proc
))
2724 { /* no arguments given */
2725 case scm_tc7_subr_0
:
2726 RETURN (SCM_SUBRF (proc
) ());
2727 case scm_tc7_subr_1o
:
2728 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2730 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2731 case scm_tc7_rpsubr
:
2732 RETURN (SCM_BOOL_T
);
2734 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2736 if (!SCM_SMOB_APPLICABLE_P (proc
))
2738 RETURN (SCM_SMOB_APPLY_0 (proc
));
2741 proc
= SCM_CCLO_SUBR (proc
);
2743 debug
.info
->a
.proc
= proc
;
2744 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2748 proc
= SCM_PROCEDURE (proc
);
2750 debug
.info
->a
.proc
= proc
;
2752 if (!SCM_CLOSUREP (proc
))
2754 if (scm_badformalsp (proc
, 0))
2755 goto umwrongnumargs
;
2756 case scm_tcs_closures
:
2757 x
= SCM_CLOSURE_BODY (proc
);
2758 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2759 goto nontoplevel_begin
;
2760 case scm_tcs_struct
:
2761 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2763 x
= SCM_ENTITY_PROCEDURE (proc
);
2767 else if (!SCM_I_OPERATORP (proc
))
2772 proc
= (SCM_I_ENTITYP (proc
)
2773 ? SCM_ENTITY_PROCEDURE (proc
)
2774 : SCM_OPERATOR_PROCEDURE (proc
));
2776 debug
.info
->a
.proc
= proc
;
2777 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2779 if (SCM_NIMP (proc
))
2784 case scm_tc7_subr_1
:
2785 case scm_tc7_subr_2
:
2786 case scm_tc7_subr_2o
:
2788 case scm_tc7_subr_3
:
2789 case scm_tc7_lsubr_2
:
2793 /* scm_everr (x, env,...) */
2794 scm_wrong_num_args (proc
);
2796 /* handle macros here */
2801 /* must handle macros by here */
2806 else if (SCM_CONSP (x
))
2808 if (SCM_IMP (SCM_CAR (x
)))
2809 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2811 t
.arg1
= EVALCELLCAR (x
, env
);
2816 t
.arg1
= EVALCAR (x
, env
);
2819 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2826 switch (SCM_TYP7 (proc
))
2827 { /* have one argument in t.arg1 */
2828 case scm_tc7_subr_2o
:
2829 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2830 case scm_tc7_subr_1
:
2831 case scm_tc7_subr_1o
:
2832 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2834 if (SCM_SUBRF (proc
))
2836 if (SCM_INUMP (t
.arg1
))
2838 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2840 else if (SCM_REALP (t
.arg1
))
2842 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2845 else if (SCM_BIGP (t
.arg1
))
2847 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2850 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2851 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2853 proc
= SCM_SNAME (proc
);
2855 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2856 while ('c' != *--chrs
)
2858 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2859 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2860 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2864 case scm_tc7_rpsubr
:
2865 RETURN (SCM_BOOL_T
);
2867 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2870 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2872 RETURN (SCM_SUBRF (proc
) (scm_list_1 (t
.arg1
)));
2875 if (!SCM_SMOB_APPLICABLE_P (proc
))
2877 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2881 proc
= SCM_CCLO_SUBR (proc
);
2883 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2884 debug
.info
->a
.proc
= proc
;
2888 proc
= SCM_PROCEDURE (proc
);
2890 debug
.info
->a
.proc
= proc
;
2892 if (!SCM_CLOSUREP (proc
))
2894 if (scm_badformalsp (proc
, 1))
2895 goto umwrongnumargs
;
2896 case scm_tcs_closures
:
2898 x
= SCM_CLOSURE_BODY (proc
);
2900 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2902 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (t
.arg1
), SCM_ENV (proc
));
2904 goto nontoplevel_begin
;
2905 case scm_tcs_struct
:
2906 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2908 x
= SCM_ENTITY_PROCEDURE (proc
);
2910 arg2
= debug
.info
->a
.args
;
2912 arg2
= scm_list_1 (t
.arg1
);
2916 else if (!SCM_I_OPERATORP (proc
))
2922 proc
= (SCM_I_ENTITYP (proc
)
2923 ? SCM_ENTITY_PROCEDURE (proc
)
2924 : SCM_OPERATOR_PROCEDURE (proc
));
2926 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2927 debug
.info
->a
.proc
= proc
;
2929 if (SCM_NIMP (proc
))
2934 case scm_tc7_subr_2
:
2935 case scm_tc7_subr_0
:
2936 case scm_tc7_subr_3
:
2937 case scm_tc7_lsubr_2
:
2946 else if (SCM_CONSP (x
))
2948 if (SCM_IMP (SCM_CAR (x
)))
2949 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2951 arg2
= EVALCELLCAR (x
, env
);
2956 arg2
= EVALCAR (x
, env
);
2958 { /* have two or more arguments */
2960 debug
.info
->a
.args
= scm_list_2 (t
.arg1
, arg2
);
2963 if (SCM_NULLP (x
)) {
2966 switch (SCM_TYP7 (proc
))
2967 { /* have two arguments */
2968 case scm_tc7_subr_2
:
2969 case scm_tc7_subr_2o
:
2970 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2973 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2975 RETURN (SCM_SUBRF (proc
) (scm_list_2 (t
.arg1
, arg2
)));
2977 case scm_tc7_lsubr_2
:
2978 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2979 case scm_tc7_rpsubr
:
2981 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2983 if (!SCM_SMOB_APPLICABLE_P (proc
))
2985 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2989 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2990 scm_cons (proc
, debug
.info
->a
.args
),
2993 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2994 scm_cons2 (proc
, t
.arg1
,
3001 case scm_tcs_struct
:
3002 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3004 x
= SCM_ENTITY_PROCEDURE (proc
);
3006 arg2
= debug
.info
->a
.args
;
3008 arg2
= scm_list_2 (t
.arg1
, arg2
);
3012 else if (!SCM_I_OPERATORP (proc
))
3018 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3019 ? SCM_ENTITY_PROCEDURE (proc
)
3020 : SCM_OPERATOR_PROCEDURE (proc
),
3021 scm_cons (proc
, debug
.info
->a
.args
),
3024 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3025 ? SCM_ENTITY_PROCEDURE (proc
)
3026 : SCM_OPERATOR_PROCEDURE (proc
),
3027 scm_cons2 (proc
, t
.arg1
,
3035 case scm_tc7_subr_0
:
3037 case scm_tc7_subr_1o
:
3038 case scm_tc7_subr_1
:
3039 case scm_tc7_subr_3
:
3044 proc
= SCM_PROCEDURE (proc
);
3046 debug
.info
->a
.proc
= proc
;
3048 if (!SCM_CLOSUREP (proc
))
3050 if (scm_badformalsp (proc
, 2))
3051 goto umwrongnumargs
;
3052 case scm_tcs_closures
:
3055 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3059 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3060 scm_list_2 (t
.arg1
, arg2
), SCM_ENV (proc
));
3062 x
= SCM_CLOSURE_BODY (proc
);
3063 goto nontoplevel_begin
;
3067 if (SCM_IMP (x
) || !SCM_CONSP (x
))
3071 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3072 scm_deval_args (x
, env
, proc
,
3073 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3077 switch (SCM_TYP7 (proc
))
3078 { /* have 3 or more arguments */
3080 case scm_tc7_subr_3
:
3081 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3082 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3083 SCM_CADDR (debug
.info
->a
.args
)));
3085 #ifdef BUILTIN_RPASUBR
3086 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3087 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3090 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3091 arg2
= SCM_CDR (arg2
);
3093 while (SCM_NIMP (arg2
));
3095 #endif /* BUILTIN_RPASUBR */
3096 case scm_tc7_rpsubr
:
3097 #ifdef BUILTIN_RPASUBR
3098 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3099 RETURN (SCM_BOOL_F
);
3100 t
.arg1
= SCM_CDDR (debug
.info
->a
.args
);
3103 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3104 RETURN (SCM_BOOL_F
);
3105 arg2
= SCM_CAR (t
.arg1
);
3106 t
.arg1
= SCM_CDR (t
.arg1
);
3108 while (SCM_NIMP (t
.arg1
));
3109 RETURN (SCM_BOOL_T
);
3110 #else /* BUILTIN_RPASUBR */
3111 RETURN (SCM_APPLY (proc
, t
.arg1
,
3113 SCM_CDDR (debug
.info
->a
.args
),
3115 #endif /* BUILTIN_RPASUBR */
3116 case scm_tc7_lsubr_2
:
3117 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3118 SCM_CDDR (debug
.info
->a
.args
)));
3120 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3122 if (!SCM_SMOB_APPLICABLE_P (proc
))
3124 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3125 SCM_CDDR (debug
.info
->a
.args
)));
3129 proc
= SCM_PROCEDURE (proc
);
3130 debug
.info
->a
.proc
= proc
;
3131 if (!SCM_CLOSUREP (proc
))
3133 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3134 goto umwrongnumargs
;
3135 case scm_tcs_closures
:
3136 SCM_SET_ARGSREADY (debug
);
3137 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3140 x
= SCM_CLOSURE_BODY (proc
);
3141 goto nontoplevel_begin
;
3143 case scm_tc7_subr_3
:
3144 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3145 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3147 #ifdef BUILTIN_RPASUBR
3148 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3151 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3154 while (SCM_NIMP (x
));
3156 #endif /* BUILTIN_RPASUBR */
3157 case scm_tc7_rpsubr
:
3158 #ifdef BUILTIN_RPASUBR
3159 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3160 RETURN (SCM_BOOL_F
);
3163 t
.arg1
= EVALCAR (x
, env
);
3164 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3165 RETURN (SCM_BOOL_F
);
3169 while (SCM_NIMP (x
));
3170 RETURN (SCM_BOOL_T
);
3171 #else /* BUILTIN_RPASUBR */
3172 RETURN (SCM_APPLY (proc
, t
.arg1
,
3174 scm_eval_args (x
, env
, proc
),
3176 #endif /* BUILTIN_RPASUBR */
3177 case scm_tc7_lsubr_2
:
3178 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3180 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3182 scm_eval_args (x
, env
, proc
))));
3184 if (!SCM_SMOB_APPLICABLE_P (proc
))
3186 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3187 scm_eval_args (x
, env
, proc
)));
3191 proc
= SCM_PROCEDURE (proc
);
3192 if (!SCM_CLOSUREP (proc
))
3195 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3196 if (SCM_NULLP (formals
)
3197 || (SCM_CONSP (formals
)
3198 && (SCM_NULLP (SCM_CDR (formals
))
3199 || (SCM_CONSP (SCM_CDR (formals
))
3200 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3201 goto umwrongnumargs
;
3203 case scm_tcs_closures
:
3205 SCM_SET_ARGSREADY (debug
);
3207 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3210 scm_eval_args (x
, env
, proc
)),
3212 x
= SCM_CLOSURE_BODY (proc
);
3213 goto nontoplevel_begin
;
3215 case scm_tcs_struct
:
3216 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3219 arg2
= debug
.info
->a
.args
;
3221 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3223 x
= SCM_ENTITY_PROCEDURE (proc
);
3226 else if (!SCM_I_OPERATORP (proc
))
3230 case scm_tc7_subr_2
:
3231 case scm_tc7_subr_1o
:
3232 case scm_tc7_subr_2o
:
3233 case scm_tc7_subr_0
:
3235 case scm_tc7_subr_1
:
3243 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3244 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3246 SCM_CLEAR_TRACED_FRAME (debug
);
3247 if (SCM_CHEAPTRAPS_P
)
3248 t
.arg1
= scm_make_debugobj (&debug
);
3252 SCM val
= scm_make_continuation (&first
);
3263 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3267 scm_last_debug_frame
= debug
.prev
;
3273 /* SECTION: This code is compiled once.
3279 /* Simple procedure calls
3283 scm_call_0 (SCM proc
)
3285 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3289 scm_call_1 (SCM proc
, SCM arg1
)
3291 return scm_apply (proc
, arg1
, scm_listofnull
);
3295 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3297 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3301 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3303 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3307 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3309 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3310 scm_cons (arg4
, scm_listofnull
)));
3313 /* Simple procedure applies
3317 scm_apply_0 (SCM proc
, SCM args
)
3319 return scm_apply (proc
, args
, SCM_EOL
);
3323 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3325 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3329 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3331 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3335 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3337 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3341 /* This code processes the arguments to apply:
3343 (apply PROC ARG1 ... ARGS)
3345 Given a list (ARG1 ... ARGS), this function conses the ARG1
3346 ... arguments onto the front of ARGS, and returns the resulting
3347 list. Note that ARGS is a list; thus, the argument to this
3348 function is a list whose last element is a list.
3350 Apply calls this function, and applies PROC to the elements of the
3351 result. apply:nconc2last takes care of building the list of
3352 arguments, given (ARG1 ... ARGS).
3354 Rather than do new consing, apply:nconc2last destroys its argument.
3355 On that topic, this code came into my care with the following
3356 beautifully cryptic comment on that topic: "This will only screw
3357 you if you do (scm_apply scm_apply '( ... ))" If you know what
3358 they're referring to, send me a patch to this comment. */
3360 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3362 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3363 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3364 "@var{args}, and returns the resulting list. Note that\n"
3365 "@var{args} is a list; thus, the argument to this function is\n"
3366 "a list whose last element is a list.\n"
3367 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3368 "destroys its argument, so use with care.")
3369 #define FUNC_NAME s_scm_nconc2last
3372 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3374 while (!SCM_NULLP (SCM_CDR (*lloc
)))
3375 lloc
= SCM_CDRLOC (*lloc
);
3376 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3377 *lloc
= SCM_CAR (*lloc
);
3385 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3386 * It is compiled twice.
3392 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3399 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3404 /* Apply a function to a list of arguments.
3406 This function is exported to the Scheme level as taking two
3407 required arguments and a tail argument, as if it were:
3408 (lambda (proc arg1 . args) ...)
3409 Thus, if you just have a list of arguments to pass to a procedure,
3410 pass the list as ARG1, and '() for ARGS. If you have some fixed
3411 args, pass the first as ARG1, then cons any remaining fixed args
3412 onto the front of your argument list, and pass that as ARGS. */
3415 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3417 #ifdef DEBUG_EXTENSIONS
3419 scm_t_debug_frame debug
;
3420 scm_t_debug_info debug_vect_body
;
3421 debug
.prev
= scm_last_debug_frame
;
3422 debug
.status
= SCM_APPLYFRAME
;
3423 debug
.vect
= &debug_vect_body
;
3424 debug
.vect
[0].a
.proc
= proc
;
3425 debug
.vect
[0].a
.args
= SCM_EOL
;
3426 scm_last_debug_frame
= &debug
;
3429 return scm_dapply (proc
, arg1
, args
);
3433 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3435 /* If ARGS is the empty list, then we're calling apply with only two
3436 arguments --- ARG1 is the list of arguments for PROC. Whatever
3437 the case, futz with things so that ARG1 is the first argument to
3438 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3441 Setting the debug apply frame args this way is pretty messy.
3442 Perhaps we should store arg1 and args directly in the frame as
3443 received, and let scm_frame_arguments unpack them, because that's
3444 a relatively rare operation. This works for now; if the Guile
3445 developer archives are still around, see Mikael's post of
3447 if (SCM_NULLP (args
))
3449 if (SCM_NULLP (arg1
))
3451 arg1
= SCM_UNDEFINED
;
3453 debug
.vect
[0].a
.args
= SCM_EOL
;
3459 debug
.vect
[0].a
.args
= arg1
;
3461 args
= SCM_CDR (arg1
);
3462 arg1
= SCM_CAR (arg1
);
3467 args
= scm_nconc2last (args
);
3469 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3473 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3476 if (SCM_CHEAPTRAPS_P
)
3477 tmp
= scm_make_debugobj (&debug
);
3482 tmp
= scm_make_continuation (&first
);
3487 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3494 switch (SCM_TYP7 (proc
))
3496 case scm_tc7_subr_2o
:
3497 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3498 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3499 case scm_tc7_subr_2
:
3500 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3502 args
= SCM_CAR (args
);
3503 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3504 case scm_tc7_subr_0
:
3505 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3506 RETURN (SCM_SUBRF (proc
) ());
3507 case scm_tc7_subr_1
:
3508 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3509 case scm_tc7_subr_1o
:
3510 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3511 RETURN (SCM_SUBRF (proc
) (arg1
));
3513 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3514 if (SCM_SUBRF (proc
))
3516 if (SCM_INUMP (arg1
))
3518 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3520 else if (SCM_REALP (arg1
))
3522 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3525 else if (SCM_BIGP (arg1
))
3526 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3528 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3529 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3531 proc
= SCM_SNAME (proc
);
3533 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3534 while ('c' != *--chrs
)
3536 SCM_ASSERT (SCM_CONSP (arg1
),
3537 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3538 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3542 case scm_tc7_subr_3
:
3543 SCM_ASRTGO (!SCM_NULLP (args
)
3544 && !SCM_NULLP (SCM_CDR (args
))
3545 && SCM_NULLP (SCM_CDDR (args
)),
3547 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3550 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3552 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3554 case scm_tc7_lsubr_2
:
3555 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3556 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3558 if (SCM_NULLP (args
))
3559 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3560 while (SCM_NIMP (args
))
3562 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3563 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3564 args
= SCM_CDR (args
);
3567 case scm_tc7_rpsubr
:
3568 if (SCM_NULLP (args
))
3569 RETURN (SCM_BOOL_T
);
3570 while (SCM_NIMP (args
))
3572 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3573 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3574 RETURN (SCM_BOOL_F
);
3575 arg1
= SCM_CAR (args
);
3576 args
= SCM_CDR (args
);
3578 RETURN (SCM_BOOL_T
);
3579 case scm_tcs_closures
:
3581 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3583 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3585 #ifndef SCM_RECKLESS
3586 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3590 /* Copy argument list */
3595 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3596 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3598 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3602 SCM_SETCDR (tl
, arg1
);
3605 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3606 proc
= SCM_CLOSURE_BODY (proc
);
3609 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3611 if (SCM_IMP (SCM_CAR (proc
)))
3613 if (SCM_ISYMP (SCM_CAR (proc
)))
3615 proc
= scm_m_expand_body (proc
, args
);
3619 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3622 SCM_CEVAL (SCM_CAR (proc
), args
);
3625 RETURN (EVALCAR (proc
, args
));
3627 if (!SCM_SMOB_APPLICABLE_P (proc
))
3629 if (SCM_UNBNDP (arg1
))
3630 RETURN (SCM_SMOB_APPLY_0 (proc
));
3631 else if (SCM_NULLP (args
))
3632 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3633 else if (SCM_NULLP (SCM_CDR (args
)))
3634 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3636 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3639 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3641 proc
= SCM_CCLO_SUBR (proc
);
3642 debug
.vect
[0].a
.proc
= proc
;
3643 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3645 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3647 proc
= SCM_CCLO_SUBR (proc
);
3651 proc
= SCM_PROCEDURE (proc
);
3653 debug
.vect
[0].a
.proc
= proc
;
3656 case scm_tcs_struct
:
3657 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3660 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3662 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3664 RETURN (scm_apply_generic (proc
, args
));
3666 else if (!SCM_I_OPERATORP (proc
))
3671 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3673 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3676 proc
= (SCM_I_ENTITYP (proc
)
3677 ? SCM_ENTITY_PROCEDURE (proc
)
3678 : SCM_OPERATOR_PROCEDURE (proc
));
3680 debug
.vect
[0].a
.proc
= proc
;
3681 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3683 if (SCM_NIMP (proc
))
3689 scm_wrong_num_args (proc
);
3692 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3697 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3698 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3700 SCM_CLEAR_TRACED_FRAME (debug
);
3701 if (SCM_CHEAPTRAPS_P
)
3702 arg1
= scm_make_debugobj (&debug
);
3706 SCM val
= scm_make_continuation (&first
);
3717 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3721 scm_last_debug_frame
= debug
.prev
;
3727 /* SECTION: The rest of this file is only read once.
3732 /* Typechecking for multi-argument MAP and FOR-EACH.
3734 Verify that each element of the vector ARGV, except for the first,
3735 is a proper list whose length is LEN. Attribute errors to WHO,
3736 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3738 check_map_args (SCM argv
,
3745 SCM
*ve
= SCM_VELTS (argv
);
3748 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3750 long elt_len
= scm_ilength (ve
[i
]);
3755 scm_apply_generic (gf
, scm_cons (proc
, args
));
3757 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3761 scm_out_of_range (who
, ve
[i
]);
3764 scm_remember_upto_here_1 (argv
);
3768 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3770 /* Note: Currently, scm_map applies PROC to the argument list(s)
3771 sequentially, starting with the first element(s). This is used in
3772 evalext.c where the Scheme procedure `map-in-order', which guarantees
3773 sequential behaviour, is implemented using scm_map. If the
3774 behaviour changes, we need to update `map-in-order'.
3778 scm_map (SCM proc
, SCM arg1
, SCM args
)
3779 #define FUNC_NAME s_map
3784 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3786 len
= scm_ilength (arg1
);
3787 SCM_GASSERTn (len
>= 0,
3788 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3789 SCM_VALIDATE_REST_ARGUMENT (args
);
3790 if (SCM_NULLP (args
))
3792 while (SCM_NIMP (arg1
))
3794 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3795 pres
= SCM_CDRLOC (*pres
);
3796 arg1
= SCM_CDR (arg1
);
3800 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3801 ve
= SCM_VELTS (args
);
3802 #ifndef SCM_RECKLESS
3803 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3808 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3810 if (SCM_IMP (ve
[i
]))
3812 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3813 ve
[i
] = SCM_CDR (ve
[i
]);
3815 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3816 pres
= SCM_CDRLOC (*pres
);
3822 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3825 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3826 #define FUNC_NAME s_for_each
3828 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3830 len
= scm_ilength (arg1
);
3831 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3832 SCM_ARG2
, s_for_each
);
3833 SCM_VALIDATE_REST_ARGUMENT (args
);
3836 while SCM_NIMP (arg1
)
3838 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3839 arg1
= SCM_CDR (arg1
);
3841 return SCM_UNSPECIFIED
;
3843 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3844 ve
= SCM_VELTS (args
);
3845 #ifndef SCM_RECKLESS
3846 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3851 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3854 (ve
[i
]) return SCM_UNSPECIFIED
;
3855 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3856 ve
[i
] = SCM_CDR (ve
[i
]);
3858 scm_apply (proc
, arg1
, SCM_EOL
);
3865 scm_closure (SCM code
, SCM env
)
3868 SCM closcar
= scm_cons (code
, SCM_EOL
);
3869 z
= scm_alloc_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
,
3871 scm_remember_upto_here (closcar
);
3876 scm_t_bits scm_tc16_promise
;
3879 scm_makprom (SCM code
)
3881 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3887 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3889 int writingp
= SCM_WRITINGP (pstate
);
3890 scm_puts ("#<promise ", port
);
3891 SCM_SET_WRITINGP (pstate
, 1);
3892 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3893 SCM_SET_WRITINGP (pstate
, writingp
);
3894 scm_putc ('>', port
);
3899 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3901 "If the promise @var{x} has not been computed yet, compute and\n"
3902 "return @var{x}, otherwise just return the previously computed\n"
3904 #define FUNC_NAME s_scm_force
3906 SCM_VALIDATE_SMOB (1, x
, promise
);
3907 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3909 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3910 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3913 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3914 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3918 return SCM_CELL_OBJECT_1 (x
);
3923 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3925 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3926 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3927 #define FUNC_NAME s_scm_promise_p
3929 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3934 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3935 (SCM xorig
, SCM x
, SCM y
),
3936 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3937 "Any source properties associated with @var{xorig} are also associated\n"
3938 "with the new pair.")
3939 #define FUNC_NAME s_scm_cons_source
3942 z
= scm_cons (x
, y
);
3943 /* Copy source properties possibly associated with xorig. */
3944 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3946 scm_whash_insert (scm_source_whash
, z
, p
);
3952 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3954 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3955 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3956 "contents of both pairs and vectors (since both cons cells and vector\n"
3957 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3958 "any other object.")
3959 #define FUNC_NAME s_scm_copy_tree
3964 if (SCM_VECTORP (obj
))
3966 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3967 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3969 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3972 if (!SCM_CONSP (obj
))
3974 ans
= tl
= scm_cons_source (obj
,
3975 scm_copy_tree (SCM_CAR (obj
)),
3977 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3979 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3983 SCM_SETCDR (tl
, obj
);
3989 /* We have three levels of EVAL here:
3991 - scm_i_eval (exp, env)
3993 evaluates EXP in environment ENV. ENV is a lexical environment
3994 structure as used by the actual tree code evaluator. When ENV is
3995 a top-level environment, then changes to the current module are
3996 tracked by updating ENV so that it continues to be in sync with
3999 - scm_primitive_eval (exp)
4001 evaluates EXP in the top-level environment as determined by the
4002 current module. This is done by constructing a suitable
4003 environment and calling scm_i_eval. Thus, changes to the
4004 top-level module are tracked normally.
4006 - scm_eval (exp, mod)
4008 evaluates EXP while MOD is the current module. This is done by
4009 setting the current module to MOD, invoking scm_primitive_eval on
4010 EXP, and then restoring the current module to the value it had
4011 previously. That is, while EXP is evaluated, changes to the
4012 current module are tracked, but these changes do not persist when
4015 For each level of evals, there are two variants, distinguished by a
4016 _x suffix: the ordinary variant does not modify EXP while the _x
4017 variant can destructively modify EXP into something completely
4018 unintelligible. A Scheme data structure passed as EXP to one of the
4019 _x variants should not ever be used again for anything. So when in
4020 doubt, use the ordinary variant.
4025 scm_i_eval_x (SCM exp
, SCM env
)
4027 return SCM_XEVAL (exp
, env
);
4031 scm_i_eval (SCM exp
, SCM env
)
4033 exp
= scm_copy_tree (exp
);
4034 return SCM_XEVAL (exp
, env
);
4038 scm_primitive_eval_x (SCM exp
)
4041 SCM transformer
= scm_current_module_transformer ();
4042 if (SCM_NIMP (transformer
))
4043 exp
= scm_call_1 (transformer
, exp
);
4044 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4045 return scm_i_eval_x (exp
, env
);
4048 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4050 "Evaluate @var{exp} in the top-level environment specified by\n"
4051 "the current module.")
4052 #define FUNC_NAME s_scm_primitive_eval
4055 SCM transformer
= scm_current_module_transformer ();
4056 if (SCM_NIMP (transformer
))
4057 exp
= scm_call_1 (transformer
, exp
);
4058 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4059 return scm_i_eval (exp
, env
);
4063 /* Eval does not take the second arg optionally. This is intentional
4064 * in order to be R5RS compatible, and to prepare for the new module
4065 * system, where we would like to make the choice of evaluation
4066 * environment explicit. */
4069 change_environment (void *data
)
4071 SCM pair
= SCM_PACK (data
);
4072 SCM new_module
= SCM_CAR (pair
);
4073 SCM old_module
= scm_current_module ();
4074 SCM_SETCDR (pair
, old_module
);
4075 scm_set_current_module (new_module
);
4080 restore_environment (void *data
)
4082 SCM pair
= SCM_PACK (data
);
4083 SCM old_module
= SCM_CDR (pair
);
4084 SCM new_module
= scm_current_module ();
4085 SCM_SETCAR (pair
, new_module
);
4086 scm_set_current_module (old_module
);
4090 inner_eval_x (void *data
)
4092 return scm_primitive_eval_x (SCM_PACK(data
));
4096 scm_eval_x (SCM exp
, SCM module
)
4097 #define FUNC_NAME "eval!"
4099 SCM_VALIDATE_MODULE (2, module
);
4101 return scm_internal_dynamic_wind
4102 (change_environment
, inner_eval_x
, restore_environment
,
4103 (void *) SCM_UNPACK (exp
),
4104 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4109 inner_eval (void *data
)
4111 return scm_primitive_eval (SCM_PACK(data
));
4114 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4115 (SCM exp
, SCM module
),
4116 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4117 "in the top-level environment specified by @var{module}.\n"
4118 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4119 "@var{module} is made the current module. The current module\n"
4120 "is reset to its previous value when @var{eval} returns.")
4121 #define FUNC_NAME s_scm_eval
4123 SCM_VALIDATE_MODULE (2, module
);
4125 return scm_internal_dynamic_wind
4126 (change_environment
, inner_eval
, restore_environment
,
4127 (void *) SCM_UNPACK (exp
),
4128 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4133 /* At this point, scm_deval and scm_dapply are generated.
4136 #ifdef DEBUG_EXTENSIONS
4146 scm_init_opts (scm_evaluator_traps
,
4147 scm_evaluator_trap_table
,
4148 SCM_N_EVALUATOR_TRAPS
);
4149 scm_init_opts (scm_eval_options_interface
,
4151 SCM_N_EVAL_OPTIONS
);
4153 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4154 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4155 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4157 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4158 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4159 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4160 scm_listofnull
= scm_list_1 (SCM_EOL
);
4162 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4167 #ifndef SCM_MAGIC_SNARFER
4168 #include "libguile/eval.x"
4171 scm_c_define ("nil", scm_lisp_nil
);
4172 scm_c_define ("t", scm_lisp_t
);
4174 scm_add_feature ("delay");