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 recieving 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 */
998 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
999 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), temp
, body
), env
);
1001 else if (SCM_CONSP (temp
))
1003 /* plain let, temp is <bindings> */
1004 SCM rvars
, inits
, body
;
1005 transform_bindings (temp
, &rvars
, &inits
, "let");
1006 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1007 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1011 /* named let: Transform (let name ((var init) ...) body ...) into
1012 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1016 SCM
*varloc
= &vars
;
1017 SCM inits
= SCM_EOL
;
1018 SCM
*initloc
= &inits
;
1021 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1023 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1024 bindings
= SCM_CAR (x
);
1025 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1026 while (!SCM_NULLP (bindings
))
1027 { /* vars and inits both in order */
1028 SCM binding
= SCM_CAR (bindings
);
1029 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1030 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1031 *varloc
= scm_list_1 (SCM_CAR (binding
));
1032 varloc
= SCM_CDRLOC (*varloc
);
1033 *initloc
= scm_list_1 (SCM_CADR (binding
));
1034 initloc
= SCM_CDRLOC (*initloc
);
1035 bindings
= SCM_CDR (bindings
);
1039 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1040 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1041 SCM rvar
= scm_list_1 (name
);
1042 SCM init
= scm_list_1 (lambda_form
);
1043 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1044 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1045 return scm_cons (letrec
, inits
);
1051 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1052 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1053 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1056 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1058 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1059 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1063 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1064 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1068 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1070 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1071 scm_s_expression
, s_atcall_cc
);
1072 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1075 /* Multi-language support */
1077 SCM_GLOBAL_SYMBOL (scm_lisp_nil
, "nil");
1078 SCM_GLOBAL_SYMBOL (scm_lisp_t
, "t");
1080 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1083 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1085 long len
= scm_ilength (SCM_CDR (xorig
));
1086 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1087 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1090 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1093 scm_m_nil_ify (SCM xorig
, SCM env SCM_UNUSED
)
1095 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1096 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1099 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1102 scm_m_t_ify (SCM xorig
, SCM env SCM_UNUSED
)
1104 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1105 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1108 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1111 scm_m_0_cond (SCM xorig
, SCM env SCM_UNUSED
)
1113 long len
= scm_ilength (SCM_CDR (xorig
));
1114 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1115 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1118 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1121 scm_m_0_ify (SCM xorig
, SCM env SCM_UNUSED
)
1123 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1124 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1127 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1130 scm_m_1_ify (SCM xorig
, SCM env SCM_UNUSED
)
1132 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1133 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1136 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1139 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1141 SCM x
= SCM_CDR (xorig
), var
;
1142 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1143 var
= scm_symbol_fref (SCM_CAR (x
));
1144 SCM_ASSYNT (SCM_VARIABLEP (var
),
1145 "Symbol's function definition is void", NULL
);
1146 SCM_SETCAR (x
, var
);
1150 /* (@bind ((var exp) ...) body ...)
1152 This will assign the values of the `exp's to the global variables
1153 named by `var's (symbols, not evaluated), creating them if they
1154 don't exist, executes body, and then restores the previous values of
1155 the `var's. Additionally, whenever control leaves body, the values
1156 of the `var's are saved and restored when control returns. It is an
1157 error when a symbol appears more than once among the `var's.
1158 All `exp's are evaluated before any `var' is set.
1160 This of this as `let' for dynamic scope.
1162 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1164 XXX - also implement `@bind*'.
1167 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1170 scm_m_atbind (SCM xorig
, SCM env
)
1172 SCM x
= SCM_CDR (xorig
);
1173 SCM top_level
= scm_env_top_level (env
);
1174 SCM vars
= SCM_EOL
, var
;
1177 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1180 while (SCM_NIMP (x
))
1183 SCM sym_exp
= SCM_CAR (x
);
1184 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1185 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1187 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1188 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1189 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1190 /* The first call to scm_sym2var will look beyond the current
1191 module, while the second call wont. */
1192 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1193 if (SCM_FALSEP (var
))
1194 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1195 vars
= scm_cons (var
, vars
);
1196 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1198 return scm_cons (SCM_IM_BIND
,
1199 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1203 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1204 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1207 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1209 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1210 scm_s_expression
, s_at_call_with_values
);
1211 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1215 scm_m_expand_body (SCM xorig
, SCM env
)
1217 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1218 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1220 while (SCM_NIMP (x
))
1222 SCM form
= SCM_CAR (x
);
1223 if (!SCM_CONSP (form
))
1225 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1228 form
= scm_macroexp (scm_cons_source (form
,
1233 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1235 defs
= scm_cons (SCM_CDR (form
), defs
);
1238 else if (!SCM_IMP (defs
))
1242 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1244 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1248 x
= scm_cons (form
, SCM_CDR (x
));
1253 if (!SCM_NULLP (defs
))
1255 SCM rvars
, inits
, body
, letrec
;
1256 transform_bindings (defs
, &rvars
, &inits
, what
);
1257 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1258 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1259 SCM_SETCAR (xorig
, letrec
);
1260 SCM_SETCDR (xorig
, SCM_EOL
);
1264 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1265 SCM_SETCAR (xorig
, SCM_CAR (x
));
1266 SCM_SETCDR (xorig
, SCM_CDR (x
));
1273 scm_macroexp (SCM x
, SCM env
)
1275 SCM res
, proc
, orig_sym
;
1277 /* Don't bother to produce error messages here. We get them when we
1278 eventually execute the code for real. */
1281 orig_sym
= SCM_CAR (x
);
1282 if (!SCM_SYMBOLP (orig_sym
))
1287 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1288 if (proc_ptr
== NULL
)
1290 /* We have lost the race. */
1296 proc
= *scm_lookupcar (x
, env
, 0);
1299 /* Only handle memoizing macros. `Acros' and `macros' are really
1300 special forms and should not be evaluated here. */
1302 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1305 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1306 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1308 if (scm_ilength (res
) <= 0)
1309 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1312 SCM_SETCAR (x
, SCM_CAR (res
));
1313 SCM_SETCDR (x
, SCM_CDR (res
));
1319 /* scm_unmemocopy takes a memoized expression together with its
1320 * environment and rewrites it to its original form. Thus, it is the
1321 * inversion of the rewrite rules above. The procedure is not
1322 * optimized for speed. It's used in scm_iprin1 when printing the
1323 * code of a closure, in scm_procedure_source, in display_frame when
1324 * generating the source for a stackframe in a backtrace, and in
1325 * display_expression.
1327 * Unmemoizing is not a realiable process. You can not in general
1328 * expect to get the original source back.
1330 * However, GOOPS currently relies on this for method compilation.
1331 * This ought to change.
1334 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1337 build_binding_list (SCM names
, SCM inits
)
1339 SCM bindings
= SCM_EOL
;
1340 while (!SCM_NULLP (names
))
1342 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1343 bindings
= scm_cons (binding
, bindings
);
1344 names
= SCM_CDR (names
);
1345 inits
= SCM_CDR (inits
);
1351 unmemocopy (SCM x
, SCM env
)
1354 #ifdef DEBUG_EXTENSIONS
1359 #ifdef DEBUG_EXTENSIONS
1360 p
= scm_whash_lookup (scm_source_whash
, x
);
1362 switch (SCM_ITAG7 (SCM_CAR (x
)))
1364 case SCM_BIT8(SCM_IM_AND
):
1365 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1367 case SCM_BIT8(SCM_IM_BEGIN
):
1368 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1370 case SCM_BIT8(SCM_IM_CASE
):
1371 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1373 case SCM_BIT8(SCM_IM_COND
):
1374 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1376 case SCM_BIT8 (SCM_IM_DO
):
1378 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1379 * where nx is the name of a local variable, ix is an initializer for
1380 * the local variable, test is the test clause of the do loop, body is
1381 * the body of the do loop and sx are the step clauses for the local
1383 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1386 names
= SCM_CAR (x
);
1388 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1389 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1391 test
= unmemocopy (SCM_CAR (x
), env
);
1393 memoized_body
= SCM_CAR (x
);
1395 steps
= scm_reverse (unmemocopy (x
, env
));
1397 /* build transformed binding list */
1399 while (!SCM_NULLP (names
))
1401 SCM name
= SCM_CAR (names
);
1402 SCM init
= SCM_CAR (inits
);
1403 SCM step
= SCM_CAR (steps
);
1404 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1406 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1408 names
= SCM_CDR (names
);
1409 inits
= SCM_CDR (inits
);
1410 steps
= SCM_CDR (steps
);
1412 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1413 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1415 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1418 case SCM_BIT8(SCM_IM_IF
):
1419 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1421 case SCM_BIT8 (SCM_IM_LET
):
1423 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1424 * where nx is the name of a local variable, ix is an initializer for
1425 * the local variable and by are the body clauses. */
1426 SCM names
, inits
, bindings
;
1429 names
= SCM_CAR (x
);
1431 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1432 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1434 bindings
= build_binding_list (names
, inits
);
1435 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1436 ls
= scm_cons (scm_sym_let
, z
);
1439 case SCM_BIT8 (SCM_IM_LETREC
):
1441 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1442 * where nx is the name of a local variable, ix is an initializer for
1443 * the local variable and by are the body clauses. */
1444 SCM names
, inits
, bindings
;
1447 names
= SCM_CAR (x
);
1448 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1450 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1452 bindings
= build_binding_list (names
, inits
);
1453 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1454 ls
= scm_cons (scm_sym_letrec
, z
);
1457 case SCM_BIT8(SCM_IM_LETSTAR
):
1465 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1468 y
= z
= scm_acons (SCM_CAR (b
),
1470 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1472 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1476 SCM_SETCDR (y
, SCM_EOL
);
1477 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1482 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1484 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1487 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1490 while (SCM_NIMP (b
));
1491 SCM_SETCDR (z
, SCM_EOL
);
1493 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1496 case SCM_BIT8(SCM_IM_OR
):
1497 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1499 case SCM_BIT8(SCM_IM_LAMBDA
):
1501 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1502 ls
= scm_cons (scm_sym_lambda
, z
);
1503 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1505 case SCM_BIT8(SCM_IM_QUOTE
):
1506 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1508 case SCM_BIT8(SCM_IM_SET_X
):
1509 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1511 case SCM_BIT8(SCM_IM_DEFINE
):
1516 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1517 ls
= scm_cons (scm_sym_define
, z
);
1518 if (!SCM_NULLP (env
))
1519 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1522 case SCM_BIT8(SCM_MAKISYM (0)):
1526 switch (SCM_ISYMNUM (z
))
1528 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1529 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1531 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1532 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1534 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1535 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1538 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1539 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1542 /* appease the Sun compiler god: */ ;
1546 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1552 while (SCM_CONSP (x
))
1554 SCM form
= SCM_CAR (x
);
1555 if (!SCM_ISYMP (form
))
1557 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1558 SCM_SETCDR (z
, unmemocar (copy
, env
));
1564 #ifdef DEBUG_EXTENSIONS
1565 if (!SCM_FALSEP (p
))
1566 scm_whash_insert (scm_source_whash
, ls
, p
);
1573 scm_unmemocopy (SCM x
, SCM env
)
1575 if (!SCM_NULLP (env
))
1576 /* Make a copy of the lowest frame to protect it from
1577 modifications by SCM_IM_DEFINE */
1578 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1580 return unmemocopy (x
, env
);
1583 #ifndef SCM_RECKLESS
1586 scm_badargsp (SCM formals
, SCM args
)
1588 while (SCM_NIMP (formals
))
1590 if (!SCM_CONSP (formals
))
1594 formals
= SCM_CDR (formals
);
1595 args
= SCM_CDR (args
);
1597 return !SCM_NULLP (args
) ? 1 : 0;
1602 scm_badformalsp (SCM closure
, int n
)
1604 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1605 while (!SCM_NULLP (formals
))
1607 if (!SCM_CONSP (formals
))
1612 formals
= SCM_CDR (formals
);
1619 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1621 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1622 while (SCM_CONSP (l
))
1624 res
= EVALCAR (l
, env
);
1626 *lloc
= scm_list_1 (res
);
1627 lloc
= SCM_CDRLOC (*lloc
);
1632 scm_wrong_num_args (proc
);
1638 scm_eval_body (SCM code
, SCM env
)
1642 next
= SCM_CDR (code
);
1643 while (!SCM_NULLP (next
))
1645 if (SCM_IMP (SCM_CAR (code
)))
1647 if (SCM_ISYMP (SCM_CAR (code
)))
1649 code
= scm_m_expand_body (code
, env
);
1654 SCM_XEVAL (SCM_CAR (code
), env
);
1656 next
= SCM_CDR (code
);
1658 return SCM_XEVALCAR (code
, env
);
1665 /* SECTION: This code is specific for the debugging support. One
1666 * branch is read when DEVAL isn't defined, the other when DEVAL is
1672 #define SCM_APPLY scm_apply
1673 #define PREP_APPLY(proc, args)
1675 #define RETURN(x) do { return x; } while (0)
1676 #ifdef STACK_CHECKING
1677 #ifndef NO_CEVAL_STACK_CHECKING
1678 #define EVAL_STACK_CHECKING
1685 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1687 #define SCM_APPLY scm_dapply
1689 #define PREP_APPLY(p, l) \
1690 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1692 #define ENTER_APPLY \
1694 SCM_SET_ARGSREADY (debug);\
1695 if (CHECK_APPLY && SCM_TRAPS_P)\
1696 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1698 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1699 SCM_SET_TRACED_FRAME (debug); \
1701 if (SCM_CHEAPTRAPS_P)\
1703 tmp = scm_make_debugobj (&debug);\
1704 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1709 tmp = scm_make_continuation (&first);\
1711 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1717 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1718 #ifdef STACK_CHECKING
1719 #ifndef EVAL_STACK_CHECKING
1720 #define EVAL_STACK_CHECKING
1724 /* scm_ceval_ptr points to the currently selected evaluator.
1725 * *fixme*: Although efficiency is important here, this state variable
1726 * should probably not be a global. It should be related to the
1731 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1733 /* scm_last_debug_frame contains a pointer to the last debugging
1734 * information stack frame. It is accessed very often from the
1735 * debugging evaluator, so it should probably not be indirectly
1736 * addressed. Better to save and restore it from the current root at
1741 scm_t_debug_frame
*scm_last_debug_frame
;
1744 /* scm_debug_eframe_size is the number of slots available for pseudo
1745 * stack frames at each real stack frame.
1748 long scm_debug_eframe_size
;
1750 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1752 long scm_eval_stack
;
1754 scm_t_option scm_eval_opts
[] = {
1755 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1758 scm_t_option scm_debug_opts
[] = {
1759 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1760 "*Flyweight representation of the stack at traps." },
1761 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1762 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1763 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1764 "Record procedure names at definition." },
1765 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1766 "Display backtrace in anti-chronological order." },
1767 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1768 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1769 { SCM_OPTION_INTEGER
, "frames", 3,
1770 "Maximum number of tail-recursive frames in backtrace." },
1771 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1772 "Maximal number of stored backtrace frames." },
1773 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1774 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1775 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1776 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1777 { 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."}
1780 scm_t_option scm_evaluator_trap_table
[] = {
1781 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1782 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1783 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1784 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1785 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1786 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1787 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1790 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1792 "Option interface for the evaluation options. Instead of using\n"
1793 "this procedure directly, use the procedures @code{eval-enable},\n"
1794 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1795 #define FUNC_NAME s_scm_eval_options_interface
1799 ans
= scm_options (setting
,
1803 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1809 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1811 "Option interface for the evaluator trap options.")
1812 #define FUNC_NAME s_scm_evaluator_traps
1816 ans
= scm_options (setting
,
1817 scm_evaluator_trap_table
,
1818 SCM_N_EVALUATOR_TRAPS
,
1820 SCM_RESET_DEBUG_MODE
;
1827 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1829 SCM
*results
= lloc
, res
;
1830 while (SCM_CONSP (l
))
1832 res
= EVALCAR (l
, env
);
1834 *lloc
= scm_list_1 (res
);
1835 lloc
= SCM_CDRLOC (*lloc
);
1840 scm_wrong_num_args (proc
);
1848 /* SECTION: Some local definitions for the evaluator.
1851 /* Update the toplevel environment frame ENV so that it refers to the
1854 #define UPDATE_TOPLEVEL_ENV(env) \
1856 SCM p = scm_current_module_lookup_closure (); \
1857 if (p != SCM_CAR(env)) \
1858 env = scm_top_level_env (p); \
1862 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (!SCM_FALSEP (scm_eqv_p ((A), (B)))))
1865 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1867 /* SECTION: This is the evaluator. Like any real monster, it has
1868 * three heads. This code is compiled twice.
1874 scm_ceval (SCM x
, SCM env
)
1880 scm_deval (SCM x
, SCM env
)
1885 SCM_CEVAL (SCM x
, SCM env
)
1892 SCM proc
, arg2
, orig_sym
;
1894 scm_t_debug_frame debug
;
1895 scm_t_debug_info
*debug_info_end
;
1896 debug
.prev
= scm_last_debug_frame
;
1897 debug
.status
= scm_debug_eframe_size
;
1899 * The debug.vect contains twice as much scm_t_debug_info frames as the
1900 * user has specified with (debug-set! frames <n>).
1902 * Even frames are eval frames, odd frames are apply frames.
1904 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1905 * sizeof (debug
.vect
[0]));
1906 debug
.info
= debug
.vect
;
1907 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1908 scm_last_debug_frame
= &debug
;
1910 #ifdef EVAL_STACK_CHECKING
1911 if (scm_stack_checking_enabled_p
1912 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1915 debug
.info
->e
.exp
= x
;
1916 debug
.info
->e
.env
= env
;
1918 scm_report_stack_overflow ();
1925 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1928 SCM_CLEAR_ARGSREADY (debug
);
1929 if (SCM_OVERFLOWP (debug
))
1932 * In theory, this should be the only place where it is necessary to
1933 * check for space in debug.vect since both eval frames and
1934 * available space are even.
1936 * For this to be the case, however, it is necessary that primitive
1937 * special forms which jump back to `loop', `begin' or some similar
1938 * label call PREP_APPLY. A convenient way to do this is to jump to
1939 * `loopnoap' or `cdrxnoap'.
1941 else if (++debug
.info
>= debug_info_end
)
1943 SCM_SET_OVERFLOW (debug
);
1947 debug
.info
->e
.exp
= x
;
1948 debug
.info
->e
.env
= env
;
1949 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1950 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1952 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1953 SCM_SET_TAILREC (debug
);
1954 if (SCM_CHEAPTRAPS_P
)
1955 t
.arg1
= scm_make_debugobj (&debug
);
1959 SCM val
= scm_make_continuation (&first
);
1969 /* This gives the possibility for the debugger to
1970 modify the source expression before evaluation. */
1975 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1976 scm_sym_enter_frame
,
1979 scm_unmemocopy (x
, env
));
1983 #if defined (USE_THREADS) || defined (DEVAL)
1987 switch (SCM_TYP7 (x
))
1989 case scm_tc7_symbol
:
1990 /* Only happens when called at top level.
1992 x
= scm_cons (x
, SCM_UNDEFINED
);
1993 RETURN (*scm_lookupcar (x
, env
, 1));
1995 case SCM_BIT8(SCM_IM_AND
):
1997 while (!SCM_NULLP (SCM_CDR (x
)))
1999 if (SCM_FALSEP (EVALCAR (x
, env
)))
2000 RETURN (SCM_BOOL_F
);
2004 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2007 case SCM_BIT8(SCM_IM_BEGIN
):
2008 if (SCM_NULLP (SCM_CDR (x
)))
2009 RETURN (SCM_UNSPECIFIED
);
2011 /* (currently unused)
2013 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2014 /* (currently unused)
2019 /* If we are on toplevel with a lookup closure, we need to sync
2020 with the current module. */
2021 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2023 UPDATE_TOPLEVEL_ENV (env
);
2024 while (!SCM_NULLP (SCM_CDR (x
)))
2027 UPDATE_TOPLEVEL_ENV (env
);
2033 goto nontoplevel_begin
;
2035 nontoplevel_cdrxnoap
:
2036 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2037 nontoplevel_cdrxbegin
:
2040 while (!SCM_NULLP (SCM_CDR (x
)))
2042 if (SCM_IMP (SCM_CAR (x
)))
2044 if (SCM_ISYMP (SCM_CAR (x
)))
2046 x
= scm_m_expand_body (x
, env
);
2047 goto nontoplevel_begin
;
2050 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
2053 SCM_CEVAL (SCM_CAR (x
), env
);
2057 carloop
: /* scm_eval car of last form in list */
2058 if (SCM_IMP (SCM_CAR (x
)))
2061 RETURN (SCM_EVALIM (x
, env
));
2064 if (SCM_SYMBOLP (SCM_CAR (x
)))
2065 RETURN (*scm_lookupcar (x
, env
, 1));
2068 goto loop
; /* tail recurse */
2071 case SCM_BIT8(SCM_IM_CASE
):
2073 t
.arg1
= EVALCAR (x
, env
);
2074 while (SCM_NIMP (x
= SCM_CDR (x
)))
2077 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2080 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2083 proc
= SCM_CAR (proc
);
2084 while (SCM_NIMP (proc
))
2086 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2089 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2092 proc
= SCM_CDR (proc
);
2095 RETURN (SCM_UNSPECIFIED
);
2098 case SCM_BIT8 (SCM_IM_COND
):
2100 while (!SCM_NULLP (x
))
2103 if (SCM_EQ_P (SCM_CAR (proc
), scm_sym_else
))
2106 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2109 t
.arg1
= EVALCAR (proc
, env
);
2110 if (!SCM_FALSEP (t
.arg1
))
2115 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2117 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2121 proc
= EVALCAR (proc
, env
);
2122 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2123 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2125 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2126 goto umwrongnumargs
;
2131 RETURN (SCM_UNSPECIFIED
);
2134 case SCM_BIT8(SCM_IM_DO
):
2136 proc
= SCM_CADR (x
); /* inits */
2137 t
.arg1
= SCM_EOL
; /* values */
2138 while (SCM_NIMP (proc
))
2140 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2141 proc
= SCM_CDR (proc
);
2143 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2145 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2147 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2149 t
.arg1
= SCM_CAR (proc
); /* body */
2150 SIDEVAL (t
.arg1
, env
);
2152 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2154 proc
= SCM_CDR (proc
))
2155 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2156 env
= EXTEND_ENV (SCM_CAAR (env
), t
.arg1
, SCM_CDR (env
));
2160 RETURN (SCM_UNSPECIFIED
);
2161 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2162 goto nontoplevel_begin
;
2165 case SCM_BIT8(SCM_IM_IF
):
2167 if (!SCM_FALSEP (EVALCAR (x
, env
)))
2169 else if (SCM_IMP (x
= SCM_CDDR (x
)))
2170 RETURN (SCM_UNSPECIFIED
);
2171 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2175 case SCM_BIT8(SCM_IM_LET
):
2177 proc
= SCM_CADR (x
);
2181 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2183 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2184 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2186 goto nontoplevel_cdrxnoap
;
2189 case SCM_BIT8(SCM_IM_LETREC
):
2191 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2197 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2199 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2200 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2201 goto nontoplevel_cdrxnoap
;
2204 case SCM_BIT8(SCM_IM_LETSTAR
):
2207 SCM bindings
= SCM_CAR (x
);
2208 if (SCM_NULLP (bindings
))
2209 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2214 SCM name
= SCM_CAR (bindings
);
2215 SCM init
= SCM_CDR (bindings
);
2216 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2217 bindings
= SCM_CDR (init
);
2219 while (!SCM_NULLP (bindings
));
2222 goto nontoplevel_cdrxnoap
;
2225 case SCM_BIT8(SCM_IM_OR
):
2227 while (!SCM_NULLP (SCM_CDR (x
)))
2229 SCM val
= EVALCAR (x
, env
);
2230 if (!SCM_FALSEP (val
))
2235 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2239 case SCM_BIT8(SCM_IM_LAMBDA
):
2240 RETURN (scm_closure (SCM_CDR (x
), env
));
2243 case SCM_BIT8(SCM_IM_QUOTE
):
2244 RETURN (SCM_CADR (x
));
2247 case SCM_BIT8(SCM_IM_SET_X
):
2250 switch (SCM_ITAG3 (proc
))
2253 if (SCM_VARIABLEP (proc
))
2254 t
.lloc
= SCM_VARIABLE_LOC (proc
);
2256 t
.lloc
= scm_lookupcar (x
, env
, 1);
2258 #ifdef MEMOIZE_LOCALS
2260 t
.lloc
= scm_ilookup (proc
, env
);
2265 *t
.lloc
= EVALCAR (x
, env
);
2269 RETURN (SCM_UNSPECIFIED
);
2273 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2274 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2276 /* new syntactic forms go here. */
2277 case SCM_BIT8(SCM_MAKISYM (0)):
2279 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2280 switch SCM_ISYMNUM (proc
)
2282 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2284 proc
= EVALCAR (proc
, env
);
2285 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2286 if (SCM_CLOSUREP (proc
))
2289 PREP_APPLY (proc
, SCM_EOL
);
2290 t
.arg1
= SCM_CDDR (x
);
2291 t
.arg1
= EVALCAR (t
.arg1
, env
);
2293 /* Go here to tail-call a closure. PROC is the closure
2294 and T.ARG1 is the list of arguments. Do not forget to
2297 debug
.info
->a
.args
= t
.arg1
;
2299 #ifndef SCM_RECKLESS
2300 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2304 /* Copy argument list */
2305 if (SCM_IMP (t
.arg1
))
2309 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2310 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2311 && SCM_CONSP (t
.arg1
))
2313 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2317 SCM_SETCDR (tl
, t
.arg1
);
2320 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2321 x
= SCM_CODE (proc
);
2322 goto nontoplevel_cdrxbegin
;
2327 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2330 SCM val
= scm_make_continuation (&first
);
2338 proc
= scm_eval_car (proc
, env
);
2339 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2340 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2342 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2343 goto umwrongnumargs
;
2346 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2347 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2349 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2350 proc
= SCM_CADR (x
); /* unevaluated operands */
2351 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2353 arg2
= *scm_ilookup (proc
, env
);
2354 else if (!SCM_CONSP (proc
))
2356 if (SCM_VARIABLEP (proc
))
2357 arg2
= SCM_VARIABLE_REF (proc
);
2359 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2363 arg2
= scm_list_1 (EVALCAR (proc
, env
));
2364 t
.lloc
= SCM_CDRLOC (arg2
);
2365 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2367 *t
.lloc
= scm_list_1 (EVALCAR (proc
, env
));
2368 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2373 /* The type dispatch code is duplicated here
2374 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2375 * cuts down execution time for type dispatch to 50%.
2378 long i
, n
, end
, mask
;
2379 SCM z
= SCM_CDDR (x
);
2380 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2381 proc
= SCM_CADR (z
);
2383 if (SCM_NIMP (proc
))
2385 /* Prepare for linear search */
2388 end
= SCM_VECTOR_LENGTH (proc
);
2392 /* Compute a hash value */
2393 long hashset
= SCM_INUM (proc
);
2396 mask
= SCM_INUM (SCM_CAR (z
));
2397 proc
= SCM_CADR (z
);
2400 if (SCM_NIMP (t
.arg1
))
2403 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2404 [scm_si_hashsets
+ hashset
];
2405 t
.arg1
= SCM_CDR (t
.arg1
);
2407 while (j
-- && SCM_NIMP (t
.arg1
));
2412 /* Search for match */
2416 z
= SCM_VELTS (proc
)[i
];
2417 t
.arg1
= arg2
; /* list of arguments */
2418 if (SCM_NIMP (t
.arg1
))
2421 /* More arguments than specifiers => CLASS != ENV */
2422 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2424 t
.arg1
= SCM_CDR (t
.arg1
);
2427 while (j
-- && SCM_NIMP (t
.arg1
));
2428 /* Fewer arguments than specifiers => CAR != ENV */
2429 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2432 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2434 SCM_CMETHOD_ENV (z
));
2435 x
= SCM_CMETHOD_CODE (z
);
2436 goto nontoplevel_cdrxbegin
;
2441 z
= scm_memoize_method (x
, arg2
);
2445 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2447 t
.arg1
= EVALCAR (x
, env
);
2448 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]));
2450 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2452 t
.arg1
= EVALCAR (x
, env
);
2455 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2456 = SCM_UNPACK (EVALCAR (proc
, env
));
2457 RETURN (SCM_UNSPECIFIED
);
2459 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2461 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2463 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2464 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2466 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2468 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2474 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2477 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2479 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2483 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2485 RETURN (!SCM_FALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
);
2487 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2489 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2491 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2492 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2494 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2496 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2502 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2505 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2507 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2511 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2513 RETURN (!SCM_FALSEP (EVALCAR (x
, env
))
2517 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2519 SCM vars
, exps
, vals
;
2522 vars
= SCM_CAAR (x
);
2523 exps
= SCM_CDAR (x
);
2527 while (SCM_NIMP (exps
))
2529 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2530 exps
= SCM_CDR (exps
);
2533 scm_swap_bindings (vars
, vals
);
2534 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2536 arg2
= x
= SCM_CDR (x
);
2537 while (!SCM_NULLP (arg2
= SCM_CDR (arg2
)))
2539 SIDEVAL (SCM_CAR (x
), env
);
2542 proc
= EVALCAR (x
, env
);
2544 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2545 scm_swap_bindings (vars
, vals
);
2550 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2553 x
= EVALCAR (proc
, env
);
2554 proc
= SCM_CDR (proc
);
2555 proc
= EVALCAR (proc
, env
);
2556 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2557 if (SCM_VALUESP (t
.arg1
))
2558 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2560 t
.arg1
= scm_list_1 (t
.arg1
);
2561 if (SCM_CLOSUREP (proc
))
2563 PREP_APPLY (proc
, t
.arg1
);
2566 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2576 /* scm_everr (x, env,...) */
2577 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2578 case scm_tc7_vector
:
2582 case scm_tc7_byvect
:
2589 #ifdef HAVE_LONG_LONGS
2590 case scm_tc7_llvect
:
2593 case scm_tc7_string
:
2595 case scm_tcs_closures
:
2599 case scm_tcs_struct
:
2602 case scm_tc7_variable
:
2603 RETURN (SCM_VARIABLE_REF(x
));
2605 #ifdef MEMOIZE_LOCALS
2606 case SCM_BIT8(SCM_ILOC00
):
2607 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2608 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2609 #ifndef SCM_RECKLESS
2615 #endif /* ifdef MEMOIZE_LOCALS */
2617 case scm_tcs_cons_nimcar
:
2618 orig_sym
= SCM_CAR (x
);
2619 if (SCM_SYMBOLP (orig_sym
))
2622 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2625 /* we have lost the race, start again. */
2630 proc
= *scm_lookupcar (x
, env
, 1);
2635 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2639 if (SCM_MACROP (proc
))
2641 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2645 /* Set a flag during macro expansion so that macro
2646 application frames can be deleted from the backtrace. */
2647 SCM_SET_MACROEXP (debug
);
2649 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2650 scm_cons (env
, scm_listofnull
));
2653 SCM_CLEAR_MACROEXP (debug
);
2655 switch (SCM_MACRO_TYPE (proc
))
2658 if (scm_ilength (t
.arg1
) <= 0)
2659 t
.arg1
= scm_list_2 (SCM_IM_BEGIN
, t
.arg1
);
2661 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2664 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2665 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2669 /* Prevent memoizing of debug info expression. */
2670 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2675 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2676 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2680 if (SCM_NIMP (x
= t
.arg1
))
2688 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2689 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2690 #ifndef SCM_RECKLESS
2694 if (SCM_CLOSUREP (proc
))
2696 arg2
= SCM_CLOSURE_FORMALS (proc
);
2697 t
.arg1
= SCM_CDR (x
);
2698 while (!SCM_NULLP (arg2
))
2700 if (!SCM_CONSP (arg2
))
2702 if (SCM_IMP (t
.arg1
))
2703 goto umwrongnumargs
;
2704 arg2
= SCM_CDR (arg2
);
2705 t
.arg1
= SCM_CDR (t
.arg1
);
2707 if (!SCM_NULLP (t
.arg1
))
2708 goto umwrongnumargs
;
2710 else if (SCM_MACROP (proc
))
2711 goto handle_a_macro
;
2717 PREP_APPLY (proc
, SCM_EOL
);
2718 if (SCM_NULLP (SCM_CDR (x
))) {
2721 switch (SCM_TYP7 (proc
))
2722 { /* no arguments given */
2723 case scm_tc7_subr_0
:
2724 RETURN (SCM_SUBRF (proc
) ());
2725 case scm_tc7_subr_1o
:
2726 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2728 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2729 case scm_tc7_rpsubr
:
2730 RETURN (SCM_BOOL_T
);
2732 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2734 if (!SCM_SMOB_APPLICABLE_P (proc
))
2736 RETURN (SCM_SMOB_APPLY_0 (proc
));
2739 proc
= SCM_CCLO_SUBR (proc
);
2741 debug
.info
->a
.proc
= proc
;
2742 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2746 proc
= SCM_PROCEDURE (proc
);
2748 debug
.info
->a
.proc
= proc
;
2750 if (!SCM_CLOSUREP (proc
))
2752 if (scm_badformalsp (proc
, 0))
2753 goto umwrongnumargs
;
2754 case scm_tcs_closures
:
2755 x
= SCM_CODE (proc
);
2756 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2757 goto nontoplevel_cdrxbegin
;
2758 case scm_tcs_struct
:
2759 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2761 x
= SCM_ENTITY_PROCEDURE (proc
);
2765 else if (!SCM_I_OPERATORP (proc
))
2770 proc
= (SCM_I_ENTITYP (proc
)
2771 ? SCM_ENTITY_PROCEDURE (proc
)
2772 : SCM_OPERATOR_PROCEDURE (proc
));
2774 debug
.info
->a
.proc
= proc
;
2775 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2777 if (SCM_NIMP (proc
))
2782 case scm_tc7_subr_1
:
2783 case scm_tc7_subr_2
:
2784 case scm_tc7_subr_2o
:
2786 case scm_tc7_subr_3
:
2787 case scm_tc7_lsubr_2
:
2791 /* scm_everr (x, env,...) */
2792 scm_wrong_num_args (proc
);
2794 /* handle macros here */
2799 /* must handle macros by here */
2804 else if (SCM_CONSP (x
))
2806 if (SCM_IMP (SCM_CAR (x
)))
2807 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2809 t
.arg1
= EVALCELLCAR (x
, env
);
2814 t
.arg1
= EVALCAR (x
, env
);
2817 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2824 switch (SCM_TYP7 (proc
))
2825 { /* have one argument in t.arg1 */
2826 case scm_tc7_subr_2o
:
2827 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2828 case scm_tc7_subr_1
:
2829 case scm_tc7_subr_1o
:
2830 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2832 if (SCM_SUBRF (proc
))
2834 if (SCM_INUMP (t
.arg1
))
2836 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2838 else if (SCM_REALP (t
.arg1
))
2840 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2843 else if (SCM_BIGP (t
.arg1
))
2845 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2848 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2849 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2851 proc
= SCM_SNAME (proc
);
2853 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2854 while ('c' != *--chrs
)
2856 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2857 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2858 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2862 case scm_tc7_rpsubr
:
2863 RETURN (SCM_BOOL_T
);
2865 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2868 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2870 RETURN (SCM_SUBRF (proc
) (scm_list_1 (t
.arg1
)));
2873 if (!SCM_SMOB_APPLICABLE_P (proc
))
2875 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2879 proc
= SCM_CCLO_SUBR (proc
);
2881 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2882 debug
.info
->a
.proc
= proc
;
2886 proc
= SCM_PROCEDURE (proc
);
2888 debug
.info
->a
.proc
= proc
;
2890 if (!SCM_CLOSUREP (proc
))
2892 if (scm_badformalsp (proc
, 1))
2893 goto umwrongnumargs
;
2894 case scm_tcs_closures
:
2896 x
= SCM_CODE (proc
);
2898 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2900 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (t
.arg1
), SCM_ENV (proc
));
2902 goto nontoplevel_cdrxbegin
;
2903 case scm_tcs_struct
:
2904 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2906 x
= SCM_ENTITY_PROCEDURE (proc
);
2908 arg2
= debug
.info
->a
.args
;
2910 arg2
= scm_list_1 (t
.arg1
);
2914 else if (!SCM_I_OPERATORP (proc
))
2920 proc
= (SCM_I_ENTITYP (proc
)
2921 ? SCM_ENTITY_PROCEDURE (proc
)
2922 : SCM_OPERATOR_PROCEDURE (proc
));
2924 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2925 debug
.info
->a
.proc
= proc
;
2927 if (SCM_NIMP (proc
))
2932 case scm_tc7_subr_2
:
2933 case scm_tc7_subr_0
:
2934 case scm_tc7_subr_3
:
2935 case scm_tc7_lsubr_2
:
2944 else if (SCM_CONSP (x
))
2946 if (SCM_IMP (SCM_CAR (x
)))
2947 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2949 arg2
= EVALCELLCAR (x
, env
);
2954 arg2
= EVALCAR (x
, env
);
2956 { /* have two or more arguments */
2958 debug
.info
->a
.args
= scm_list_2 (t
.arg1
, arg2
);
2961 if (SCM_NULLP (x
)) {
2964 switch (SCM_TYP7 (proc
))
2965 { /* have two arguments */
2966 case scm_tc7_subr_2
:
2967 case scm_tc7_subr_2o
:
2968 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2971 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2973 RETURN (SCM_SUBRF (proc
) (scm_list_2 (t
.arg1
, arg2
)));
2975 case scm_tc7_lsubr_2
:
2976 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2977 case scm_tc7_rpsubr
:
2979 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2981 if (!SCM_SMOB_APPLICABLE_P (proc
))
2983 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2987 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2988 scm_cons (proc
, debug
.info
->a
.args
),
2991 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2992 scm_cons2 (proc
, t
.arg1
,
2999 case scm_tcs_struct
:
3000 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3002 x
= SCM_ENTITY_PROCEDURE (proc
);
3004 arg2
= debug
.info
->a
.args
;
3006 arg2
= scm_list_2 (t
.arg1
, arg2
);
3010 else if (!SCM_I_OPERATORP (proc
))
3016 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3017 ? SCM_ENTITY_PROCEDURE (proc
)
3018 : SCM_OPERATOR_PROCEDURE (proc
),
3019 scm_cons (proc
, debug
.info
->a
.args
),
3022 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3023 ? SCM_ENTITY_PROCEDURE (proc
)
3024 : SCM_OPERATOR_PROCEDURE (proc
),
3025 scm_cons2 (proc
, t
.arg1
,
3033 case scm_tc7_subr_0
:
3035 case scm_tc7_subr_1o
:
3036 case scm_tc7_subr_1
:
3037 case scm_tc7_subr_3
:
3042 proc
= SCM_PROCEDURE (proc
);
3044 debug
.info
->a
.proc
= proc
;
3046 if (!SCM_CLOSUREP (proc
))
3048 if (scm_badformalsp (proc
, 2))
3049 goto umwrongnumargs
;
3050 case scm_tcs_closures
:
3053 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3057 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3058 scm_list_2 (t
.arg1
, arg2
), SCM_ENV (proc
));
3060 x
= SCM_CODE (proc
);
3061 goto nontoplevel_cdrxbegin
;
3065 if (SCM_IMP (x
) || !SCM_CONSP (x
))
3069 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3070 scm_deval_args (x
, env
, proc
,
3071 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3075 switch (SCM_TYP7 (proc
))
3076 { /* have 3 or more arguments */
3078 case scm_tc7_subr_3
:
3079 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3080 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3081 SCM_CADDR (debug
.info
->a
.args
)));
3083 #ifdef BUILTIN_RPASUBR
3084 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3085 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3088 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3089 arg2
= SCM_CDR (arg2
);
3091 while (SCM_NIMP (arg2
));
3093 #endif /* BUILTIN_RPASUBR */
3094 case scm_tc7_rpsubr
:
3095 #ifdef BUILTIN_RPASUBR
3096 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3097 RETURN (SCM_BOOL_F
);
3098 t
.arg1
= SCM_CDDR (debug
.info
->a
.args
);
3101 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3102 RETURN (SCM_BOOL_F
);
3103 arg2
= SCM_CAR (t
.arg1
);
3104 t
.arg1
= SCM_CDR (t
.arg1
);
3106 while (SCM_NIMP (t
.arg1
));
3107 RETURN (SCM_BOOL_T
);
3108 #else /* BUILTIN_RPASUBR */
3109 RETURN (SCM_APPLY (proc
, t
.arg1
,
3111 SCM_CDDR (debug
.info
->a
.args
),
3113 #endif /* BUILTIN_RPASUBR */
3114 case scm_tc7_lsubr_2
:
3115 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3116 SCM_CDDR (debug
.info
->a
.args
)));
3118 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3120 if (!SCM_SMOB_APPLICABLE_P (proc
))
3122 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3123 SCM_CDDR (debug
.info
->a
.args
)));
3127 proc
= SCM_PROCEDURE (proc
);
3128 debug
.info
->a
.proc
= proc
;
3129 if (!SCM_CLOSUREP (proc
))
3131 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3132 goto umwrongnumargs
;
3133 case scm_tcs_closures
:
3134 SCM_SET_ARGSREADY (debug
);
3135 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3138 x
= SCM_CODE (proc
);
3139 goto nontoplevel_cdrxbegin
;
3141 case scm_tc7_subr_3
:
3142 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3143 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3145 #ifdef BUILTIN_RPASUBR
3146 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3149 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3152 while (SCM_NIMP (x
));
3154 #endif /* BUILTIN_RPASUBR */
3155 case scm_tc7_rpsubr
:
3156 #ifdef BUILTIN_RPASUBR
3157 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3158 RETURN (SCM_BOOL_F
);
3161 t
.arg1
= EVALCAR (x
, env
);
3162 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3163 RETURN (SCM_BOOL_F
);
3167 while (SCM_NIMP (x
));
3168 RETURN (SCM_BOOL_T
);
3169 #else /* BUILTIN_RPASUBR */
3170 RETURN (SCM_APPLY (proc
, t
.arg1
,
3172 scm_eval_args (x
, env
, proc
),
3174 #endif /* BUILTIN_RPASUBR */
3175 case scm_tc7_lsubr_2
:
3176 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3178 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3180 scm_eval_args (x
, env
, proc
))));
3182 if (!SCM_SMOB_APPLICABLE_P (proc
))
3184 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3185 scm_eval_args (x
, env
, proc
)));
3189 proc
= SCM_PROCEDURE (proc
);
3190 if (!SCM_CLOSUREP (proc
))
3193 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3194 if (SCM_NULLP (formals
)
3195 || (SCM_CONSP (formals
)
3196 && (SCM_NULLP (SCM_CDR (formals
))
3197 || (SCM_CONSP (SCM_CDR (formals
))
3198 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3199 goto umwrongnumargs
;
3201 case scm_tcs_closures
:
3203 SCM_SET_ARGSREADY (debug
);
3205 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3208 scm_eval_args (x
, env
, proc
)),
3210 x
= SCM_CODE (proc
);
3211 goto nontoplevel_cdrxbegin
;
3213 case scm_tcs_struct
:
3214 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3217 arg2
= debug
.info
->a
.args
;
3219 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3221 x
= SCM_ENTITY_PROCEDURE (proc
);
3224 else if (!SCM_I_OPERATORP (proc
))
3228 case scm_tc7_subr_2
:
3229 case scm_tc7_subr_1o
:
3230 case scm_tc7_subr_2o
:
3231 case scm_tc7_subr_0
:
3233 case scm_tc7_subr_1
:
3241 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3242 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3244 SCM_CLEAR_TRACED_FRAME (debug
);
3245 if (SCM_CHEAPTRAPS_P
)
3246 t
.arg1
= scm_make_debugobj (&debug
);
3250 SCM val
= scm_make_continuation (&first
);
3261 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3265 scm_last_debug_frame
= debug
.prev
;
3271 /* SECTION: This code is compiled once.
3277 /* Simple procedure calls
3281 scm_call_0 (SCM proc
)
3283 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3287 scm_call_1 (SCM proc
, SCM arg1
)
3289 return scm_apply (proc
, arg1
, scm_listofnull
);
3293 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3295 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3299 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3301 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3305 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3307 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3308 scm_cons (arg4
, scm_listofnull
)));
3311 /* Simple procedure applies
3315 scm_apply_0 (SCM proc
, SCM args
)
3317 return scm_apply (proc
, args
, SCM_EOL
);
3321 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3323 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3327 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3329 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3333 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3335 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3339 /* This code processes the arguments to apply:
3341 (apply PROC ARG1 ... ARGS)
3343 Given a list (ARG1 ... ARGS), this function conses the ARG1
3344 ... arguments onto the front of ARGS, and returns the resulting
3345 list. Note that ARGS is a list; thus, the argument to this
3346 function is a list whose last element is a list.
3348 Apply calls this function, and applies PROC to the elements of the
3349 result. apply:nconc2last takes care of building the list of
3350 arguments, given (ARG1 ... ARGS).
3352 Rather than do new consing, apply:nconc2last destroys its argument.
3353 On that topic, this code came into my care with the following
3354 beautifully cryptic comment on that topic: "This will only screw
3355 you if you do (scm_apply scm_apply '( ... ))" If you know what
3356 they're referring to, send me a patch to this comment. */
3358 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3360 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3361 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3362 "@var{args}, and returns the resulting list. Note that\n"
3363 "@var{args} is a list; thus, the argument to this function is\n"
3364 "a list whose last element is a list.\n"
3365 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3366 "destroys its argument, so use with care.")
3367 #define FUNC_NAME s_scm_nconc2last
3370 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3372 while (!SCM_NULLP (SCM_CDR (*lloc
)))
3373 lloc
= SCM_CDRLOC (*lloc
);
3374 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3375 *lloc
= SCM_CAR (*lloc
);
3383 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3384 * It is compiled twice.
3390 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3397 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3402 /* Apply a function to a list of arguments.
3404 This function is exported to the Scheme level as taking two
3405 required arguments and a tail argument, as if it were:
3406 (lambda (proc arg1 . args) ...)
3407 Thus, if you just have a list of arguments to pass to a procedure,
3408 pass the list as ARG1, and '() for ARGS. If you have some fixed
3409 args, pass the first as ARG1, then cons any remaining fixed args
3410 onto the front of your argument list, and pass that as ARGS. */
3413 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3415 #ifdef DEBUG_EXTENSIONS
3417 scm_t_debug_frame debug
;
3418 scm_t_debug_info debug_vect_body
;
3419 debug
.prev
= scm_last_debug_frame
;
3420 debug
.status
= SCM_APPLYFRAME
;
3421 debug
.vect
= &debug_vect_body
;
3422 debug
.vect
[0].a
.proc
= proc
;
3423 debug
.vect
[0].a
.args
= SCM_EOL
;
3424 scm_last_debug_frame
= &debug
;
3427 return scm_dapply (proc
, arg1
, args
);
3431 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3433 /* If ARGS is the empty list, then we're calling apply with only two
3434 arguments --- ARG1 is the list of arguments for PROC. Whatever
3435 the case, futz with things so that ARG1 is the first argument to
3436 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3439 Setting the debug apply frame args this way is pretty messy.
3440 Perhaps we should store arg1 and args directly in the frame as
3441 received, and let scm_frame_arguments unpack them, because that's
3442 a relatively rare operation. This works for now; if the Guile
3443 developer archives are still around, see Mikael's post of
3445 if (SCM_NULLP (args
))
3447 if (SCM_NULLP (arg1
))
3449 arg1
= SCM_UNDEFINED
;
3451 debug
.vect
[0].a
.args
= SCM_EOL
;
3457 debug
.vect
[0].a
.args
= arg1
;
3459 args
= SCM_CDR (arg1
);
3460 arg1
= SCM_CAR (arg1
);
3465 args
= scm_nconc2last (args
);
3467 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3471 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3474 if (SCM_CHEAPTRAPS_P
)
3475 tmp
= scm_make_debugobj (&debug
);
3480 tmp
= scm_make_continuation (&first
);
3485 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3492 switch (SCM_TYP7 (proc
))
3494 case scm_tc7_subr_2o
:
3495 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3496 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3497 case scm_tc7_subr_2
:
3498 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3500 args
= SCM_CAR (args
);
3501 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3502 case scm_tc7_subr_0
:
3503 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3504 RETURN (SCM_SUBRF (proc
) ());
3505 case scm_tc7_subr_1
:
3506 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3507 case scm_tc7_subr_1o
:
3508 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3509 RETURN (SCM_SUBRF (proc
) (arg1
));
3511 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3512 if (SCM_SUBRF (proc
))
3514 if (SCM_INUMP (arg1
))
3516 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3518 else if (SCM_REALP (arg1
))
3520 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3523 else if (SCM_BIGP (arg1
))
3524 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3526 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3527 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3529 proc
= SCM_SNAME (proc
);
3531 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3532 while ('c' != *--chrs
)
3534 SCM_ASSERT (SCM_CONSP (arg1
),
3535 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3536 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3540 case scm_tc7_subr_3
:
3541 SCM_ASRTGO (!SCM_NULLP (args
)
3542 && !SCM_NULLP (SCM_CDR (args
))
3543 && SCM_NULLP (SCM_CDDR (args
)),
3545 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3548 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3550 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3552 case scm_tc7_lsubr_2
:
3553 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3554 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3556 if (SCM_NULLP (args
))
3557 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3558 while (SCM_NIMP (args
))
3560 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3561 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3562 args
= SCM_CDR (args
);
3565 case scm_tc7_rpsubr
:
3566 if (SCM_NULLP (args
))
3567 RETURN (SCM_BOOL_T
);
3568 while (SCM_NIMP (args
))
3570 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3571 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3572 RETURN (SCM_BOOL_F
);
3573 arg1
= SCM_CAR (args
);
3574 args
= SCM_CDR (args
);
3576 RETURN (SCM_BOOL_T
);
3577 case scm_tcs_closures
:
3579 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3581 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3583 #ifndef SCM_RECKLESS
3584 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3588 /* Copy argument list */
3593 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3594 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3596 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3600 SCM_SETCDR (tl
, arg1
);
3603 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3604 proc
= SCM_CDR (SCM_CODE (proc
));
3607 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3609 if (SCM_IMP (SCM_CAR (proc
)))
3611 if (SCM_ISYMP (SCM_CAR (proc
)))
3613 proc
= scm_m_expand_body (proc
, args
);
3617 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3620 SCM_CEVAL (SCM_CAR (proc
), args
);
3623 RETURN (EVALCAR (proc
, args
));
3625 if (!SCM_SMOB_APPLICABLE_P (proc
))
3627 if (SCM_UNBNDP (arg1
))
3628 RETURN (SCM_SMOB_APPLY_0 (proc
));
3629 else if (SCM_NULLP (args
))
3630 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3631 else if (SCM_NULLP (SCM_CDR (args
)))
3632 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3634 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3637 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3639 proc
= SCM_CCLO_SUBR (proc
);
3640 debug
.vect
[0].a
.proc
= proc
;
3641 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3643 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3645 proc
= SCM_CCLO_SUBR (proc
);
3649 proc
= SCM_PROCEDURE (proc
);
3651 debug
.vect
[0].a
.proc
= proc
;
3654 case scm_tcs_struct
:
3655 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3658 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3660 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3662 RETURN (scm_apply_generic (proc
, args
));
3664 else if (!SCM_I_OPERATORP (proc
))
3669 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3671 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3674 proc
= (SCM_I_ENTITYP (proc
)
3675 ? SCM_ENTITY_PROCEDURE (proc
)
3676 : SCM_OPERATOR_PROCEDURE (proc
));
3678 debug
.vect
[0].a
.proc
= proc
;
3679 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3681 if (SCM_NIMP (proc
))
3687 scm_wrong_num_args (proc
);
3690 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3695 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3696 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3698 SCM_CLEAR_TRACED_FRAME (debug
);
3699 if (SCM_CHEAPTRAPS_P
)
3700 arg1
= scm_make_debugobj (&debug
);
3704 SCM val
= scm_make_continuation (&first
);
3715 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3719 scm_last_debug_frame
= debug
.prev
;
3725 /* SECTION: The rest of this file is only read once.
3730 /* Typechecking for multi-argument MAP and FOR-EACH.
3732 Verify that each element of the vector ARGV, except for the first,
3733 is a proper list whose length is LEN. Attribute errors to WHO,
3734 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3736 check_map_args (SCM argv
,
3743 SCM
*ve
= SCM_VELTS (argv
);
3746 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3748 long elt_len
= scm_ilength (ve
[i
]);
3753 scm_apply_generic (gf
, scm_cons (proc
, args
));
3755 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3759 scm_out_of_range (who
, ve
[i
]);
3762 scm_remember_upto_here_1 (argv
);
3766 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3768 /* Note: Currently, scm_map applies PROC to the argument list(s)
3769 sequentially, starting with the first element(s). This is used in
3770 evalext.c where the Scheme procedure `map-in-order', which guarantees
3771 sequential behaviour, is implemented using scm_map. If the
3772 behaviour changes, we need to update `map-in-order'.
3776 scm_map (SCM proc
, SCM arg1
, SCM args
)
3777 #define FUNC_NAME s_map
3782 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3784 len
= scm_ilength (arg1
);
3785 SCM_GASSERTn (len
>= 0,
3786 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3787 SCM_VALIDATE_REST_ARGUMENT (args
);
3788 if (SCM_NULLP (args
))
3790 while (SCM_NIMP (arg1
))
3792 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3793 pres
= SCM_CDRLOC (*pres
);
3794 arg1
= SCM_CDR (arg1
);
3798 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3799 ve
= SCM_VELTS (args
);
3800 #ifndef SCM_RECKLESS
3801 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3806 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3808 if (SCM_IMP (ve
[i
]))
3810 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3811 ve
[i
] = SCM_CDR (ve
[i
]);
3813 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3814 pres
= SCM_CDRLOC (*pres
);
3820 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3823 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3824 #define FUNC_NAME s_for_each
3826 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3828 len
= scm_ilength (arg1
);
3829 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3830 SCM_ARG2
, s_for_each
);
3831 SCM_VALIDATE_REST_ARGUMENT (args
);
3834 while SCM_NIMP (arg1
)
3836 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3837 arg1
= SCM_CDR (arg1
);
3839 return SCM_UNSPECIFIED
;
3841 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3842 ve
= SCM_VELTS (args
);
3843 #ifndef SCM_RECKLESS
3844 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3849 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3852 (ve
[i
]) return SCM_UNSPECIFIED
;
3853 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3854 ve
[i
] = SCM_CDR (ve
[i
]);
3856 scm_apply (proc
, arg1
, SCM_EOL
);
3863 scm_closure (SCM code
, SCM env
)
3868 SCM_SETCODE (z
, code
);
3869 SCM_SETENV (z
, env
);
3874 scm_t_bits scm_tc16_promise
;
3877 scm_makprom (SCM code
)
3879 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3885 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3887 int writingp
= SCM_WRITINGP (pstate
);
3888 scm_puts ("#<promise ", port
);
3889 SCM_SET_WRITINGP (pstate
, 1);
3890 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3891 SCM_SET_WRITINGP (pstate
, writingp
);
3892 scm_putc ('>', port
);
3897 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3899 "If the promise @var{x} has not been computed yet, compute and\n"
3900 "return @var{x}, otherwise just return the previously computed\n"
3902 #define FUNC_NAME s_scm_force
3904 SCM_VALIDATE_SMOB (1, x
, promise
);
3905 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3907 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3908 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3911 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3912 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3916 return SCM_CELL_OBJECT_1 (x
);
3921 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3923 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3924 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3925 #define FUNC_NAME s_scm_promise_p
3927 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3932 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3933 (SCM xorig
, SCM x
, SCM y
),
3934 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3935 "Any source properties associated with @var{xorig} are also associated\n"
3936 "with the new pair.")
3937 #define FUNC_NAME s_scm_cons_source
3941 SCM_SET_CELL_OBJECT_0 (z
, x
);
3942 SCM_SET_CELL_OBJECT_1 (z
, 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");