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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
47 /* This file is read twice in order to produce debugging versions of
48 * scm_ceval and scm_apply. These functions, scm_deval and
49 * scm_dapply, are produced when we define the preprocessor macro
50 * DEVAL. The file is divided into sections which are treated
51 * differently with respect to DEVAL. The heads of these sections are
52 * marked with the string "SECTION:".
55 /* SECTION: This code is compiled once.
60 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
61 #include "libguile/scmconfig.h"
63 /* AIX requires this to be the first thing in the file. The #pragma
64 directive is indented so pre-ANSI compilers will ignore it, rather
73 # ifndef alloca /* predefined by HP cc +Olibcalls */
80 #include "libguile/_scm.h"
81 #include "libguile/debug.h"
82 #include "libguile/dynwind.h"
83 #include "libguile/alist.h"
84 #include "libguile/eq.h"
85 #include "libguile/continuations.h"
86 #include "libguile/throw.h"
87 #include "libguile/smob.h"
88 #include "libguile/macros.h"
89 #include "libguile/procprop.h"
90 #include "libguile/hashtab.h"
91 #include "libguile/hash.h"
92 #include "libguile/srcprop.h"
93 #include "libguile/stackchk.h"
94 #include "libguile/objects.h"
95 #include "libguile/async.h"
96 #include "libguile/feature.h"
97 #include "libguile/modules.h"
98 #include "libguile/ports.h"
99 #include "libguile/root.h"
100 #include "libguile/vectors.h"
101 #include "libguile/fluids.h"
102 #include "libguile/values.h"
104 #include "libguile/validate.h"
105 #include "libguile/eval.h"
109 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
111 if (SCM_EQ_P ((x), SCM_EOL)) \
112 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
117 /* The evaluator contains a plethora of EVAL symbols.
118 * This is an attempt at explanation.
120 * The following macros should be used in code which is read twice
121 * (where the choice of evaluator is hard soldered):
123 * SCM_CEVAL is the symbol used within one evaluator to call itself.
124 * Originally, it is defined to scm_ceval, but is redefined to
125 * scm_deval during the second pass.
127 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
128 * only side effects of expressions matter. All immediates are
131 * SCM_EVALIM is used when it is known that the expression is an
132 * immediate. (This macro never calls an evaluator.)
134 * EVALCAR evaluates the car of an expression.
136 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
137 * car is a lisp cell.
139 * The following macros should be used in code which is read once
140 * (where the choice of evaluator is dynamic):
142 * SCM_XEVAL takes care of immediates without calling an evaluator. It
143 * then calls scm_ceval *or* scm_deval, depending on the debugging
146 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
147 * depending on the debugging mode.
149 * The main motivation for keeping this plethora is efficiency
150 * together with maintainability (=> locality of code).
153 #define SCM_CEVAL scm_ceval
154 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
156 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
157 ? *scm_lookupcar (x, env, 1) \
158 : SCM_CEVAL (SCM_CAR (x), env))
160 #define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \
161 ? (SCM_IMP (SCM_CAR (x)) \
162 ? SCM_EVALIM (SCM_CAR (x), env) \
163 : SCM_GLOC_VAL (SCM_CAR (x))) \
164 : EVALCELLCAR (x, env))
166 #define EXTEND_ENV SCM_EXTEND_ENV
168 #ifdef MEMOIZE_LOCALS
171 scm_ilookup (SCM iloc
, SCM env
)
173 register long ir
= SCM_IFRAME (iloc
);
174 register SCM er
= env
;
175 for (; 0 != ir
; --ir
)
178 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
180 if (SCM_ICDRP (iloc
))
181 return SCM_CDRLOC (er
);
182 return SCM_CARLOC (SCM_CDR (er
));
188 /* The Lookup Car Race
191 Memoization of variables and special forms is done while executing
192 the code for the first time. As long as there is only one thread
193 everything is fine, but as soon as two threads execute the same
194 code concurrently `for the first time' they can come into conflict.
196 This memoization includes rewriting variable references into more
197 efficient forms and expanding macros. Furthermore, macro expansion
198 includes `compiling' special forms like `let', `cond', etc. into
199 tree-code instructions.
201 There shouldn't normally be a problem with memoizing local and
202 global variable references (into ilocs and glocs), because all
203 threads will mutate the code in *exactly* the same way and (if I
204 read the C code correctly) it is not possible to observe a half-way
205 mutated cons cell. The lookup procedure can handle this
206 transparently without any critical sections.
208 It is different with macro expansion, because macro expansion
209 happens outside of the lookup procedure and can't be
210 undone. Therefore it can't cope with it. It has to indicate
211 failure when it detects a lost race and hope that the caller can
212 handle it. Luckily, it turns out that this is the case.
214 An example to illustrate this: Suppose that the follwing form will
215 be memoized concurrently by two threads
219 Let's first examine the lookup of X in the body. The first thread
220 decides that it has to find the symbol "x" in the environment and
221 starts to scan it. Then the other thread takes over and actually
222 overtakes the first. It looks up "x" and substitutes an
223 appropriate iloc for it. Now the first thread continues and
224 completes its lookup. It comes to exactly the same conclusions as
225 the second one and could - without much ado - just overwrite the
226 iloc with the same iloc.
228 But let's see what will happen when the race occurs while looking
229 up the symbol "let" at the start of the form. It could happen that
230 the second thread interrupts the lookup of the first thread and not
231 only substitutes a gloc for it but goes right ahead and replaces it
232 with the compiled form (#@let* (x 12) x). Now, when the first
233 thread completes its lookup, it would replace the #@let* with a
234 gloc pointing to the "let" binding, effectively reverting the form
235 to (let (x 12) x). This is wrong. It has to detect that it has
236 lost the race and the evaluator has to reconsider the changed form
239 This race condition could be resolved with some kind of traffic
240 light (like mutexes) around scm_lookupcar, but I think that it is
241 best to avoid them in this case. They would serialize memoization
242 completely and because lookup involves calling arbitrary Scheme
243 code (via the lookup-thunk), threads could be blocked for an
244 arbitrary amount of time or even deadlock. But with the current
245 solution a lot of unnecessary work is potentially done. */
247 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
248 return NULL to indicate a failed lookup due to some race conditions
249 between threads. This only happens when VLOC is the first cell of
250 a special form that will eventually be memoized (like `let', etc.)
251 In that case the whole lookup is bogus and the caller has to
252 reconsider the complete special form.
254 SCM_LOOKUPCAR is still there, of course. It just calls
255 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
256 should only be called when it is known that VLOC is not the first
257 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
258 for NULL. I think I've found the only places where this
261 #endif /* USE_THREADS */
263 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
267 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
270 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
274 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
275 #ifdef MEMOIZE_LOCALS
276 register SCM iloc
= SCM_ILOC00
;
278 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
280 if (!SCM_CONSP (SCM_CAR (env
)))
282 al
= SCM_CARLOC (env
);
283 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
287 if (SCM_EQ_P (fl
, var
))
289 #ifdef MEMOIZE_LOCALS
291 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
294 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
296 return SCM_CDRLOC (*al
);
301 al
= SCM_CDRLOC (*al
);
302 if (SCM_EQ_P (SCM_CAR (fl
), var
))
304 #ifdef MEMOIZE_LOCALS
305 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
306 if (SCM_UNBNDP (SCM_CAR (*al
)))
313 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
316 SCM_SETCAR (vloc
, iloc
);
318 return SCM_CARLOC (*al
);
320 #ifdef MEMOIZE_LOCALS
321 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
324 #ifdef MEMOIZE_LOCALS
325 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
329 SCM top_thunk
, real_var
;
332 top_thunk
= SCM_CAR (env
); /* env now refers to a
333 top level env thunk */
337 top_thunk
= SCM_BOOL_F
;
338 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
339 if (SCM_FALSEP (real_var
))
343 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
346 /* scm_everr (vloc, genv,...) */
350 scm_error (scm_unbound_variable_key
, NULL
,
351 "Unbound variable: ~S",
352 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
354 scm_misc_error (NULL
, "Damaged environment: ~S",
355 scm_cons (var
, SCM_EOL
));
359 /* A variable could not be found, but we shall
360 not throw an error. */
361 static SCM undef_object
= SCM_UNDEFINED
;
362 return &undef_object
;
368 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
370 /* Some other thread has changed the very cell we are working
371 on. In effect, it must have done our job or messed it up
374 var
= SCM_CAR (vloc
);
375 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
376 return SCM_GLOC_VAL_LOC (var
);
377 #ifdef MEMOIZE_LOCALS
378 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
379 return scm_ilookup (var
, genv
);
381 /* We can't cope with anything else than glocs and ilocs. When
382 a special form has been memoized (i.e. `let' into `#@let') we
383 return NULL and expect the calling function to do the right
384 thing. For the evaluator, this means going back and redoing
385 the dispatch on the car of the form. */
388 #endif /* USE_THREADS */
390 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (real_var
) + scm_tc3_cons_gloc
);
391 return SCM_VARIABLE_LOC (real_var
);
397 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
399 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
406 #define unmemocar scm_unmemocar
408 SCM_SYMBOL (sym_three_question_marks
, "???");
411 scm_unmemocar (SCM form
, SCM env
)
418 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
421 scm_module_reverse_lookup (scm_env_module (env
), SCM_GLOC_VAR (c
));
422 if (SCM_EQ_P (sym
, SCM_BOOL_F
))
423 sym
= sym_three_question_marks
;
424 SCM_SETCAR (form
, sym
);
426 #ifdef MEMOIZE_LOCALS
427 #ifdef DEBUG_EXTENSIONS
428 else if (SCM_ILOCP (c
))
432 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
434 env
= SCM_CAR (SCM_CAR (env
));
435 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
437 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
446 scm_eval_car (SCM pair
, SCM env
)
448 return SCM_XEVALCAR (pair
, env
);
453 * The following rewrite expressions and
454 * some memoized forms have different syntax
457 const char scm_s_expression
[] = "missing or extra expression";
458 const char scm_s_test
[] = "bad test";
459 const char scm_s_body
[] = "bad body";
460 const char scm_s_bindings
[] = "bad bindings";
461 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
462 const char scm_s_variable
[] = "bad variable";
463 const char scm_s_clauses
[] = "bad or missing clauses";
464 const char scm_s_formals
[] = "bad formals";
465 const char scm_s_duplicate_formals
[] = "duplicate formals";
467 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
468 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
469 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
470 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
471 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
475 #ifdef DEBUG_EXTENSIONS
476 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
477 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
478 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
479 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
483 /* Check that the body denoted by XORIG is valid and rewrite it into
484 its internal form. The internal form of a body is just the body
485 itself, but prefixed with an ISYM that denotes to what kind of
486 outer construct this body belongs. A lambda body starts with
487 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
488 etc. The one exception is a body that belongs to a letrec that has
489 been formed by rewriting internal defines: it starts with
492 /* XXX - Besides controlling the rewriting of internal defines, the
493 additional ISYM could be used for improved error messages.
494 This is not done yet. */
497 scm_m_body (SCM op
, SCM xorig
, const char *what
)
499 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_expression
, what
);
501 /* Don't add another ISYM if one is present already. */
502 if (SCM_ISYMP (SCM_CAR (xorig
)))
505 /* Retain possible doc string. */
506 if (!SCM_CONSP (SCM_CAR (xorig
)))
508 if (SCM_NNULLP (SCM_CDR(xorig
)))
509 return scm_cons (SCM_CAR (xorig
),
510 scm_m_body (op
, SCM_CDR(xorig
), what
));
514 return scm_cons (op
, xorig
);
517 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
518 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
521 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
523 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
525 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
526 return scm_cons (SCM_IM_QUOTE
, x
);
531 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
532 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
535 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
537 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, scm_s_expression
, s_begin
);
538 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
541 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
542 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
545 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
547 long len
= scm_ilength (SCM_CDR (xorig
));
548 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, "if");
549 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
553 /* Will go into the RnRS module when Guile is factorized.
554 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
555 const char scm_s_set_x
[] = "set!";
556 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
559 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
561 SCM x
= SCM_CDR (xorig
);
562 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, scm_s_set_x
);
563 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
564 return scm_cons (SCM_IM_SET_X
, x
);
568 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
569 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
572 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
574 long len
= scm_ilength (SCM_CDR (xorig
));
575 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
577 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
582 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
583 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
586 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
588 long len
= scm_ilength (SCM_CDR (xorig
));
589 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
591 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
597 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
598 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
601 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
603 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
604 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_clauses
, s_case
);
605 while (SCM_NIMP (x
= SCM_CDR (x
)))
608 SCM_ASSYNT (scm_ilength (proc
) >= 2, scm_s_clauses
, s_case
);
609 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
610 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
611 && SCM_NULLP (SCM_CDR (x
))),
612 scm_s_clauses
, s_case
);
614 return scm_cons (SCM_IM_CASE
, cdrx
);
618 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
619 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
623 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
625 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
626 long len
= scm_ilength (x
);
627 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
631 len
= scm_ilength (arg1
);
632 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
633 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
635 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
636 "bad ELSE clause", s_cond
);
637 SCM_SETCAR (arg1
, SCM_BOOL_T
);
639 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
640 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
641 "bad recipient", s_cond
);
644 return scm_cons (SCM_IM_COND
, cdrx
);
647 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
648 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
650 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
651 cdr of the last cons. (Thus, LIST is not required to be a proper
652 list and when OBJ also found in the improper ending.) */
655 scm_c_improper_memq (SCM obj
, SCM list
)
657 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
659 if (SCM_EQ_P (SCM_CAR (list
), obj
))
662 return SCM_EQ_P (list
, obj
);
666 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
668 SCM proc
, x
= SCM_CDR (xorig
);
669 if (scm_ilength (x
) < 2)
672 if (SCM_NULLP (proc
))
674 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
678 if (SCM_SYMBOLP (proc
))
680 if (SCM_NCONSP (proc
))
682 while (SCM_NIMP (proc
))
684 if (SCM_NCONSP (proc
))
686 if (!SCM_SYMBOLP (proc
))
691 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
693 else if (scm_c_improper_memq (SCM_CAR(proc
), SCM_CDR(proc
)))
694 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
695 proc
= SCM_CDR (proc
);
697 if (SCM_NNULLP (proc
))
700 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
704 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
705 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
708 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
709 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
713 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
715 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
716 long len
= scm_ilength (x
);
717 SCM_ASSYNT (len
>= 2, scm_s_body
, s_letstar
);
719 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_letstar
);
720 while (SCM_NIMP (proc
))
722 arg1
= SCM_CAR (proc
);
723 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_letstar
);
724 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_letstar
);
725 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
726 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
727 proc
= SCM_CDR (proc
);
729 x
= scm_cons (vars
, SCM_CDR (x
));
731 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
732 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
735 /* DO gets the most radically altered syntax
736 (do ((<var1> <init1> <step1>)
742 (do_mem (varn ... var2 var1)
743 (<init1> <init2> ... <initn>)
746 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
749 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
750 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
753 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
755 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
756 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
757 SCM
*initloc
= &inits
, *steploc
= &steps
;
758 long len
= scm_ilength (x
);
759 SCM_ASSYNT (len
>= 2, scm_s_test
, "do");
761 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, "do");
762 while (SCM_NIMP(proc
))
764 arg1
= SCM_CAR (proc
);
765 len
= scm_ilength (arg1
);
766 SCM_ASSYNT (2 == len
|| 3 == len
, scm_s_bindings
, "do");
767 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, "do");
768 /* vars reversed here, inits and steps reversed at evaluation */
769 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
770 arg1
= SCM_CDR (arg1
);
771 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
772 initloc
= SCM_CDRLOC (*initloc
);
773 arg1
= SCM_CDR (arg1
);
774 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
775 steploc
= SCM_CDRLOC (*steploc
);
776 proc
= SCM_CDR (proc
);
779 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
780 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
781 x
= scm_cons2 (vars
, inits
, x
);
782 return scm_cons (SCM_IM_DO
, x
);
785 /* evalcar is small version of inline EVALCAR when we don't care about
788 #define evalcar scm_eval_car
791 static SCM
iqq (SCM form
, SCM env
, long depth
);
793 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
794 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
797 scm_m_quasiquote (SCM xorig
, SCM env
)
799 SCM x
= SCM_CDR (xorig
);
800 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
801 return iqq (SCM_CAR (x
), env
, 1);
806 iqq (SCM form
, SCM env
, long depth
)
812 if (SCM_VECTORP (form
))
814 long i
= SCM_VECTOR_LENGTH (form
);
815 SCM
*data
= SCM_VELTS (form
);
818 tmp
= scm_cons (data
[i
], tmp
);
819 return scm_vector (iqq (tmp
, env
, depth
));
821 if (!SCM_CONSP (form
))
823 tmp
= SCM_CAR (form
);
824 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
829 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
833 form
= SCM_CDR (form
);
834 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
835 form
, SCM_ARG1
, s_quasiquote
);
837 return evalcar (form
, env
);
838 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
840 if (SCM_CONSP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
844 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
846 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
849 /* Here are acros which return values rather than code. */
851 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
852 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
855 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
857 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
858 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
862 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
863 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
866 scm_m_define (SCM x
, SCM env
)
870 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
873 while (SCM_CONSP (proc
))
874 { /* nested define syntax */
875 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
876 proc
= SCM_CAR (proc
);
878 SCM_ASSYNT (SCM_SYMBOLP (proc
), scm_s_variable
, s_define
);
879 SCM_ASSYNT (1 == scm_ilength (x
), scm_s_expression
, s_define
);
880 if (SCM_TOP_LEVEL (env
))
882 x
= evalcar (x
, env
);
883 #ifdef DEBUG_EXTENSIONS
884 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
888 if (SCM_CLOSUREP (arg1
)
889 /* Only the first definition determines the name. */
890 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
891 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
892 else if (SCM_MACROP (arg1
)
893 /* Dirk::FIXME: Does the following test make sense? */
894 && !SCM_EQ_P (SCM_MACRO_CODE (arg1
), arg1
))
896 arg1
= SCM_MACRO_CODE (arg1
);
901 arg1
= scm_sym2var (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
902 SCM_VARIABLE_SET (arg1
, x
);
904 return scm_cons2 (scm_sym_quote
, proc
, SCM_EOL
);
906 return SCM_UNSPECIFIED
;
909 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
915 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env SCM_UNUSED
)
917 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
918 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
919 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
920 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
923 SCM_ASSYNT (scm_ilength (proc
) >= 1, scm_s_bindings
, what
);
926 /* vars scm_list reversed here, inits reversed at evaluation */
927 arg1
= SCM_CAR (proc
);
928 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, what
);
929 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, what
);
930 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
931 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
932 vars
= scm_cons (SCM_CAR (arg1
), vars
);
933 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
934 initloc
= SCM_CDRLOC (*initloc
);
936 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
938 return scm_cons2 (op
, vars
,
939 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
942 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
943 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
946 scm_m_letrec (SCM xorig
, SCM env
)
948 SCM x
= SCM_CDR (xorig
);
949 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_letrec
);
951 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
952 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
953 scm_m_body (SCM_IM_LETREC
,
958 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
961 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
962 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
965 scm_m_let (SCM xorig
, SCM env
)
967 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
968 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
969 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
971 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
975 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
977 /* null or single binding, let* is faster */
978 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
979 scm_m_body (SCM_IM_LET
,
985 SCM_ASSYNT (SCM_NIMP (proc
), scm_s_bindings
, s_let
);
986 if (SCM_CONSP (proc
))
988 /* plain let, proc is <bindings> */
989 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
992 if (!SCM_SYMBOLP (proc
))
993 scm_misc_error (s_let
, scm_s_bindings
, SCM_EOL
); /* bad let */
994 name
= proc
; /* named let, build equiv letrec */
996 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
997 proc
= SCM_CAR (x
); /* bindings list */
998 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_let
);
999 while (SCM_NIMP (proc
))
1000 { /* vars and inits both in order */
1001 arg1
= SCM_CAR (proc
);
1002 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_let
);
1003 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_let
);
1004 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1005 varloc
= SCM_CDRLOC (*varloc
);
1006 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1007 initloc
= SCM_CDRLOC (*initloc
);
1008 proc
= SCM_CDR (proc
);
1011 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1012 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1013 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1015 scm_acons (name
, inits
, SCM_EOL
));
1016 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1020 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1021 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1022 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1025 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1027 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1028 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1032 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1033 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1037 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1039 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1040 scm_s_expression
, s_atcall_cc
);
1041 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1044 /* Multi-language support */
1046 SCM_GLOBAL_SYMBOL (scm_lisp_nil
, "nil");
1047 SCM_GLOBAL_SYMBOL (scm_lisp_t
, "t");
1049 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1052 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1054 long len
= scm_ilength (SCM_CDR (xorig
));
1055 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1056 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1059 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1062 scm_m_nil_ify (SCM xorig
, SCM env SCM_UNUSED
)
1064 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1065 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1068 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1071 scm_m_t_ify (SCM xorig
, SCM env SCM_UNUSED
)
1073 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1074 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1077 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1080 scm_m_0_cond (SCM xorig
, SCM env SCM_UNUSED
)
1082 long len
= scm_ilength (SCM_CDR (xorig
));
1083 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1084 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1087 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1090 scm_m_0_ify (SCM xorig
, SCM env SCM_UNUSED
)
1092 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1093 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1096 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1099 scm_m_1_ify (SCM xorig
, SCM env SCM_UNUSED
)
1101 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1102 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1105 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1108 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1110 SCM x
= SCM_CDR (xorig
), var
;
1111 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1112 var
= scm_symbol_fref (SCM_CAR (x
));
1113 SCM_ASSYNT (SCM_VARIABLEP (var
),
1114 "Symbol's function definition is void", NULL
);
1115 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
1119 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1122 scm_m_atbind (SCM xorig
, SCM env
)
1124 SCM x
= SCM_CDR (xorig
);
1125 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, "@bind");
1131 while (SCM_NIMP (SCM_CDR (env
)))
1132 env
= SCM_CDR (env
);
1133 env
= SCM_CAR (env
);
1134 if (SCM_CONSP (env
))
1139 while (SCM_NIMP (x
))
1141 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2var (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1144 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1147 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1148 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1151 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1153 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1154 scm_s_expression
, s_at_call_with_values
);
1155 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1159 scm_m_expand_body (SCM xorig
, SCM env
)
1161 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1162 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1164 while (SCM_NIMP (x
))
1166 SCM form
= SCM_CAR (x
);
1167 if (!SCM_CONSP (form
))
1169 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1172 form
= scm_macroexp (scm_cons_source (form
,
1177 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1179 defs
= scm_cons (SCM_CDR (form
), defs
);
1182 else if (!SCM_IMP (defs
))
1186 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1188 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1192 x
= scm_cons (form
, SCM_CDR (x
));
1197 SCM_ASSYNT (SCM_NIMP (x
), scm_s_body
, what
);
1198 if (SCM_NIMP (defs
))
1200 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1202 scm_cons2 (scm_sym_define
, defs
, x
),
1208 SCM_SETCAR (xorig
, SCM_CAR (x
));
1209 SCM_SETCDR (xorig
, SCM_CDR (x
));
1216 scm_macroexp (SCM x
, SCM env
)
1218 SCM res
, proc
, orig_sym
;
1220 /* Don't bother to produce error messages here. We get them when we
1221 eventually execute the code for real. */
1224 orig_sym
= SCM_CAR (x
);
1225 if (!SCM_SYMBOLP (orig_sym
))
1230 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1231 if (proc_ptr
== NULL
)
1233 /* We have lost the race. */
1239 proc
= *scm_lookupcar (x
, env
, 0);
1242 /* Only handle memoizing macros. `Acros' and `macros' are really
1243 special forms and should not be evaluated here. */
1245 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1248 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1249 res
= scm_apply (SCM_MACRO_CODE (proc
), x
, scm_cons (env
, scm_listofnull
));
1251 if (scm_ilength (res
) <= 0)
1252 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1255 SCM_SETCAR (x
, SCM_CAR (res
));
1256 SCM_SETCDR (x
, SCM_CDR (res
));
1262 /* scm_unmemocopy takes a memoized expression together with its
1263 * environment and rewrites it to its original form. Thus, it is the
1264 * inversion of the rewrite rules above. The procedure is not
1265 * optimized for speed. It's used in scm_iprin1 when printing the
1266 * code of a closure, in scm_procedure_source, in display_frame when
1267 * generating the source for a stackframe in a backtrace, and in
1268 * display_expression.
1270 * Unmemoizing is not a realiable process. You can not in general
1271 * expect to get the original source back.
1273 * However, GOOPS currently relies on this for method compilation.
1274 * This ought to change.
1277 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1280 unmemocopy (SCM x
, SCM env
)
1283 #ifdef DEBUG_EXTENSIONS
1286 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1288 #ifdef DEBUG_EXTENSIONS
1289 p
= scm_whash_lookup (scm_source_whash
, x
);
1291 switch (SCM_TYP7 (x
))
1293 case SCM_BIT8(SCM_IM_AND
):
1294 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1296 case SCM_BIT8(SCM_IM_BEGIN
):
1297 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1299 case SCM_BIT8(SCM_IM_CASE
):
1300 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1302 case SCM_BIT8(SCM_IM_COND
):
1303 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1305 case SCM_BIT8(SCM_IM_DO
):
1306 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1308 case SCM_BIT8(SCM_IM_IF
):
1309 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1311 case SCM_BIT8(SCM_IM_LET
):
1312 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1314 case SCM_BIT8(SCM_IM_LETREC
):
1317 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1321 f
= v
= SCM_CAR (x
);
1323 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1325 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1326 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1329 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1330 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1332 /* build transformed binding list */
1334 while (SCM_NIMP (v
))
1336 z
= scm_acons (SCM_CAR (v
),
1337 scm_cons (SCM_CAR (e
),
1338 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1340 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1346 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1348 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1352 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1355 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1356 /* body forms are now to be found in SCM_CDR (x)
1357 (this is how *real* code look like! :) */
1361 case SCM_BIT8(SCM_IM_LETSTAR
):
1369 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1372 y
= z
= scm_acons (SCM_CAR (b
),
1374 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1376 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1377 b
= SCM_CDR (SCM_CDR (b
));
1380 SCM_SETCDR (y
, SCM_EOL
);
1381 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1386 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1388 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1391 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1392 b
= SCM_CDR (SCM_CDR (b
));
1394 while (SCM_NIMP (b
));
1395 SCM_SETCDR (z
, SCM_EOL
);
1397 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1400 case SCM_BIT8(SCM_IM_OR
):
1401 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1403 case SCM_BIT8(SCM_IM_LAMBDA
):
1405 ls
= scm_cons (scm_sym_lambda
,
1406 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1407 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1409 case SCM_BIT8(SCM_IM_QUOTE
):
1410 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1412 case SCM_BIT8(SCM_IM_SET_X
):
1413 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1415 case SCM_BIT8(SCM_IM_DEFINE
):
1419 ls
= scm_cons (scm_sym_define
,
1420 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1421 if (SCM_NNULLP (env
))
1422 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1425 case SCM_BIT8(SCM_MAKISYM (0)):
1429 switch (SCM_ISYMNUM (z
))
1431 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1432 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1434 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1435 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1437 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1438 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1441 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1442 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1445 /* appease the Sun compiler god: */ ;
1449 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1454 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1456 if (SCM_ISYMP (SCM_CAR (x
)))
1457 /* skip body markers */
1459 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1465 #ifdef DEBUG_EXTENSIONS
1466 if (SCM_NFALSEP (p
))
1467 scm_whash_insert (scm_source_whash
, ls
, p
);
1474 scm_unmemocopy (SCM x
, SCM env
)
1476 if (SCM_NNULLP (env
))
1477 /* Make a copy of the lowest frame to protect it from
1478 modifications by SCM_IM_DEFINE */
1479 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1481 return unmemocopy (x
, env
);
1484 #ifndef SCM_RECKLESS
1487 scm_badargsp (SCM formals
, SCM args
)
1489 while (SCM_NIMP (formals
))
1491 if (SCM_NCONSP (formals
))
1495 formals
= SCM_CDR (formals
);
1496 args
= SCM_CDR (args
);
1498 return SCM_NNULLP (args
) ? 1 : 0;
1503 scm_badformalsp (SCM closure
, int n
)
1505 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1506 while (!SCM_NULLP (formals
))
1508 if (!SCM_CONSP (formals
))
1513 formals
= SCM_CDR (formals
);
1520 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1522 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1523 while (!SCM_IMP (l
))
1528 if (SCM_IMP (SCM_CAR (l
)))
1529 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1531 res
= EVALCELLCAR (l
, env
);
1533 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1536 SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1538 res
= SCM_CAR (l
); /* struct planted in code */
1540 res
= SCM_GLOC_VAL (SCM_CAR (l
));
1545 res
= EVALCAR (l
, env
);
1547 *lloc
= scm_cons (res
, SCM_EOL
);
1548 lloc
= SCM_CDRLOC (*lloc
);
1555 scm_wrong_num_args (proc
);
1562 scm_eval_body (SCM code
, SCM env
)
1567 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1569 if (SCM_IMP (SCM_CAR (code
)))
1571 if (SCM_ISYMP (SCM_CAR (code
)))
1573 code
= scm_m_expand_body (code
, env
);
1578 SCM_XEVAL (SCM_CAR (code
), env
);
1581 return SCM_XEVALCAR (code
, env
);
1588 /* SECTION: This code is specific for the debugging support. One
1589 * branch is read when DEVAL isn't defined, the other when DEVAL is
1595 #define SCM_APPLY scm_apply
1596 #define PREP_APPLY(proc, args)
1598 #define RETURN(x) return x;
1599 #ifdef STACK_CHECKING
1600 #ifndef NO_CEVAL_STACK_CHECKING
1601 #define EVAL_STACK_CHECKING
1608 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1610 #define SCM_APPLY scm_dapply
1612 #define PREP_APPLY(p, l) \
1613 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1615 #define ENTER_APPLY \
1617 SCM_SET_ARGSREADY (debug);\
1618 if (CHECK_APPLY && SCM_TRAPS_P)\
1619 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1621 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1622 SCM_SET_TRACED_FRAME (debug); \
1623 if (SCM_CHEAPTRAPS_P)\
1625 tmp = scm_make_debugobj (&debug);\
1626 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1631 tmp = scm_make_continuation (&first);\
1633 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1638 #define RETURN(e) {proc = (e); goto exit;}
1639 #ifdef STACK_CHECKING
1640 #ifndef EVAL_STACK_CHECKING
1641 #define EVAL_STACK_CHECKING
1645 /* scm_ceval_ptr points to the currently selected evaluator.
1646 * *fixme*: Although efficiency is important here, this state variable
1647 * should probably not be a global. It should be related to the
1652 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1654 /* scm_last_debug_frame contains a pointer to the last debugging
1655 * information stack frame. It is accessed very often from the
1656 * debugging evaluator, so it should probably not be indirectly
1657 * addressed. Better to save and restore it from the current root at
1662 scm_t_debug_frame
*scm_last_debug_frame
;
1665 /* scm_debug_eframe_size is the number of slots available for pseudo
1666 * stack frames at each real stack frame.
1669 long scm_debug_eframe_size
;
1671 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1673 long scm_eval_stack
;
1675 scm_t_option scm_eval_opts
[] = {
1676 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1679 scm_t_option scm_debug_opts
[] = {
1680 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1681 "*Flyweight representation of the stack at traps." },
1682 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1683 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1684 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1685 "Record procedure names at definition." },
1686 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1687 "Display backtrace in anti-chronological order." },
1688 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1689 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1690 { SCM_OPTION_INTEGER
, "frames", 3,
1691 "Maximum number of tail-recursive frames in backtrace." },
1692 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1693 "Maximal number of stored backtrace frames." },
1694 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1695 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1696 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1697 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1698 { SCM_OPTION_SCM
, "show-file-name", 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."}
1701 scm_t_option scm_evaluator_trap_table
[] = {
1702 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1703 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1704 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1705 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1708 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1710 "Option interface for the evaluation options. Instead of using\n"
1711 "this procedure directly, use the procedures @code{eval-enable},\n"
1712 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1713 #define FUNC_NAME s_scm_eval_options_interface
1717 ans
= scm_options (setting
,
1721 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1727 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1729 "Option interface for the evaluator trap options.")
1730 #define FUNC_NAME s_scm_evaluator_traps
1734 ans
= scm_options (setting
,
1735 scm_evaluator_trap_table
,
1736 SCM_N_EVALUATOR_TRAPS
,
1738 SCM_RESET_DEBUG_MODE
;
1745 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1747 SCM
*results
= lloc
, res
;
1748 while (!SCM_IMP (l
))
1753 if (SCM_IMP (SCM_CAR (l
)))
1754 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1756 res
= EVALCELLCAR (l
, env
);
1758 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1761 SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1763 res
= SCM_CAR (l
); /* struct planted in code */
1765 res
= SCM_GLOC_VAL (SCM_CAR (l
));
1770 res
= EVALCAR (l
, env
);
1772 *lloc
= scm_cons (res
, SCM_EOL
);
1773 lloc
= SCM_CDRLOC (*lloc
);
1780 scm_wrong_num_args (proc
);
1789 /* SECTION: Some local definitions for the evaluator.
1792 /* Update the toplevel environment frame ENV so that it refers to the
1795 #define UPDATE_TOPLEVEL_ENV(env) \
1797 SCM p = scm_current_module_lookup_closure (); \
1798 if (p != SCM_CAR(env)) \
1799 env = scm_top_level_env (p); \
1803 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1806 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1808 /* SECTION: This is the evaluator. Like any real monster, it has
1809 * three heads. This code is compiled twice.
1815 scm_ceval (SCM x
, SCM env
)
1821 scm_deval (SCM x
, SCM env
)
1826 SCM_CEVAL (SCM x
, SCM env
)
1833 SCM proc
, arg2
, orig_sym
;
1835 scm_t_debug_frame debug
;
1836 scm_t_debug_info
*debug_info_end
;
1837 debug
.prev
= scm_last_debug_frame
;
1838 debug
.status
= scm_debug_eframe_size
;
1840 * The debug.vect contains twice as much scm_t_debug_info frames as the
1841 * user has specified with (debug-set! frames <n>).
1843 * Even frames are eval frames, odd frames are apply frames.
1845 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1846 * sizeof (debug
.vect
[0]));
1847 debug
.info
= debug
.vect
;
1848 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1849 scm_last_debug_frame
= &debug
;
1851 #ifdef EVAL_STACK_CHECKING
1852 if (scm_stack_checking_enabled_p
1853 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1856 debug
.info
->e
.exp
= x
;
1857 debug
.info
->e
.env
= env
;
1859 scm_report_stack_overflow ();
1866 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1869 SCM_CLEAR_ARGSREADY (debug
);
1870 if (SCM_OVERFLOWP (debug
))
1873 * In theory, this should be the only place where it is necessary to
1874 * check for space in debug.vect since both eval frames and
1875 * available space are even.
1877 * For this to be the case, however, it is necessary that primitive
1878 * special forms which jump back to `loop', `begin' or some similar
1879 * label call PREP_APPLY. A convenient way to do this is to jump to
1880 * `loopnoap' or `cdrxnoap'.
1882 else if (++debug
.info
>= debug_info_end
)
1884 SCM_SET_OVERFLOW (debug
);
1888 debug
.info
->e
.exp
= x
;
1889 debug
.info
->e
.env
= env
;
1890 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1891 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1893 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1894 SCM_SET_TAILREC (debug
);
1895 if (SCM_CHEAPTRAPS_P
)
1896 t
.arg1
= scm_make_debugobj (&debug
);
1900 SCM val
= scm_make_continuation (&first
);
1912 /* This gives the possibility for the debugger to
1913 modify the source expression before evaluation. */
1917 scm_ithrow (scm_sym_enter_frame
,
1918 scm_cons2 (t
.arg1
, tail
,
1919 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1923 #if defined (USE_THREADS) || defined (DEVAL)
1927 switch (SCM_TYP7 (x
))
1929 case scm_tc7_symbol
:
1930 /* Only happens when called at top level.
1932 x
= scm_cons (x
, SCM_UNDEFINED
);
1935 case SCM_BIT8(SCM_IM_AND
):
1938 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1939 if (SCM_FALSEP (EVALCAR (x
, env
)))
1941 RETURN (SCM_BOOL_F
);
1945 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1948 case SCM_BIT8(SCM_IM_BEGIN
):
1949 /* (currently unused)
1951 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1952 /* (currently unused)
1957 /* If we are on toplevel with a lookup closure, we need to sync
1958 with the current module. */
1959 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1962 UPDATE_TOPLEVEL_ENV (env
);
1963 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1967 UPDATE_TOPLEVEL_ENV (env
);
1972 goto nontoplevel_begin
;
1974 nontoplevel_cdrxnoap
:
1975 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1976 nontoplevel_cdrxbegin
:
1980 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1982 if (SCM_IMP (SCM_CAR (x
)))
1984 if (SCM_ISYMP (SCM_CAR (x
)))
1986 x
= scm_m_expand_body (x
, env
);
1987 goto nontoplevel_begin
;
1990 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
1993 SCM_CEVAL (SCM_CAR (x
), env
);
1997 carloop
: /* scm_eval car of last form in list */
1998 if (!SCM_CELLP (SCM_CAR (x
)))
2001 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
2004 if (SCM_SYMBOLP (SCM_CAR (x
)))
2007 RETURN (*scm_lookupcar (x
, env
, 1))
2011 goto loop
; /* tail recurse */
2014 case SCM_BIT8(SCM_IM_CASE
):
2016 t
.arg1
= EVALCAR (x
, env
);
2017 while (SCM_NIMP (x
= SCM_CDR (x
)))
2020 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2023 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2026 proc
= SCM_CAR (proc
);
2027 while (SCM_NIMP (proc
))
2029 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2031 x
= SCM_CDR (SCM_CAR (x
));
2032 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2035 proc
= SCM_CDR (proc
);
2038 RETURN (SCM_UNSPECIFIED
)
2041 case SCM_BIT8(SCM_IM_COND
):
2042 while (!SCM_IMP (x
= SCM_CDR (x
)))
2045 t
.arg1
= EVALCAR (proc
, env
);
2046 if (SCM_NFALSEP (t
.arg1
))
2053 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2055 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2059 proc
= EVALCAR (proc
, env
);
2060 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2061 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2063 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2064 goto umwrongnumargs
;
2068 RETURN (SCM_UNSPECIFIED
)
2071 case SCM_BIT8(SCM_IM_DO
):
2073 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2074 t
.arg1
= SCM_EOL
; /* values */
2075 while (SCM_NIMP (proc
))
2077 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2078 proc
= SCM_CDR (proc
);
2080 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2081 x
= SCM_CDR (SCM_CDR (x
));
2082 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2084 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2086 t
.arg1
= SCM_CAR (proc
); /* body */
2087 SIDEVAL (t
.arg1
, env
);
2089 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2091 proc
= SCM_CDR (proc
))
2092 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2093 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2097 RETURN (SCM_UNSPECIFIED
);
2098 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2099 goto nontoplevel_begin
;
2102 case SCM_BIT8(SCM_IM_IF
):
2104 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2106 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2108 RETURN (SCM_UNSPECIFIED
);
2110 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2114 case SCM_BIT8(SCM_IM_LET
):
2116 proc
= SCM_CAR (SCM_CDR (x
));
2120 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2122 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2123 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2125 goto nontoplevel_cdrxnoap
;
2128 case SCM_BIT8(SCM_IM_LETREC
):
2130 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2136 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2138 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2139 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2140 goto nontoplevel_cdrxnoap
;
2143 case SCM_BIT8(SCM_IM_LETSTAR
):
2148 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2149 goto nontoplevel_cdrxnoap
;
2153 t
.arg1
= SCM_CAR (proc
);
2154 proc
= SCM_CDR (proc
);
2155 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2157 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2158 goto nontoplevel_cdrxnoap
;
2160 case SCM_BIT8(SCM_IM_OR
):
2163 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2165 x
= EVALCAR (x
, env
);
2166 if (!SCM_FALSEP (x
))
2172 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2176 case SCM_BIT8(SCM_IM_LAMBDA
):
2177 RETURN (scm_closure (SCM_CDR (x
), env
));
2180 case SCM_BIT8(SCM_IM_QUOTE
):
2181 RETURN (SCM_CAR (SCM_CDR (x
)));
2184 case SCM_BIT8(SCM_IM_SET_X
):
2187 switch (SCM_ITAG3 (proc
))
2190 t
.lloc
= scm_lookupcar (x
, env
, 1);
2192 case scm_tc3_cons_gloc
:
2193 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2195 #ifdef MEMOIZE_LOCALS
2197 t
.lloc
= scm_ilookup (proc
, env
);
2202 *t
.lloc
= EVALCAR (x
, env
);
2206 RETURN (SCM_UNSPECIFIED
);
2210 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2211 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2213 /* new syntactic forms go here. */
2214 case SCM_BIT8(SCM_MAKISYM (0)):
2216 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2217 switch SCM_ISYMNUM (proc
)
2219 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2221 proc
= EVALCAR (proc
, env
);
2222 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2223 if (SCM_CLOSUREP (proc
))
2226 PREP_APPLY (proc
, SCM_EOL
);
2227 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2228 t
.arg1
= EVALCAR (t
.arg1
, env
);
2230 /* Go here to tail-call a closure. PROC is the closure
2231 and T.ARG1 is the list of arguments. Do not forget to
2234 debug
.info
->a
.args
= t
.arg1
;
2236 #ifndef SCM_RECKLESS
2237 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2241 /* Copy argument list */
2242 if (SCM_IMP (t
.arg1
))
2246 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2247 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2248 && SCM_CONSP (t
.arg1
))
2250 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2254 SCM_SETCDR (tl
, t
.arg1
);
2257 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2258 x
= SCM_CODE (proc
);
2259 goto nontoplevel_cdrxbegin
;
2264 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2267 SCM val
= scm_make_continuation (&first
);
2275 proc
= evalcar (proc
, env
);
2276 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2277 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2279 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2280 goto umwrongnumargs
;
2283 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2284 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2286 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2287 proc
= SCM_CADR (x
); /* unevaluated operands */
2288 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2290 arg2
= *scm_ilookup (proc
, env
);
2291 else if (SCM_NCONSP (proc
))
2293 if (SCM_NCELLP (proc
))
2294 arg2
= SCM_GLOC_VAL (proc
);
2296 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2300 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2301 t
.lloc
= SCM_CDRLOC (arg2
);
2302 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2304 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2305 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2310 /* The type dispatch code is duplicated here
2311 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2312 * cuts down execution time for type dispatch to 50%.
2315 long i
, n
, end
, mask
;
2316 SCM z
= SCM_CDDR (x
);
2317 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2318 proc
= SCM_CADR (z
);
2320 if (SCM_NIMP (proc
))
2322 /* Prepare for linear search */
2325 end
= SCM_VECTOR_LENGTH (proc
);
2329 /* Compute a hash value */
2330 long hashset
= SCM_INUM (proc
);
2333 mask
= SCM_INUM (SCM_CAR (z
));
2334 proc
= SCM_CADR (z
);
2337 if (SCM_NIMP (t
.arg1
))
2340 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2341 [scm_si_hashsets
+ hashset
];
2342 t
.arg1
= SCM_CDR (t
.arg1
);
2344 while (j
-- && SCM_NIMP (t
.arg1
));
2349 /* Search for match */
2353 z
= SCM_VELTS (proc
)[i
];
2354 t
.arg1
= arg2
; /* list of arguments */
2355 if (SCM_NIMP (t
.arg1
))
2358 /* More arguments than specifiers => CLASS != ENV */
2359 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2361 t
.arg1
= SCM_CDR (t
.arg1
);
2364 while (j
-- && SCM_NIMP (t
.arg1
));
2365 /* Fewer arguments than specifiers => CAR != ENV */
2366 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2369 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2371 SCM_CMETHOD_ENV (z
));
2372 x
= SCM_CMETHOD_CODE (z
);
2373 goto nontoplevel_cdrxbegin
;
2378 z
= scm_memoize_method (x
, arg2
);
2382 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2384 t
.arg1
= EVALCAR (x
, env
);
2385 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2387 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2389 t
.arg1
= EVALCAR (x
, env
);
2392 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2393 = SCM_UNPACK (EVALCAR (proc
, env
));
2394 RETURN (SCM_UNSPECIFIED
)
2396 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2398 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2400 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2401 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2403 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2405 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2411 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2414 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2416 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2420 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2422 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2424 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2426 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2428 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2429 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2431 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2433 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2439 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2442 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2444 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2448 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2450 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2454 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2457 t
.arg1
= SCM_CAR (x
);
2458 arg2
= SCM_CDAR (env
);
2459 while (SCM_NIMP (arg2
))
2461 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2462 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2464 SCM_SETCAR (arg2
, proc
);
2465 t
.arg1
= SCM_CDR (t
.arg1
);
2466 arg2
= SCM_CDR (arg2
);
2468 t
.arg1
= SCM_CAR (x
);
2469 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2471 arg2
= x
= SCM_CDR (x
);
2472 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2474 SIDEVAL (SCM_CAR (x
), env
);
2477 proc
= EVALCAR (x
, env
);
2479 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2480 arg2
= SCM_CDAR (env
);
2481 while (SCM_NIMP (arg2
))
2483 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2485 t
.arg1
= SCM_CDR (t
.arg1
);
2486 arg2
= SCM_CDR (arg2
);
2491 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2494 x
= EVALCAR (proc
, env
);
2495 proc
= SCM_CDR (proc
);
2496 proc
= EVALCAR (proc
, env
);
2497 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2498 if (SCM_VALUESP (t
.arg1
))
2499 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2501 t
.arg1
= scm_cons (t
.arg1
, SCM_EOL
);
2502 if (SCM_CLOSUREP (proc
))
2504 PREP_APPLY (proc
, t
.arg1
);
2507 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2517 /* scm_everr (x, env,...) */
2518 scm_misc_error (NULL
, "Wrong type to apply: ~S", SCM_LIST1 (proc
));
2519 case scm_tc7_vector
:
2523 case scm_tc7_byvect
:
2530 #ifdef HAVE_LONG_LONGS
2531 case scm_tc7_llvect
:
2534 case scm_tc7_string
:
2535 case scm_tc7_substring
:
2537 case scm_tcs_closures
:
2543 #ifdef MEMOIZE_LOCALS
2544 case SCM_BIT8(SCM_ILOC00
):
2545 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2546 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2547 #ifndef SCM_RECKLESS
2553 #endif /* ifdef MEMOIZE_LOCALS */
2556 case scm_tcs_cons_gloc
: {
2557 scm_t_bits vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2559 /* This is a struct implanted in the code, not a gloc. */
2562 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2563 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2564 #ifndef SCM_RECKLESS
2573 case scm_tcs_cons_nimcar
:
2574 orig_sym
= SCM_CAR (x
);
2575 if (SCM_SYMBOLP (orig_sym
))
2578 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2581 /* we have lost the race, start again. */
2586 proc
= *scm_lookupcar (x
, env
, 1);
2591 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2595 if (SCM_MACROP (proc
))
2597 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2601 /* Set a flag during macro expansion so that macro
2602 application frames can be deleted from the backtrace. */
2603 SCM_SET_MACROEXP (debug
);
2605 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2606 scm_cons (env
, scm_listofnull
));
2609 SCM_CLEAR_MACROEXP (debug
);
2611 switch (SCM_MACRO_TYPE (proc
))
2614 if (scm_ilength (t
.arg1
) <= 0)
2615 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2617 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2620 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2621 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2625 /* Prevent memoizing of debug info expression. */
2626 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2631 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2632 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2636 if (SCM_NIMP (x
= t
.arg1
))
2644 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2645 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2646 #ifndef SCM_RECKLESS
2650 if (SCM_CLOSUREP (proc
))
2652 arg2
= SCM_CLOSURE_FORMALS (proc
);
2653 t
.arg1
= SCM_CDR (x
);
2654 while (!SCM_NULLP (arg2
))
2656 if (!SCM_CONSP (arg2
))
2658 if (SCM_IMP (t
.arg1
))
2659 goto umwrongnumargs
;
2660 arg2
= SCM_CDR (arg2
);
2661 t
.arg1
= SCM_CDR (t
.arg1
);
2663 if (!SCM_NULLP (t
.arg1
))
2664 goto umwrongnumargs
;
2666 else if (SCM_MACROP (proc
))
2667 goto handle_a_macro
;
2673 PREP_APPLY (proc
, SCM_EOL
);
2674 if (SCM_NULLP (SCM_CDR (x
))) {
2677 switch (SCM_TYP7 (proc
))
2678 { /* no arguments given */
2679 case scm_tc7_subr_0
:
2680 RETURN (SCM_SUBRF (proc
) ());
2681 case scm_tc7_subr_1o
:
2682 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2684 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2685 case scm_tc7_rpsubr
:
2686 RETURN (SCM_BOOL_T
);
2688 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2690 if (!SCM_SMOB_APPLICABLE_P (proc
))
2692 RETURN (SCM_SMOB_APPLY_0 (proc
));
2695 proc
= SCM_CCLO_SUBR (proc
);
2697 debug
.info
->a
.proc
= proc
;
2698 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2702 proc
= SCM_PROCEDURE (proc
);
2704 debug
.info
->a
.proc
= proc
;
2706 if (!SCM_CLOSUREP (proc
))
2708 if (scm_badformalsp (proc
, 0))
2709 goto umwrongnumargs
;
2710 case scm_tcs_closures
:
2711 x
= SCM_CODE (proc
);
2712 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2713 goto nontoplevel_cdrxbegin
;
2714 case scm_tcs_cons_gloc
: /* really structs, not glocs */
2715 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2717 x
= SCM_ENTITY_PROCEDURE (proc
);
2721 else if (!SCM_I_OPERATORP (proc
))
2726 proc
= (SCM_I_ENTITYP (proc
)
2727 ? SCM_ENTITY_PROCEDURE (proc
)
2728 : SCM_OPERATOR_PROCEDURE (proc
));
2730 debug
.info
->a
.proc
= proc
;
2731 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2733 if (SCM_NIMP (proc
))
2738 case scm_tc7_subr_1
:
2739 case scm_tc7_subr_2
:
2740 case scm_tc7_subr_2o
:
2742 case scm_tc7_subr_3
:
2743 case scm_tc7_lsubr_2
:
2747 /* scm_everr (x, env,...) */
2748 scm_wrong_num_args (proc
);
2750 /* handle macros here */
2755 /* must handle macros by here */
2760 else if (SCM_CONSP (x
))
2762 if (SCM_IMP (SCM_CAR (x
)))
2763 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2765 t
.arg1
= EVALCELLCAR (x
, env
);
2767 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2769 scm_t_bits vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2771 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2773 t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
));
2778 t
.arg1
= EVALCAR (x
, env
);
2781 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2788 switch (SCM_TYP7 (proc
))
2789 { /* have one argument in t.arg1 */
2790 case scm_tc7_subr_2o
:
2791 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2792 case scm_tc7_subr_1
:
2793 case scm_tc7_subr_1o
:
2794 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2796 if (SCM_SUBRF (proc
))
2798 if (SCM_INUMP (t
.arg1
))
2800 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2802 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2803 if (SCM_REALP (t
.arg1
))
2805 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2808 if (SCM_BIGP (t
.arg1
))
2810 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2814 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2815 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2817 proc
= SCM_SNAME (proc
);
2819 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2820 while ('c' != *--chrs
)
2822 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2823 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2824 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2828 case scm_tc7_rpsubr
:
2829 RETURN (SCM_BOOL_T
);
2831 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2834 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2836 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2839 if (!SCM_SMOB_APPLICABLE_P (proc
))
2841 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2845 proc
= SCM_CCLO_SUBR (proc
);
2847 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2848 debug
.info
->a
.proc
= proc
;
2852 proc
= SCM_PROCEDURE (proc
);
2854 debug
.info
->a
.proc
= proc
;
2856 if (!SCM_CLOSUREP (proc
))
2858 if (scm_badformalsp (proc
, 1))
2859 goto umwrongnumargs
;
2860 case scm_tcs_closures
:
2862 x
= SCM_CODE (proc
);
2864 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2866 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2868 goto nontoplevel_cdrxbegin
;
2869 case scm_tcs_cons_gloc
: /* really structs, not glocs */
2870 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2872 x
= SCM_ENTITY_PROCEDURE (proc
);
2874 arg2
= debug
.info
->a
.args
;
2876 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2880 else if (!SCM_I_OPERATORP (proc
))
2886 proc
= (SCM_I_ENTITYP (proc
)
2887 ? SCM_ENTITY_PROCEDURE (proc
)
2888 : SCM_OPERATOR_PROCEDURE (proc
));
2890 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2891 debug
.info
->a
.proc
= proc
;
2893 if (SCM_NIMP (proc
))
2898 case scm_tc7_subr_2
:
2899 case scm_tc7_subr_0
:
2900 case scm_tc7_subr_3
:
2901 case scm_tc7_lsubr_2
:
2910 else if (SCM_CONSP (x
))
2912 if (SCM_IMP (SCM_CAR (x
)))
2913 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2915 arg2
= EVALCELLCAR (x
, env
);
2917 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2919 scm_t_bits vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2921 arg2
= SCM_CAR (x
); /* struct planted in code */
2923 arg2
= SCM_GLOC_VAL (SCM_CAR (x
));
2928 arg2
= EVALCAR (x
, env
);
2930 { /* have two or more arguments */
2932 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2935 if (SCM_NULLP (x
)) {
2938 switch (SCM_TYP7 (proc
))
2939 { /* have two arguments */
2940 case scm_tc7_subr_2
:
2941 case scm_tc7_subr_2o
:
2942 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2945 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2947 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2949 case scm_tc7_lsubr_2
:
2950 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2951 case scm_tc7_rpsubr
:
2953 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2955 if (!SCM_SMOB_APPLICABLE_P (proc
))
2957 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2961 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2962 scm_cons (proc
, debug
.info
->a
.args
),
2965 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2966 scm_cons2 (proc
, t
.arg1
,
2973 case scm_tcs_cons_gloc
: /* really structs, not glocs */
2974 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2976 x
= SCM_ENTITY_PROCEDURE (proc
);
2978 arg2
= debug
.info
->a
.args
;
2980 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2984 else if (!SCM_I_OPERATORP (proc
))
2990 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2991 ? SCM_ENTITY_PROCEDURE (proc
)
2992 : SCM_OPERATOR_PROCEDURE (proc
),
2993 scm_cons (proc
, debug
.info
->a
.args
),
2996 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2997 ? SCM_ENTITY_PROCEDURE (proc
)
2998 : SCM_OPERATOR_PROCEDURE (proc
),
2999 scm_cons2 (proc
, t
.arg1
,
3007 case scm_tc7_subr_0
:
3009 case scm_tc7_subr_1o
:
3010 case scm_tc7_subr_1
:
3011 case scm_tc7_subr_3
:
3016 proc
= SCM_PROCEDURE (proc
);
3018 debug
.info
->a
.proc
= proc
;
3020 if (!SCM_CLOSUREP (proc
))
3022 if (scm_badformalsp (proc
, 2))
3023 goto umwrongnumargs
;
3024 case scm_tcs_closures
:
3027 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3031 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3032 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
3034 x
= SCM_CODE (proc
);
3035 goto nontoplevel_cdrxbegin
;
3039 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3043 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3044 scm_deval_args (x
, env
, proc
,
3045 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3049 switch (SCM_TYP7 (proc
))
3050 { /* have 3 or more arguments */
3052 case scm_tc7_subr_3
:
3053 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3054 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3055 SCM_CADDR (debug
.info
->a
.args
)));
3057 #ifdef BUILTIN_RPASUBR
3058 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3059 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3062 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3063 arg2
= SCM_CDR (arg2
);
3065 while (SCM_NIMP (arg2
));
3067 #endif /* BUILTIN_RPASUBR */
3068 case scm_tc7_rpsubr
:
3069 #ifdef BUILTIN_RPASUBR
3070 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3072 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3075 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3077 arg2
= SCM_CAR (t
.arg1
);
3078 t
.arg1
= SCM_CDR (t
.arg1
);
3080 while (SCM_NIMP (t
.arg1
));
3082 #else /* BUILTIN_RPASUBR */
3083 RETURN (SCM_APPLY (proc
, t
.arg1
,
3085 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3087 #endif /* BUILTIN_RPASUBR */
3088 case scm_tc7_lsubr_2
:
3089 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3090 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3092 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3094 if (!SCM_SMOB_APPLICABLE_P (proc
))
3096 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3097 SCM_CDDR (debug
.info
->a
.args
)));
3101 proc
= SCM_PROCEDURE (proc
);
3102 debug
.info
->a
.proc
= proc
;
3103 if (!SCM_CLOSUREP (proc
))
3105 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3106 goto umwrongnumargs
;
3107 case scm_tcs_closures
:
3108 SCM_SET_ARGSREADY (debug
);
3109 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3112 x
= SCM_CODE (proc
);
3113 goto nontoplevel_cdrxbegin
;
3115 case scm_tc7_subr_3
:
3116 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3117 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3119 #ifdef BUILTIN_RPASUBR
3120 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3123 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3126 while (SCM_NIMP (x
));
3128 #endif /* BUILTIN_RPASUBR */
3129 case scm_tc7_rpsubr
:
3130 #ifdef BUILTIN_RPASUBR
3131 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3135 t
.arg1
= EVALCAR (x
, env
);
3136 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3141 while (SCM_NIMP (x
));
3143 #else /* BUILTIN_RPASUBR */
3144 RETURN (SCM_APPLY (proc
, t
.arg1
,
3146 scm_eval_args (x
, env
, proc
),
3148 #endif /* BUILTIN_RPASUBR */
3149 case scm_tc7_lsubr_2
:
3150 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3152 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3154 scm_eval_args (x
, env
, proc
))));
3156 if (!SCM_SMOB_APPLICABLE_P (proc
))
3158 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3159 scm_eval_args (x
, env
, proc
)));
3163 proc
= SCM_PROCEDURE (proc
);
3164 if (!SCM_CLOSUREP (proc
))
3167 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3168 if (SCM_NULLP (formals
)
3169 || (SCM_CONSP (formals
)
3170 && (SCM_NULLP (SCM_CDR (formals
))
3171 || (SCM_CONSP (SCM_CDR (formals
))
3172 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3173 goto umwrongnumargs
;
3175 case scm_tcs_closures
:
3177 SCM_SET_ARGSREADY (debug
);
3179 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3182 scm_eval_args (x
, env
, proc
)),
3184 x
= SCM_CODE (proc
);
3185 goto nontoplevel_cdrxbegin
;
3187 case scm_tcs_cons_gloc
: /* really structs, not glocs */
3188 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3191 arg2
= debug
.info
->a
.args
;
3193 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3195 x
= SCM_ENTITY_PROCEDURE (proc
);
3198 else if (!SCM_I_OPERATORP (proc
))
3202 case scm_tc7_subr_2
:
3203 case scm_tc7_subr_1o
:
3204 case scm_tc7_subr_2o
:
3205 case scm_tc7_subr_0
:
3207 case scm_tc7_subr_1
:
3215 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3216 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3218 SCM_CLEAR_TRACED_FRAME (debug
);
3219 if (SCM_CHEAPTRAPS_P
)
3220 t
.arg1
= scm_make_debugobj (&debug
);
3224 SCM val
= scm_make_continuation (&first
);
3234 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3237 scm_last_debug_frame
= debug
.prev
;
3243 /* SECTION: This code is compiled once.
3248 /* This code processes the arguments to apply:
3250 (apply PROC ARG1 ... ARGS)
3252 Given a list (ARG1 ... ARGS), this function conses the ARG1
3253 ... arguments onto the front of ARGS, and returns the resulting
3254 list. Note that ARGS is a list; thus, the argument to this
3255 function is a list whose last element is a list.
3257 Apply calls this function, and applies PROC to the elements of the
3258 result. apply:nconc2last takes care of building the list of
3259 arguments, given (ARG1 ... ARGS).
3261 Rather than do new consing, apply:nconc2last destroys its argument.
3262 On that topic, this code came into my care with the following
3263 beautifully cryptic comment on that topic: "This will only screw
3264 you if you do (scm_apply scm_apply '( ... ))" If you know what
3265 they're referring to, send me a patch to this comment. */
3267 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3269 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3270 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3271 "@var{args}, and returns the resulting list. Note that\n"
3272 "@var{args} is a list; thus, the argument to this function is\n"
3273 "a list whose last element is a list.\n"
3274 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3275 "destroys its argument, so use with care.")
3276 #define FUNC_NAME s_scm_nconc2last
3279 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3281 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3282 lloc
= SCM_CDRLOC (*lloc
);
3283 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3284 *lloc
= SCM_CAR (*lloc
);
3292 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3293 * It is compiled twice.
3299 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3306 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3311 /* Apply a function to a list of arguments.
3313 This function is exported to the Scheme level as taking two
3314 required arguments and a tail argument, as if it were:
3315 (lambda (proc arg1 . args) ...)
3316 Thus, if you just have a list of arguments to pass to a procedure,
3317 pass the list as ARG1, and '() for ARGS. If you have some fixed
3318 args, pass the first as ARG1, then cons any remaining fixed args
3319 onto the front of your argument list, and pass that as ARGS. */
3322 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3324 #ifdef DEBUG_EXTENSIONS
3326 scm_t_debug_frame debug
;
3327 scm_t_debug_info debug_vect_body
;
3328 debug
.prev
= scm_last_debug_frame
;
3329 debug
.status
= SCM_APPLYFRAME
;
3330 debug
.vect
= &debug_vect_body
;
3331 debug
.vect
[0].a
.proc
= proc
;
3332 debug
.vect
[0].a
.args
= SCM_EOL
;
3333 scm_last_debug_frame
= &debug
;
3336 return scm_dapply (proc
, arg1
, args
);
3340 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3342 /* If ARGS is the empty list, then we're calling apply with only two
3343 arguments --- ARG1 is the list of arguments for PROC. Whatever
3344 the case, futz with things so that ARG1 is the first argument to
3345 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3348 Setting the debug apply frame args this way is pretty messy.
3349 Perhaps we should store arg1 and args directly in the frame as
3350 received, and let scm_frame_arguments unpack them, because that's
3351 a relatively rare operation. This works for now; if the Guile
3352 developer archives are still around, see Mikael's post of
3354 if (SCM_NULLP (args
))
3356 if (SCM_NULLP (arg1
))
3358 arg1
= SCM_UNDEFINED
;
3360 debug
.vect
[0].a
.args
= SCM_EOL
;
3366 debug
.vect
[0].a
.args
= arg1
;
3368 args
= SCM_CDR (arg1
);
3369 arg1
= SCM_CAR (arg1
);
3374 args
= scm_nconc2last (args
);
3376 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3380 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3383 if (SCM_CHEAPTRAPS_P
)
3384 tmp
= scm_make_debugobj (&debug
);
3389 tmp
= scm_make_continuation (&first
);
3393 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3399 switch (SCM_TYP7 (proc
))
3401 case scm_tc7_subr_2o
:
3402 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3403 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3404 case scm_tc7_subr_2
:
3405 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3407 args
= SCM_CAR (args
);
3408 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3409 case scm_tc7_subr_0
:
3410 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3411 RETURN (SCM_SUBRF (proc
) ())
3412 case scm_tc7_subr_1
:
3413 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3414 case scm_tc7_subr_1o
:
3415 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3416 RETURN (SCM_SUBRF (proc
) (arg1
))
3418 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3419 if (SCM_SUBRF (proc
))
3421 if (SCM_INUMP (arg1
))
3423 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3425 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3426 if (SCM_REALP (arg1
))
3428 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3431 if (SCM_BIGP (arg1
))
3432 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))))
3435 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3436 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3438 proc
= SCM_SNAME (proc
);
3440 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3441 while ('c' != *--chrs
)
3443 SCM_ASSERT (SCM_CONSP (arg1
),
3444 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3445 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3449 case scm_tc7_subr_3
:
3450 SCM_ASRTGO (SCM_NNULLP (args
)
3451 && SCM_NNULLP (SCM_CDR (args
))
3452 && SCM_NULLP (SCM_CDDR (args
)),
3454 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3457 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3459 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3461 case scm_tc7_lsubr_2
:
3462 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3463 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3465 if (SCM_NULLP (args
))
3466 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3467 while (SCM_NIMP (args
))
3469 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3470 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3471 args
= SCM_CDR (args
);
3474 case scm_tc7_rpsubr
:
3475 if (SCM_NULLP (args
))
3476 RETURN (SCM_BOOL_T
);
3477 while (SCM_NIMP (args
))
3479 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3480 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3481 RETURN (SCM_BOOL_F
);
3482 arg1
= SCM_CAR (args
);
3483 args
= SCM_CDR (args
);
3485 RETURN (SCM_BOOL_T
);
3486 case scm_tcs_closures
:
3488 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3490 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3492 #ifndef SCM_RECKLESS
3493 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3497 /* Copy argument list */
3502 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3503 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3505 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3509 SCM_SETCDR (tl
, arg1
);
3512 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3513 proc
= SCM_CDR (SCM_CODE (proc
));
3516 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3518 if (SCM_IMP (SCM_CAR (proc
)))
3520 if (SCM_ISYMP (SCM_CAR (proc
)))
3522 proc
= scm_m_expand_body (proc
, args
);
3526 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3529 SCM_CEVAL (SCM_CAR (proc
), args
);
3532 RETURN (EVALCAR (proc
, args
));
3534 if (!SCM_SMOB_APPLICABLE_P (proc
))
3536 if (SCM_UNBNDP (arg1
))
3537 RETURN (SCM_SMOB_APPLY_0 (proc
))
3538 else if (SCM_NULLP (args
))
3539 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3540 else if (SCM_NULLP (SCM_CDR (args
)))
3541 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3543 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3546 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3548 proc
= SCM_CCLO_SUBR (proc
);
3549 debug
.vect
[0].a
.proc
= proc
;
3550 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3552 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3554 proc
= SCM_CCLO_SUBR (proc
);
3558 proc
= SCM_PROCEDURE (proc
);
3560 debug
.vect
[0].a
.proc
= proc
;
3563 case scm_tcs_cons_gloc
: /* really structs, not glocs */
3564 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3567 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3569 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3571 RETURN (scm_apply_generic (proc
, args
));
3573 else if (!SCM_I_OPERATORP (proc
))
3578 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3580 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3583 proc
= (SCM_I_ENTITYP (proc
)
3584 ? SCM_ENTITY_PROCEDURE (proc
)
3585 : SCM_OPERATOR_PROCEDURE (proc
));
3587 debug
.vect
[0].a
.proc
= proc
;
3588 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3590 if (SCM_NIMP (proc
))
3596 scm_wrong_num_args (proc
);
3599 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3604 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3605 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3607 SCM_CLEAR_TRACED_FRAME (debug
);
3608 if (SCM_CHEAPTRAPS_P
)
3609 arg1
= scm_make_debugobj (&debug
);
3613 SCM val
= scm_make_continuation (&first
);
3623 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3626 scm_last_debug_frame
= debug
.prev
;
3632 /* SECTION: The rest of this file is only read once.
3637 /* Typechecking for multi-argument MAP and FOR-EACH.
3639 Verify that each element of the vector ARGV, except for the first,
3640 is a proper list whose length is LEN. Attribute errors to WHO,
3641 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3643 check_map_args (SCM argv
,
3650 SCM
*ve
= SCM_VELTS (argv
);
3653 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3655 long elt_len
= scm_ilength (ve
[i
]);
3660 scm_apply_generic (gf
, scm_cons (proc
, args
));
3662 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3666 scm_out_of_range (who
, ve
[i
]);
3669 scm_remember_upto_here_1 (argv
);
3673 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3675 /* Note: Currently, scm_map applies PROC to the argument list(s)
3676 sequentially, starting with the first element(s). This is used in
3677 evalext.c where the Scheme procedure `map-in-order', which guarantees
3678 sequential behaviour, is implemented using scm_map. If the
3679 behaviour changes, we need to update `map-in-order'.
3683 scm_map (SCM proc
, SCM arg1
, SCM args
)
3684 #define FUNC_NAME s_map
3689 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3691 len
= scm_ilength (arg1
);
3692 SCM_GASSERTn (len
>= 0,
3693 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3694 SCM_VALIDATE_REST_ARGUMENT (args
);
3695 if (SCM_NULLP (args
))
3697 while (SCM_NIMP (arg1
))
3699 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3701 pres
= SCM_CDRLOC (*pres
);
3702 arg1
= SCM_CDR (arg1
);
3706 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3707 ve
= SCM_VELTS (args
);
3708 #ifndef SCM_RECKLESS
3709 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3714 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3716 if (SCM_IMP (ve
[i
]))
3718 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3719 ve
[i
] = SCM_CDR (ve
[i
]);
3721 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3722 pres
= SCM_CDRLOC (*pres
);
3728 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3731 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3732 #define FUNC_NAME s_for_each
3734 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3736 len
= scm_ilength (arg1
);
3737 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3738 SCM_ARG2
, s_for_each
);
3739 SCM_VALIDATE_REST_ARGUMENT (args
);
3742 while SCM_NIMP (arg1
)
3744 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3745 arg1
= SCM_CDR (arg1
);
3747 return SCM_UNSPECIFIED
;
3749 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3750 ve
= SCM_VELTS (args
);
3751 #ifndef SCM_RECKLESS
3752 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3757 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3760 (ve
[i
]) return SCM_UNSPECIFIED
;
3761 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3762 ve
[i
] = SCM_CDR (ve
[i
]);
3764 scm_apply (proc
, arg1
, SCM_EOL
);
3771 scm_closure (SCM code
, SCM env
)
3776 SCM_SETCODE (z
, code
);
3777 SCM_SETENV (z
, env
);
3782 scm_t_bits scm_tc16_promise
;
3785 scm_makprom (SCM code
)
3787 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3793 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3795 int writingp
= SCM_WRITINGP (pstate
);
3796 scm_puts ("#<promise ", port
);
3797 SCM_SET_WRITINGP (pstate
, 1);
3798 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3799 SCM_SET_WRITINGP (pstate
, writingp
);
3800 scm_putc ('>', port
);
3805 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3807 "If the promise @var{x} has not been computed yet, compute and\n"
3808 "return @var{x}, otherwise just return the previously computed\n"
3810 #define FUNC_NAME s_scm_force
3812 SCM_VALIDATE_SMOB (1, x
, promise
);
3813 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3815 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3816 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3819 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3820 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3824 return SCM_CELL_OBJECT_1 (x
);
3829 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3831 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3832 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3833 #define FUNC_NAME s_scm_promise_p
3835 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3840 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3841 (SCM xorig
, SCM x
, SCM y
),
3842 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3843 "Any source properties associated with @var{xorig} are also associated\n"
3844 "with the new pair.")
3845 #define FUNC_NAME s_scm_cons_source
3849 SCM_SET_CELL_OBJECT_0 (z
, x
);
3850 SCM_SET_CELL_OBJECT_1 (z
, y
);
3851 /* Copy source properties possibly associated with xorig. */
3852 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3854 scm_whash_insert (scm_source_whash
, z
, p
);
3860 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3862 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3863 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3864 "contents of both pairs and vectors (since both cons cells and vector\n"
3865 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3866 "any other object.")
3867 #define FUNC_NAME s_scm_copy_tree
3872 if (SCM_VECTORP (obj
))
3874 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3875 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3877 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3880 if (SCM_NCONSP (obj
))
3882 ans
= tl
= scm_cons_source (obj
,
3883 scm_copy_tree (SCM_CAR (obj
)),
3885 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3887 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3891 SCM_SETCDR (tl
, obj
);
3897 /* We have three levels of EVAL here:
3899 - scm_i_eval (exp, env)
3901 evaluates EXP in environment ENV. ENV is a lexical environment
3902 structure as used by the actual tree code evaluator. When ENV is
3903 a top-level environment, then changes to the current module are
3904 tracked by updating ENV so that it continues to be in sync with
3907 - scm_primitive_eval (exp)
3909 evaluates EXP in the top-level environment as determined by the
3910 current module. This is done by constructing a suitable
3911 environment and calling scm_i_eval. Thus, changes to the
3912 top-level module are tracked normally.
3914 - scm_eval (exp, mod)
3916 evaluates EXP while MOD is the current module. This is done by
3917 setting the current module to MOD, invoking scm_primitive_eval on
3918 EXP, and then restoring the current module to the value it had
3919 previously. That is, while EXP is evaluated, changes to the
3920 current module are tracked, but these changes do not persist when
3923 For each level of evals, there are two variants, distinguished by a
3924 _x suffix: the ordinary variant does not modify EXP while the _x
3925 variant can destructively modify EXP into something completely
3926 unintelligible. A Scheme data structure passed as EXP to one of the
3927 _x variants should not ever be used again for anything. So when in
3928 doubt, use the ordinary variant.
3933 scm_i_eval_x (SCM exp
, SCM env
)
3935 return SCM_XEVAL (exp
, env
);
3939 scm_i_eval (SCM exp
, SCM env
)
3941 exp
= scm_copy_tree (exp
);
3942 return SCM_XEVAL (exp
, env
);
3946 scm_primitive_eval_x (SCM exp
)
3949 SCM transformer
= scm_current_module_transformer ();
3950 if (SCM_NIMP (transformer
))
3951 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3952 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3953 return scm_i_eval_x (exp
, env
);
3956 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3958 "Evaluate @var{exp} in the top-level environment specified by\n"
3959 "the current module.")
3960 #define FUNC_NAME s_scm_primitive_eval
3963 SCM transformer
= scm_current_module_transformer ();
3964 if (SCM_NIMP (transformer
))
3965 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3966 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3967 return scm_i_eval (exp
, env
);
3971 /* Eval does not take the second arg optionally. This is intentional
3972 * in order to be R5RS compatible, and to prepare for the new module
3973 * system, where we would like to make the choice of evaluation
3974 * environment explicit. */
3977 change_environment (void *data
)
3979 SCM pair
= SCM_PACK (data
);
3980 SCM new_module
= SCM_CAR (pair
);
3981 SCM old_module
= scm_current_module ();
3982 SCM_SETCDR (pair
, old_module
);
3983 scm_set_current_module (new_module
);
3988 restore_environment (void *data
)
3990 SCM pair
= SCM_PACK (data
);
3991 SCM old_module
= SCM_CDR (pair
);
3992 SCM new_module
= scm_current_module ();
3993 SCM_SETCAR (pair
, new_module
);
3994 scm_set_current_module (old_module
);
3998 inner_eval_x (void *data
)
4000 return scm_primitive_eval_x (SCM_PACK(data
));
4004 scm_eval_x (SCM exp
, SCM module
)
4005 #define FUNC_NAME "eval!"
4007 SCM_VALIDATE_MODULE (2, module
);
4009 return scm_internal_dynamic_wind
4010 (change_environment
, inner_eval_x
, restore_environment
,
4011 (void *) SCM_UNPACK (exp
),
4012 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4017 inner_eval (void *data
)
4019 return scm_primitive_eval (SCM_PACK(data
));
4022 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4023 (SCM exp
, SCM module
),
4024 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4025 "in the top-level environment specified by @var{module}.\n"
4026 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
4027 "@var{module} is made the current module. The current module\n"
4028 "is reset to its previous value when @var{eval} returns.")
4029 #define FUNC_NAME s_scm_eval
4031 SCM_VALIDATE_MODULE (2, module
);
4033 return scm_internal_dynamic_wind
4034 (change_environment
, inner_eval
, restore_environment
,
4035 (void *) SCM_UNPACK (exp
),
4036 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4040 #if (SCM_DEBUG_DEPRECATED == 0)
4042 /* Use scm_current_module () or scm_interaction_environment ()
4043 * instead. The former is the module selected during loading of code.
4044 * The latter is the module in which the user of this thread currently
4045 * types expressions.
4048 SCM scm_top_level_lookup_closure_var
;
4049 SCM scm_system_transformer
;
4051 /* Avoid using this functionality altogether (except for implementing
4052 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4054 * Applications should use either C level scm_eval_x or Scheme
4055 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4058 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4061 return scm_i_eval (obj
, env
);
4063 return scm_i_eval_x (obj
, env
);
4066 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4067 (SCM obj
, SCM env_thunk
),
4068 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4069 "designated by @var{lookup}, a symbol-lookup function."
4070 "Do not use this version of eval, it does not play well\n"
4071 "with the module system. Use @code{eval} or\n"
4072 "@code{primitive-eval} instead.")
4073 #define FUNC_NAME s_scm_eval2
4075 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4079 #endif /* DEPRECATED */
4082 /* At this point, scm_deval and scm_dapply are generated.
4085 #ifdef DEBUG_EXTENSIONS
4095 scm_init_opts (scm_evaluator_traps
,
4096 scm_evaluator_trap_table
,
4097 SCM_N_EVALUATOR_TRAPS
);
4098 scm_init_opts (scm_eval_options_interface
,
4100 SCM_N_EVAL_OPTIONS
);
4102 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4103 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4104 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4106 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4107 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
4108 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4109 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
4111 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4116 #if SCM_DEBUG_DEPRECATED == 0
4117 scm_top_level_lookup_closure_var
=
4118 scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ());
4119 scm_system_transformer
=
4120 scm_c_define ("scm:eval-transformer", scm_make_fluid ());
4123 #ifndef SCM_MAGIC_SNARFER
4124 #include "libguile/eval.x"
4127 scm_c_define ("nil", scm_lisp_nil
);
4128 scm_c_define ("t", scm_lisp_t
);
4130 scm_add_feature ("delay");