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_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
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); \
1624 if (SCM_CHEAPTRAPS_P)\
1626 tmp = scm_make_debugobj (&debug);\
1627 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1632 tmp = scm_make_continuation (&first);\
1634 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1640 #define RETURN(e) {proc = (e); goto exit;}
1641 #ifdef STACK_CHECKING
1642 #ifndef EVAL_STACK_CHECKING
1643 #define EVAL_STACK_CHECKING
1647 /* scm_ceval_ptr points to the currently selected evaluator.
1648 * *fixme*: Although efficiency is important here, this state variable
1649 * should probably not be a global. It should be related to the
1654 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1656 /* scm_last_debug_frame contains a pointer to the last debugging
1657 * information stack frame. It is accessed very often from the
1658 * debugging evaluator, so it should probably not be indirectly
1659 * addressed. Better to save and restore it from the current root at
1664 scm_t_debug_frame
*scm_last_debug_frame
;
1667 /* scm_debug_eframe_size is the number of slots available for pseudo
1668 * stack frames at each real stack frame.
1671 long scm_debug_eframe_size
;
1673 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1675 long scm_eval_stack
;
1677 scm_t_option scm_eval_opts
[] = {
1678 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1681 scm_t_option scm_debug_opts
[] = {
1682 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1683 "*Flyweight representation of the stack at traps." },
1684 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1685 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1686 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1687 "Record procedure names at definition." },
1688 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1689 "Display backtrace in anti-chronological order." },
1690 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1691 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1692 { SCM_OPTION_INTEGER
, "frames", 3,
1693 "Maximum number of tail-recursive frames in backtrace." },
1694 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1695 "Maximal number of stored backtrace frames." },
1696 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1697 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1698 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1699 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1700 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
1703 scm_t_option scm_evaluator_trap_table
[] = {
1704 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1705 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1706 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1707 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1708 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1709 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1710 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1713 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1715 "Option interface for the evaluation options. Instead of using\n"
1716 "this procedure directly, use the procedures @code{eval-enable},\n"
1717 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1718 #define FUNC_NAME s_scm_eval_options_interface
1722 ans
= scm_options (setting
,
1726 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1732 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1734 "Option interface for the evaluator trap options.")
1735 #define FUNC_NAME s_scm_evaluator_traps
1739 ans
= scm_options (setting
,
1740 scm_evaluator_trap_table
,
1741 SCM_N_EVALUATOR_TRAPS
,
1743 SCM_RESET_DEBUG_MODE
;
1750 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1752 SCM
*results
= lloc
, res
;
1753 while (!SCM_IMP (l
))
1758 if (SCM_IMP (SCM_CAR (l
)))
1759 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1761 res
= EVALCELLCAR (l
, env
);
1763 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1766 SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1768 res
= SCM_CAR (l
); /* struct planted in code */
1770 res
= SCM_GLOC_VAL (SCM_CAR (l
));
1775 res
= EVALCAR (l
, env
);
1777 *lloc
= scm_cons (res
, SCM_EOL
);
1778 lloc
= SCM_CDRLOC (*lloc
);
1785 scm_wrong_num_args (proc
);
1794 /* SECTION: Some local definitions for the evaluator.
1797 /* Update the toplevel environment frame ENV so that it refers to the
1800 #define UPDATE_TOPLEVEL_ENV(env) \
1802 SCM p = scm_current_module_lookup_closure (); \
1803 if (p != SCM_CAR(env)) \
1804 env = scm_top_level_env (p); \
1808 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1811 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1813 /* SECTION: This is the evaluator. Like any real monster, it has
1814 * three heads. This code is compiled twice.
1820 scm_ceval (SCM x
, SCM env
)
1826 scm_deval (SCM x
, SCM env
)
1831 SCM_CEVAL (SCM x
, SCM env
)
1838 SCM proc
, arg2
, orig_sym
;
1840 scm_t_debug_frame debug
;
1841 scm_t_debug_info
*debug_info_end
;
1842 debug
.prev
= scm_last_debug_frame
;
1843 debug
.status
= scm_debug_eframe_size
;
1845 * The debug.vect contains twice as much scm_t_debug_info frames as the
1846 * user has specified with (debug-set! frames <n>).
1848 * Even frames are eval frames, odd frames are apply frames.
1850 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1851 * sizeof (debug
.vect
[0]));
1852 debug
.info
= debug
.vect
;
1853 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1854 scm_last_debug_frame
= &debug
;
1856 #ifdef EVAL_STACK_CHECKING
1857 if (scm_stack_checking_enabled_p
1858 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1861 debug
.info
->e
.exp
= x
;
1862 debug
.info
->e
.env
= env
;
1864 scm_report_stack_overflow ();
1871 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1874 SCM_CLEAR_ARGSREADY (debug
);
1875 if (SCM_OVERFLOWP (debug
))
1878 * In theory, this should be the only place where it is necessary to
1879 * check for space in debug.vect since both eval frames and
1880 * available space are even.
1882 * For this to be the case, however, it is necessary that primitive
1883 * special forms which jump back to `loop', `begin' or some similar
1884 * label call PREP_APPLY. A convenient way to do this is to jump to
1885 * `loopnoap' or `cdrxnoap'.
1887 else if (++debug
.info
>= debug_info_end
)
1889 SCM_SET_OVERFLOW (debug
);
1893 debug
.info
->e
.exp
= x
;
1894 debug
.info
->e
.env
= env
;
1895 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1896 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1898 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1899 SCM_SET_TAILREC (debug
);
1900 if (SCM_CHEAPTRAPS_P
)
1901 t
.arg1
= scm_make_debugobj (&debug
);
1905 SCM val
= scm_make_continuation (&first
);
1917 /* This gives the possibility for the debugger to
1918 modify the source expression before evaluation. */
1923 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1924 scm_sym_enter_frame
,
1927 scm_unmemocopy (x
, env
));
1931 #if defined (USE_THREADS) || defined (DEVAL)
1935 switch (SCM_TYP7 (x
))
1937 case scm_tc7_symbol
:
1938 /* Only happens when called at top level.
1940 x
= scm_cons (x
, SCM_UNDEFINED
);
1943 case SCM_BIT8(SCM_IM_AND
):
1946 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1947 if (SCM_FALSEP (EVALCAR (x
, env
)))
1949 RETURN (SCM_BOOL_F
);
1953 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1956 case SCM_BIT8(SCM_IM_BEGIN
):
1957 /* (currently unused)
1959 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1960 /* (currently unused)
1965 /* If we are on toplevel with a lookup closure, we need to sync
1966 with the current module. */
1967 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1970 UPDATE_TOPLEVEL_ENV (env
);
1971 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1975 UPDATE_TOPLEVEL_ENV (env
);
1980 goto nontoplevel_begin
;
1982 nontoplevel_cdrxnoap
:
1983 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1984 nontoplevel_cdrxbegin
:
1988 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1990 if (SCM_IMP (SCM_CAR (x
)))
1992 if (SCM_ISYMP (SCM_CAR (x
)))
1994 x
= scm_m_expand_body (x
, env
);
1995 goto nontoplevel_begin
;
1998 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (x
));
2001 SCM_CEVAL (SCM_CAR (x
), env
);
2005 carloop
: /* scm_eval car of last form in list */
2006 if (!SCM_CELLP (SCM_CAR (x
)))
2009 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
2012 if (SCM_SYMBOLP (SCM_CAR (x
)))
2015 RETURN (*scm_lookupcar (x
, env
, 1))
2019 goto loop
; /* tail recurse */
2022 case SCM_BIT8(SCM_IM_CASE
):
2024 t
.arg1
= EVALCAR (x
, env
);
2025 while (SCM_NIMP (x
= SCM_CDR (x
)))
2028 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2031 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2034 proc
= SCM_CAR (proc
);
2035 while (SCM_NIMP (proc
))
2037 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2039 x
= SCM_CDR (SCM_CAR (x
));
2040 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2043 proc
= SCM_CDR (proc
);
2046 RETURN (SCM_UNSPECIFIED
)
2049 case SCM_BIT8(SCM_IM_COND
):
2050 while (!SCM_IMP (x
= SCM_CDR (x
)))
2053 t
.arg1
= EVALCAR (proc
, env
);
2054 if (SCM_NFALSEP (t
.arg1
))
2061 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2063 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2067 proc
= EVALCAR (proc
, env
);
2068 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2069 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2071 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2072 goto umwrongnumargs
;
2076 RETURN (SCM_UNSPECIFIED
)
2079 case SCM_BIT8(SCM_IM_DO
):
2081 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2082 t
.arg1
= SCM_EOL
; /* values */
2083 while (SCM_NIMP (proc
))
2085 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2086 proc
= SCM_CDR (proc
);
2088 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2089 x
= SCM_CDR (SCM_CDR (x
));
2090 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2092 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2094 t
.arg1
= SCM_CAR (proc
); /* body */
2095 SIDEVAL (t
.arg1
, env
);
2097 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2099 proc
= SCM_CDR (proc
))
2100 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2101 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2105 RETURN (SCM_UNSPECIFIED
);
2106 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2107 goto nontoplevel_begin
;
2110 case SCM_BIT8(SCM_IM_IF
):
2112 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2114 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2116 RETURN (SCM_UNSPECIFIED
);
2118 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2122 case SCM_BIT8(SCM_IM_LET
):
2124 proc
= SCM_CAR (SCM_CDR (x
));
2128 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2130 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2131 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2133 goto nontoplevel_cdrxnoap
;
2136 case SCM_BIT8(SCM_IM_LETREC
):
2138 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2144 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2146 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2147 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2148 goto nontoplevel_cdrxnoap
;
2151 case SCM_BIT8(SCM_IM_LETSTAR
):
2156 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2157 goto nontoplevel_cdrxnoap
;
2161 t
.arg1
= SCM_CAR (proc
);
2162 proc
= SCM_CDR (proc
);
2163 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2165 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2166 goto nontoplevel_cdrxnoap
;
2168 case SCM_BIT8(SCM_IM_OR
):
2171 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2173 x
= EVALCAR (x
, env
);
2174 if (!SCM_FALSEP (x
))
2180 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2184 case SCM_BIT8(SCM_IM_LAMBDA
):
2185 RETURN (scm_closure (SCM_CDR (x
), env
));
2188 case SCM_BIT8(SCM_IM_QUOTE
):
2189 RETURN (SCM_CAR (SCM_CDR (x
)));
2192 case SCM_BIT8(SCM_IM_SET_X
):
2195 switch (SCM_ITAG3 (proc
))
2198 t
.lloc
= scm_lookupcar (x
, env
, 1);
2200 case scm_tc3_cons_gloc
:
2201 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2203 #ifdef MEMOIZE_LOCALS
2205 t
.lloc
= scm_ilookup (proc
, env
);
2210 *t
.lloc
= EVALCAR (x
, env
);
2214 RETURN (SCM_UNSPECIFIED
);
2218 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2219 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2221 /* new syntactic forms go here. */
2222 case SCM_BIT8(SCM_MAKISYM (0)):
2224 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2225 switch SCM_ISYMNUM (proc
)
2227 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2229 proc
= EVALCAR (proc
, env
);
2230 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2231 if (SCM_CLOSUREP (proc
))
2234 PREP_APPLY (proc
, SCM_EOL
);
2235 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2236 t
.arg1
= EVALCAR (t
.arg1
, env
);
2238 /* Go here to tail-call a closure. PROC is the closure
2239 and T.ARG1 is the list of arguments. Do not forget to
2242 debug
.info
->a
.args
= t
.arg1
;
2244 #ifndef SCM_RECKLESS
2245 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2249 /* Copy argument list */
2250 if (SCM_IMP (t
.arg1
))
2254 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2255 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2256 && SCM_CONSP (t
.arg1
))
2258 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2262 SCM_SETCDR (tl
, t
.arg1
);
2265 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2266 x
= SCM_CODE (proc
);
2267 goto nontoplevel_cdrxbegin
;
2272 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2275 SCM val
= scm_make_continuation (&first
);
2283 proc
= evalcar (proc
, env
);
2284 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2285 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2287 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2288 goto umwrongnumargs
;
2291 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2292 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2294 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2295 proc
= SCM_CADR (x
); /* unevaluated operands */
2296 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2298 arg2
= *scm_ilookup (proc
, env
);
2299 else if (SCM_NCONSP (proc
))
2301 if (SCM_NCELLP (proc
))
2302 arg2
= SCM_GLOC_VAL (proc
);
2304 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2308 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2309 t
.lloc
= SCM_CDRLOC (arg2
);
2310 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2312 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2313 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2318 /* The type dispatch code is duplicated here
2319 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2320 * cuts down execution time for type dispatch to 50%.
2323 long i
, n
, end
, mask
;
2324 SCM z
= SCM_CDDR (x
);
2325 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2326 proc
= SCM_CADR (z
);
2328 if (SCM_NIMP (proc
))
2330 /* Prepare for linear search */
2333 end
= SCM_VECTOR_LENGTH (proc
);
2337 /* Compute a hash value */
2338 long hashset
= SCM_INUM (proc
);
2341 mask
= SCM_INUM (SCM_CAR (z
));
2342 proc
= SCM_CADR (z
);
2345 if (SCM_NIMP (t
.arg1
))
2348 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2349 [scm_si_hashsets
+ hashset
];
2350 t
.arg1
= SCM_CDR (t
.arg1
);
2352 while (j
-- && SCM_NIMP (t
.arg1
));
2357 /* Search for match */
2361 z
= SCM_VELTS (proc
)[i
];
2362 t
.arg1
= arg2
; /* list of arguments */
2363 if (SCM_NIMP (t
.arg1
))
2366 /* More arguments than specifiers => CLASS != ENV */
2367 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2369 t
.arg1
= SCM_CDR (t
.arg1
);
2372 while (j
-- && SCM_NIMP (t
.arg1
));
2373 /* Fewer arguments than specifiers => CAR != ENV */
2374 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2377 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2379 SCM_CMETHOD_ENV (z
));
2380 x
= SCM_CMETHOD_CODE (z
);
2381 goto nontoplevel_cdrxbegin
;
2386 z
= scm_memoize_method (x
, arg2
);
2390 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2392 t
.arg1
= EVALCAR (x
, env
);
2393 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2395 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2397 t
.arg1
= EVALCAR (x
, env
);
2400 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2401 = SCM_UNPACK (EVALCAR (proc
, env
));
2402 RETURN (SCM_UNSPECIFIED
)
2404 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2406 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2408 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2409 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2411 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2413 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2419 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2422 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2424 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2428 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2430 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2432 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2434 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2436 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2437 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2439 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2441 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2447 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2450 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2452 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2456 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2458 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2462 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2465 t
.arg1
= SCM_CAR (x
);
2466 arg2
= SCM_CDAR (env
);
2467 while (SCM_NIMP (arg2
))
2469 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2470 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2472 SCM_SETCAR (arg2
, proc
);
2473 t
.arg1
= SCM_CDR (t
.arg1
);
2474 arg2
= SCM_CDR (arg2
);
2476 t
.arg1
= SCM_CAR (x
);
2477 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2479 arg2
= x
= SCM_CDR (x
);
2480 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2482 SIDEVAL (SCM_CAR (x
), env
);
2485 proc
= EVALCAR (x
, env
);
2487 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2488 arg2
= SCM_CDAR (env
);
2489 while (SCM_NIMP (arg2
))
2491 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2493 t
.arg1
= SCM_CDR (t
.arg1
);
2494 arg2
= SCM_CDR (arg2
);
2499 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2502 x
= EVALCAR (proc
, env
);
2503 proc
= SCM_CDR (proc
);
2504 proc
= EVALCAR (proc
, env
);
2505 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2506 if (SCM_VALUESP (t
.arg1
))
2507 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2509 t
.arg1
= scm_cons (t
.arg1
, SCM_EOL
);
2510 if (SCM_CLOSUREP (proc
))
2512 PREP_APPLY (proc
, t
.arg1
);
2515 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2525 /* scm_everr (x, env,...) */
2526 scm_misc_error (NULL
, "Wrong type to apply: ~S", SCM_LIST1 (proc
));
2527 case scm_tc7_vector
:
2531 case scm_tc7_byvect
:
2538 #ifdef HAVE_LONG_LONGS
2539 case scm_tc7_llvect
:
2542 case scm_tc7_string
:
2543 case scm_tc7_substring
:
2545 case scm_tcs_closures
:
2551 #ifdef MEMOIZE_LOCALS
2552 case SCM_BIT8(SCM_ILOC00
):
2553 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2554 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2555 #ifndef SCM_RECKLESS
2561 #endif /* ifdef MEMOIZE_LOCALS */
2564 case scm_tcs_cons_gloc
: {
2565 scm_t_bits vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2567 /* This is a struct implanted in the code, not a gloc. */
2570 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2571 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2572 #ifndef SCM_RECKLESS
2581 case scm_tcs_cons_nimcar
:
2582 orig_sym
= SCM_CAR (x
);
2583 if (SCM_SYMBOLP (orig_sym
))
2586 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2589 /* we have lost the race, start again. */
2594 proc
= *scm_lookupcar (x
, env
, 1);
2599 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2603 if (SCM_MACROP (proc
))
2605 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2609 /* Set a flag during macro expansion so that macro
2610 application frames can be deleted from the backtrace. */
2611 SCM_SET_MACROEXP (debug
);
2613 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2614 scm_cons (env
, scm_listofnull
));
2617 SCM_CLEAR_MACROEXP (debug
);
2619 switch (SCM_MACRO_TYPE (proc
))
2622 if (scm_ilength (t
.arg1
) <= 0)
2623 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2625 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2628 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2629 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2633 /* Prevent memoizing of debug info expression. */
2634 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2639 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2640 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2644 if (SCM_NIMP (x
= t
.arg1
))
2652 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2653 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2654 #ifndef SCM_RECKLESS
2658 if (SCM_CLOSUREP (proc
))
2660 arg2
= SCM_CLOSURE_FORMALS (proc
);
2661 t
.arg1
= SCM_CDR (x
);
2662 while (!SCM_NULLP (arg2
))
2664 if (!SCM_CONSP (arg2
))
2666 if (SCM_IMP (t
.arg1
))
2667 goto umwrongnumargs
;
2668 arg2
= SCM_CDR (arg2
);
2669 t
.arg1
= SCM_CDR (t
.arg1
);
2671 if (!SCM_NULLP (t
.arg1
))
2672 goto umwrongnumargs
;
2674 else if (SCM_MACROP (proc
))
2675 goto handle_a_macro
;
2681 PREP_APPLY (proc
, SCM_EOL
);
2682 if (SCM_NULLP (SCM_CDR (x
))) {
2685 switch (SCM_TYP7 (proc
))
2686 { /* no arguments given */
2687 case scm_tc7_subr_0
:
2688 RETURN (SCM_SUBRF (proc
) ());
2689 case scm_tc7_subr_1o
:
2690 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2692 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2693 case scm_tc7_rpsubr
:
2694 RETURN (SCM_BOOL_T
);
2696 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2698 if (!SCM_SMOB_APPLICABLE_P (proc
))
2700 RETURN (SCM_SMOB_APPLY_0 (proc
));
2703 proc
= SCM_CCLO_SUBR (proc
);
2705 debug
.info
->a
.proc
= proc
;
2706 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2710 proc
= SCM_PROCEDURE (proc
);
2712 debug
.info
->a
.proc
= proc
;
2714 if (!SCM_CLOSUREP (proc
))
2716 if (scm_badformalsp (proc
, 0))
2717 goto umwrongnumargs
;
2718 case scm_tcs_closures
:
2719 x
= SCM_CODE (proc
);
2720 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2721 goto nontoplevel_cdrxbegin
;
2722 case scm_tcs_cons_gloc
: /* really structs, not glocs */
2723 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2725 x
= SCM_ENTITY_PROCEDURE (proc
);
2729 else if (!SCM_I_OPERATORP (proc
))
2734 proc
= (SCM_I_ENTITYP (proc
)
2735 ? SCM_ENTITY_PROCEDURE (proc
)
2736 : SCM_OPERATOR_PROCEDURE (proc
));
2738 debug
.info
->a
.proc
= proc
;
2739 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2741 if (SCM_NIMP (proc
))
2746 case scm_tc7_subr_1
:
2747 case scm_tc7_subr_2
:
2748 case scm_tc7_subr_2o
:
2750 case scm_tc7_subr_3
:
2751 case scm_tc7_lsubr_2
:
2755 /* scm_everr (x, env,...) */
2756 scm_wrong_num_args (proc
);
2758 /* handle macros here */
2763 /* must handle macros by here */
2768 else if (SCM_CONSP (x
))
2770 if (SCM_IMP (SCM_CAR (x
)))
2771 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2773 t
.arg1
= EVALCELLCAR (x
, env
);
2775 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2777 scm_t_bits vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2779 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2781 t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
));
2786 t
.arg1
= EVALCAR (x
, env
);
2789 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2796 switch (SCM_TYP7 (proc
))
2797 { /* have one argument in t.arg1 */
2798 case scm_tc7_subr_2o
:
2799 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2800 case scm_tc7_subr_1
:
2801 case scm_tc7_subr_1o
:
2802 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2804 if (SCM_SUBRF (proc
))
2806 if (SCM_INUMP (t
.arg1
))
2808 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2810 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2811 if (SCM_REALP (t
.arg1
))
2813 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2816 if (SCM_BIGP (t
.arg1
))
2818 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2822 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2823 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2825 proc
= SCM_SNAME (proc
);
2827 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2828 while ('c' != *--chrs
)
2830 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2831 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2832 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2836 case scm_tc7_rpsubr
:
2837 RETURN (SCM_BOOL_T
);
2839 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2842 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2844 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2847 if (!SCM_SMOB_APPLICABLE_P (proc
))
2849 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2853 proc
= SCM_CCLO_SUBR (proc
);
2855 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2856 debug
.info
->a
.proc
= proc
;
2860 proc
= SCM_PROCEDURE (proc
);
2862 debug
.info
->a
.proc
= proc
;
2864 if (!SCM_CLOSUREP (proc
))
2866 if (scm_badformalsp (proc
, 1))
2867 goto umwrongnumargs
;
2868 case scm_tcs_closures
:
2870 x
= SCM_CODE (proc
);
2872 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2874 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2876 goto nontoplevel_cdrxbegin
;
2877 case scm_tcs_cons_gloc
: /* really structs, not glocs */
2878 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2880 x
= SCM_ENTITY_PROCEDURE (proc
);
2882 arg2
= debug
.info
->a
.args
;
2884 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2888 else if (!SCM_I_OPERATORP (proc
))
2894 proc
= (SCM_I_ENTITYP (proc
)
2895 ? SCM_ENTITY_PROCEDURE (proc
)
2896 : SCM_OPERATOR_PROCEDURE (proc
));
2898 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2899 debug
.info
->a
.proc
= proc
;
2901 if (SCM_NIMP (proc
))
2906 case scm_tc7_subr_2
:
2907 case scm_tc7_subr_0
:
2908 case scm_tc7_subr_3
:
2909 case scm_tc7_lsubr_2
:
2918 else if (SCM_CONSP (x
))
2920 if (SCM_IMP (SCM_CAR (x
)))
2921 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2923 arg2
= EVALCELLCAR (x
, env
);
2925 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2927 scm_t_bits vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2929 arg2
= SCM_CAR (x
); /* struct planted in code */
2931 arg2
= SCM_GLOC_VAL (SCM_CAR (x
));
2936 arg2
= EVALCAR (x
, env
);
2938 { /* have two or more arguments */
2940 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2943 if (SCM_NULLP (x
)) {
2946 switch (SCM_TYP7 (proc
))
2947 { /* have two arguments */
2948 case scm_tc7_subr_2
:
2949 case scm_tc7_subr_2o
:
2950 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2953 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2955 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2957 case scm_tc7_lsubr_2
:
2958 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2959 case scm_tc7_rpsubr
:
2961 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2963 if (!SCM_SMOB_APPLICABLE_P (proc
))
2965 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2969 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2970 scm_cons (proc
, debug
.info
->a
.args
),
2973 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2974 scm_cons2 (proc
, t
.arg1
,
2981 case scm_tcs_cons_gloc
: /* really structs, not glocs */
2982 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2984 x
= SCM_ENTITY_PROCEDURE (proc
);
2986 arg2
= debug
.info
->a
.args
;
2988 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2992 else if (!SCM_I_OPERATORP (proc
))
2998 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2999 ? SCM_ENTITY_PROCEDURE (proc
)
3000 : SCM_OPERATOR_PROCEDURE (proc
),
3001 scm_cons (proc
, debug
.info
->a
.args
),
3004 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3005 ? SCM_ENTITY_PROCEDURE (proc
)
3006 : SCM_OPERATOR_PROCEDURE (proc
),
3007 scm_cons2 (proc
, t
.arg1
,
3015 case scm_tc7_subr_0
:
3017 case scm_tc7_subr_1o
:
3018 case scm_tc7_subr_1
:
3019 case scm_tc7_subr_3
:
3024 proc
= SCM_PROCEDURE (proc
);
3026 debug
.info
->a
.proc
= proc
;
3028 if (!SCM_CLOSUREP (proc
))
3030 if (scm_badformalsp (proc
, 2))
3031 goto umwrongnumargs
;
3032 case scm_tcs_closures
:
3035 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3039 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3040 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
3042 x
= SCM_CODE (proc
);
3043 goto nontoplevel_cdrxbegin
;
3047 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3051 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3052 scm_deval_args (x
, env
, proc
,
3053 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3057 switch (SCM_TYP7 (proc
))
3058 { /* have 3 or more arguments */
3060 case scm_tc7_subr_3
:
3061 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3062 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3063 SCM_CADDR (debug
.info
->a
.args
)));
3065 #ifdef BUILTIN_RPASUBR
3066 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3067 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3070 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3071 arg2
= SCM_CDR (arg2
);
3073 while (SCM_NIMP (arg2
));
3075 #endif /* BUILTIN_RPASUBR */
3076 case scm_tc7_rpsubr
:
3077 #ifdef BUILTIN_RPASUBR
3078 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3080 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3083 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3085 arg2
= SCM_CAR (t
.arg1
);
3086 t
.arg1
= SCM_CDR (t
.arg1
);
3088 while (SCM_NIMP (t
.arg1
));
3090 #else /* BUILTIN_RPASUBR */
3091 RETURN (SCM_APPLY (proc
, t
.arg1
,
3093 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3095 #endif /* BUILTIN_RPASUBR */
3096 case scm_tc7_lsubr_2
:
3097 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3098 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3100 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3102 if (!SCM_SMOB_APPLICABLE_P (proc
))
3104 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3105 SCM_CDDR (debug
.info
->a
.args
)));
3109 proc
= SCM_PROCEDURE (proc
);
3110 debug
.info
->a
.proc
= proc
;
3111 if (!SCM_CLOSUREP (proc
))
3113 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3114 goto umwrongnumargs
;
3115 case scm_tcs_closures
:
3116 SCM_SET_ARGSREADY (debug
);
3117 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3120 x
= SCM_CODE (proc
);
3121 goto nontoplevel_cdrxbegin
;
3123 case scm_tc7_subr_3
:
3124 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3125 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3127 #ifdef BUILTIN_RPASUBR
3128 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3131 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3134 while (SCM_NIMP (x
));
3136 #endif /* BUILTIN_RPASUBR */
3137 case scm_tc7_rpsubr
:
3138 #ifdef BUILTIN_RPASUBR
3139 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3143 t
.arg1
= EVALCAR (x
, env
);
3144 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3149 while (SCM_NIMP (x
));
3151 #else /* BUILTIN_RPASUBR */
3152 RETURN (SCM_APPLY (proc
, t
.arg1
,
3154 scm_eval_args (x
, env
, proc
),
3156 #endif /* BUILTIN_RPASUBR */
3157 case scm_tc7_lsubr_2
:
3158 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3160 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3162 scm_eval_args (x
, env
, proc
))));
3164 if (!SCM_SMOB_APPLICABLE_P (proc
))
3166 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3167 scm_eval_args (x
, env
, proc
)));
3171 proc
= SCM_PROCEDURE (proc
);
3172 if (!SCM_CLOSUREP (proc
))
3175 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3176 if (SCM_NULLP (formals
)
3177 || (SCM_CONSP (formals
)
3178 && (SCM_NULLP (SCM_CDR (formals
))
3179 || (SCM_CONSP (SCM_CDR (formals
))
3180 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3181 goto umwrongnumargs
;
3183 case scm_tcs_closures
:
3185 SCM_SET_ARGSREADY (debug
);
3187 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3190 scm_eval_args (x
, env
, proc
)),
3192 x
= SCM_CODE (proc
);
3193 goto nontoplevel_cdrxbegin
;
3195 case scm_tcs_cons_gloc
: /* really structs, not glocs */
3196 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3199 arg2
= debug
.info
->a
.args
;
3201 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3203 x
= SCM_ENTITY_PROCEDURE (proc
);
3206 else if (!SCM_I_OPERATORP (proc
))
3210 case scm_tc7_subr_2
:
3211 case scm_tc7_subr_1o
:
3212 case scm_tc7_subr_2o
:
3213 case scm_tc7_subr_0
:
3215 case scm_tc7_subr_1
:
3223 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3224 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3226 SCM_CLEAR_TRACED_FRAME (debug
);
3227 if (SCM_CHEAPTRAPS_P
)
3228 t
.arg1
= scm_make_debugobj (&debug
);
3232 SCM val
= scm_make_continuation (&first
);
3243 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3247 scm_last_debug_frame
= debug
.prev
;
3253 /* SECTION: This code is compiled once.
3259 /* Simple procedure calls
3263 scm_call_0 (SCM proc
)
3265 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3269 scm_call_1 (SCM proc
, SCM arg1
)
3271 return scm_apply (proc
, arg1
, scm_listofnull
);
3275 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3277 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3281 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3283 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3287 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3289 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3290 scm_cons (arg4
, scm_listofnull
)));
3293 /* Simple procedure applies
3297 scm_apply_0 (SCM proc
, SCM args
)
3299 return scm_apply (proc
, args
, SCM_EOL
);
3303 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3305 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3309 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3311 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3315 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3317 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3321 /* This code processes the arguments to apply:
3323 (apply PROC ARG1 ... ARGS)
3325 Given a list (ARG1 ... ARGS), this function conses the ARG1
3326 ... arguments onto the front of ARGS, and returns the resulting
3327 list. Note that ARGS is a list; thus, the argument to this
3328 function is a list whose last element is a list.
3330 Apply calls this function, and applies PROC to the elements of the
3331 result. apply:nconc2last takes care of building the list of
3332 arguments, given (ARG1 ... ARGS).
3334 Rather than do new consing, apply:nconc2last destroys its argument.
3335 On that topic, this code came into my care with the following
3336 beautifully cryptic comment on that topic: "This will only screw
3337 you if you do (scm_apply scm_apply '( ... ))" If you know what
3338 they're referring to, send me a patch to this comment. */
3340 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3342 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3343 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3344 "@var{args}, and returns the resulting list. Note that\n"
3345 "@var{args} is a list; thus, the argument to this function is\n"
3346 "a list whose last element is a list.\n"
3347 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3348 "destroys its argument, so use with care.")
3349 #define FUNC_NAME s_scm_nconc2last
3352 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3354 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3355 lloc
= SCM_CDRLOC (*lloc
);
3356 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3357 *lloc
= SCM_CAR (*lloc
);
3365 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3366 * It is compiled twice.
3372 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3379 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3384 /* Apply a function to a list of arguments.
3386 This function is exported to the Scheme level as taking two
3387 required arguments and a tail argument, as if it were:
3388 (lambda (proc arg1 . args) ...)
3389 Thus, if you just have a list of arguments to pass to a procedure,
3390 pass the list as ARG1, and '() for ARGS. If you have some fixed
3391 args, pass the first as ARG1, then cons any remaining fixed args
3392 onto the front of your argument list, and pass that as ARGS. */
3395 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3397 #ifdef DEBUG_EXTENSIONS
3399 scm_t_debug_frame debug
;
3400 scm_t_debug_info debug_vect_body
;
3401 debug
.prev
= scm_last_debug_frame
;
3402 debug
.status
= SCM_APPLYFRAME
;
3403 debug
.vect
= &debug_vect_body
;
3404 debug
.vect
[0].a
.proc
= proc
;
3405 debug
.vect
[0].a
.args
= SCM_EOL
;
3406 scm_last_debug_frame
= &debug
;
3409 return scm_dapply (proc
, arg1
, args
);
3413 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3415 /* If ARGS is the empty list, then we're calling apply with only two
3416 arguments --- ARG1 is the list of arguments for PROC. Whatever
3417 the case, futz with things so that ARG1 is the first argument to
3418 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3421 Setting the debug apply frame args this way is pretty messy.
3422 Perhaps we should store arg1 and args directly in the frame as
3423 received, and let scm_frame_arguments unpack them, because that's
3424 a relatively rare operation. This works for now; if the Guile
3425 developer archives are still around, see Mikael's post of
3427 if (SCM_NULLP (args
))
3429 if (SCM_NULLP (arg1
))
3431 arg1
= SCM_UNDEFINED
;
3433 debug
.vect
[0].a
.args
= SCM_EOL
;
3439 debug
.vect
[0].a
.args
= arg1
;
3441 args
= SCM_CDR (arg1
);
3442 arg1
= SCM_CAR (arg1
);
3447 args
= scm_nconc2last (args
);
3449 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3453 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3456 if (SCM_CHEAPTRAPS_P
)
3457 tmp
= scm_make_debugobj (&debug
);
3462 tmp
= scm_make_continuation (&first
);
3467 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3474 switch (SCM_TYP7 (proc
))
3476 case scm_tc7_subr_2o
:
3477 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3478 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3479 case scm_tc7_subr_2
:
3480 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3482 args
= SCM_CAR (args
);
3483 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3484 case scm_tc7_subr_0
:
3485 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3486 RETURN (SCM_SUBRF (proc
) ())
3487 case scm_tc7_subr_1
:
3488 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3489 case scm_tc7_subr_1o
:
3490 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3491 RETURN (SCM_SUBRF (proc
) (arg1
))
3493 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3494 if (SCM_SUBRF (proc
))
3496 if (SCM_INUMP (arg1
))
3498 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3500 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3501 if (SCM_REALP (arg1
))
3503 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3506 if (SCM_BIGP (arg1
))
3507 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))))
3510 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3511 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3513 proc
= SCM_SNAME (proc
);
3515 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3516 while ('c' != *--chrs
)
3518 SCM_ASSERT (SCM_CONSP (arg1
),
3519 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3520 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3524 case scm_tc7_subr_3
:
3525 SCM_ASRTGO (SCM_NNULLP (args
)
3526 && SCM_NNULLP (SCM_CDR (args
))
3527 && SCM_NULLP (SCM_CDDR (args
)),
3529 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3532 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3534 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3536 case scm_tc7_lsubr_2
:
3537 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3538 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3540 if (SCM_NULLP (args
))
3541 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3542 while (SCM_NIMP (args
))
3544 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3545 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3546 args
= SCM_CDR (args
);
3549 case scm_tc7_rpsubr
:
3550 if (SCM_NULLP (args
))
3551 RETURN (SCM_BOOL_T
);
3552 while (SCM_NIMP (args
))
3554 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3555 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3556 RETURN (SCM_BOOL_F
);
3557 arg1
= SCM_CAR (args
);
3558 args
= SCM_CDR (args
);
3560 RETURN (SCM_BOOL_T
);
3561 case scm_tcs_closures
:
3563 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3565 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3567 #ifndef SCM_RECKLESS
3568 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3572 /* Copy argument list */
3577 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3578 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3580 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3584 SCM_SETCDR (tl
, arg1
);
3587 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3588 proc
= SCM_CDR (SCM_CODE (proc
));
3591 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3593 if (SCM_IMP (SCM_CAR (proc
)))
3595 if (SCM_ISYMP (SCM_CAR (proc
)))
3597 proc
= scm_m_expand_body (proc
, args
);
3601 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3604 SCM_CEVAL (SCM_CAR (proc
), args
);
3607 RETURN (EVALCAR (proc
, args
));
3609 if (!SCM_SMOB_APPLICABLE_P (proc
))
3611 if (SCM_UNBNDP (arg1
))
3612 RETURN (SCM_SMOB_APPLY_0 (proc
))
3613 else if (SCM_NULLP (args
))
3614 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3615 else if (SCM_NULLP (SCM_CDR (args
)))
3616 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3618 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3621 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3623 proc
= SCM_CCLO_SUBR (proc
);
3624 debug
.vect
[0].a
.proc
= proc
;
3625 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3627 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3629 proc
= SCM_CCLO_SUBR (proc
);
3633 proc
= SCM_PROCEDURE (proc
);
3635 debug
.vect
[0].a
.proc
= proc
;
3638 case scm_tcs_cons_gloc
: /* really structs, not glocs */
3639 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3642 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3644 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3646 RETURN (scm_apply_generic (proc
, args
));
3648 else if (!SCM_I_OPERATORP (proc
))
3653 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3655 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3658 proc
= (SCM_I_ENTITYP (proc
)
3659 ? SCM_ENTITY_PROCEDURE (proc
)
3660 : SCM_OPERATOR_PROCEDURE (proc
));
3662 debug
.vect
[0].a
.proc
= proc
;
3663 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3665 if (SCM_NIMP (proc
))
3671 scm_wrong_num_args (proc
);
3674 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3679 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3680 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3682 SCM_CLEAR_TRACED_FRAME (debug
);
3683 if (SCM_CHEAPTRAPS_P
)
3684 arg1
= scm_make_debugobj (&debug
);
3688 SCM val
= scm_make_continuation (&first
);
3699 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3703 scm_last_debug_frame
= debug
.prev
;
3709 /* SECTION: The rest of this file is only read once.
3714 /* Typechecking for multi-argument MAP and FOR-EACH.
3716 Verify that each element of the vector ARGV, except for the first,
3717 is a proper list whose length is LEN. Attribute errors to WHO,
3718 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3720 check_map_args (SCM argv
,
3727 SCM
*ve
= SCM_VELTS (argv
);
3730 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3732 long elt_len
= scm_ilength (ve
[i
]);
3737 scm_apply_generic (gf
, scm_cons (proc
, args
));
3739 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3743 scm_out_of_range (who
, ve
[i
]);
3746 scm_remember_upto_here_1 (argv
);
3750 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3752 /* Note: Currently, scm_map applies PROC to the argument list(s)
3753 sequentially, starting with the first element(s). This is used in
3754 evalext.c where the Scheme procedure `map-in-order', which guarantees
3755 sequential behaviour, is implemented using scm_map. If the
3756 behaviour changes, we need to update `map-in-order'.
3760 scm_map (SCM proc
, SCM arg1
, SCM args
)
3761 #define FUNC_NAME s_map
3766 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3768 len
= scm_ilength (arg1
);
3769 SCM_GASSERTn (len
>= 0,
3770 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3771 SCM_VALIDATE_REST_ARGUMENT (args
);
3772 if (SCM_NULLP (args
))
3774 while (SCM_NIMP (arg1
))
3776 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3778 pres
= SCM_CDRLOC (*pres
);
3779 arg1
= SCM_CDR (arg1
);
3783 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3784 ve
= SCM_VELTS (args
);
3785 #ifndef SCM_RECKLESS
3786 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3791 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3793 if (SCM_IMP (ve
[i
]))
3795 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3796 ve
[i
] = SCM_CDR (ve
[i
]);
3798 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3799 pres
= SCM_CDRLOC (*pres
);
3805 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3808 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3809 #define FUNC_NAME s_for_each
3811 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3813 len
= scm_ilength (arg1
);
3814 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3815 SCM_ARG2
, s_for_each
);
3816 SCM_VALIDATE_REST_ARGUMENT (args
);
3819 while SCM_NIMP (arg1
)
3821 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3822 arg1
= SCM_CDR (arg1
);
3824 return SCM_UNSPECIFIED
;
3826 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3827 ve
= SCM_VELTS (args
);
3828 #ifndef SCM_RECKLESS
3829 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3834 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3837 (ve
[i
]) return SCM_UNSPECIFIED
;
3838 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3839 ve
[i
] = SCM_CDR (ve
[i
]);
3841 scm_apply (proc
, arg1
, SCM_EOL
);
3848 scm_closure (SCM code
, SCM env
)
3853 SCM_SETCODE (z
, code
);
3854 SCM_SETENV (z
, env
);
3859 scm_t_bits scm_tc16_promise
;
3862 scm_makprom (SCM code
)
3864 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3870 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3872 int writingp
= SCM_WRITINGP (pstate
);
3873 scm_puts ("#<promise ", port
);
3874 SCM_SET_WRITINGP (pstate
, 1);
3875 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3876 SCM_SET_WRITINGP (pstate
, writingp
);
3877 scm_putc ('>', port
);
3882 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3884 "If the promise @var{x} has not been computed yet, compute and\n"
3885 "return @var{x}, otherwise just return the previously computed\n"
3887 #define FUNC_NAME s_scm_force
3889 SCM_VALIDATE_SMOB (1, x
, promise
);
3890 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3892 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3893 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3896 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3897 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3901 return SCM_CELL_OBJECT_1 (x
);
3906 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3908 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3909 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3910 #define FUNC_NAME s_scm_promise_p
3912 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3917 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3918 (SCM xorig
, SCM x
, SCM y
),
3919 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3920 "Any source properties associated with @var{xorig} are also associated\n"
3921 "with the new pair.")
3922 #define FUNC_NAME s_scm_cons_source
3926 SCM_SET_CELL_OBJECT_0 (z
, x
);
3927 SCM_SET_CELL_OBJECT_1 (z
, y
);
3928 /* Copy source properties possibly associated with xorig. */
3929 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3931 scm_whash_insert (scm_source_whash
, z
, p
);
3937 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3939 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3940 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3941 "contents of both pairs and vectors (since both cons cells and vector\n"
3942 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3943 "any other object.")
3944 #define FUNC_NAME s_scm_copy_tree
3949 if (SCM_VECTORP (obj
))
3951 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3952 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3954 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3957 if (SCM_NCONSP (obj
))
3959 ans
= tl
= scm_cons_source (obj
,
3960 scm_copy_tree (SCM_CAR (obj
)),
3962 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3964 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3968 SCM_SETCDR (tl
, obj
);
3974 /* We have three levels of EVAL here:
3976 - scm_i_eval (exp, env)
3978 evaluates EXP in environment ENV. ENV is a lexical environment
3979 structure as used by the actual tree code evaluator. When ENV is
3980 a top-level environment, then changes to the current module are
3981 tracked by updating ENV so that it continues to be in sync with
3984 - scm_primitive_eval (exp)
3986 evaluates EXP in the top-level environment as determined by the
3987 current module. This is done by constructing a suitable
3988 environment and calling scm_i_eval. Thus, changes to the
3989 top-level module are tracked normally.
3991 - scm_eval (exp, mod)
3993 evaluates EXP while MOD is the current module. This is done by
3994 setting the current module to MOD, invoking scm_primitive_eval on
3995 EXP, and then restoring the current module to the value it had
3996 previously. That is, while EXP is evaluated, changes to the
3997 current module are tracked, but these changes do not persist when
4000 For each level of evals, there are two variants, distinguished by a
4001 _x suffix: the ordinary variant does not modify EXP while the _x
4002 variant can destructively modify EXP into something completely
4003 unintelligible. A Scheme data structure passed as EXP to one of the
4004 _x variants should not ever be used again for anything. So when in
4005 doubt, use the ordinary variant.
4010 scm_i_eval_x (SCM exp
, SCM env
)
4012 return SCM_XEVAL (exp
, env
);
4016 scm_i_eval (SCM exp
, SCM env
)
4018 exp
= scm_copy_tree (exp
);
4019 return SCM_XEVAL (exp
, env
);
4023 scm_primitive_eval_x (SCM exp
)
4026 SCM transformer
= scm_current_module_transformer ();
4027 if (SCM_NIMP (transformer
))
4028 exp
= scm_call_1 (transformer
, exp
);
4029 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4030 return scm_i_eval_x (exp
, env
);
4033 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4035 "Evaluate @var{exp} in the top-level environment specified by\n"
4036 "the current module.")
4037 #define FUNC_NAME s_scm_primitive_eval
4040 SCM transformer
= scm_current_module_transformer ();
4041 if (SCM_NIMP (transformer
))
4042 exp
= scm_call_1 (transformer
, exp
);
4043 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4044 return scm_i_eval (exp
, env
);
4048 /* Eval does not take the second arg optionally. This is intentional
4049 * in order to be R5RS compatible, and to prepare for the new module
4050 * system, where we would like to make the choice of evaluation
4051 * environment explicit. */
4054 change_environment (void *data
)
4056 SCM pair
= SCM_PACK (data
);
4057 SCM new_module
= SCM_CAR (pair
);
4058 SCM old_module
= scm_current_module ();
4059 SCM_SETCDR (pair
, old_module
);
4060 scm_set_current_module (new_module
);
4065 restore_environment (void *data
)
4067 SCM pair
= SCM_PACK (data
);
4068 SCM old_module
= SCM_CDR (pair
);
4069 SCM new_module
= scm_current_module ();
4070 SCM_SETCAR (pair
, new_module
);
4071 scm_set_current_module (old_module
);
4075 inner_eval_x (void *data
)
4077 return scm_primitive_eval_x (SCM_PACK(data
));
4081 scm_eval_x (SCM exp
, SCM module
)
4082 #define FUNC_NAME "eval!"
4084 SCM_VALIDATE_MODULE (2, module
);
4086 return scm_internal_dynamic_wind
4087 (change_environment
, inner_eval_x
, restore_environment
,
4088 (void *) SCM_UNPACK (exp
),
4089 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4094 inner_eval (void *data
)
4096 return scm_primitive_eval (SCM_PACK(data
));
4099 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4100 (SCM exp
, SCM module
),
4101 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4102 "in the top-level environment specified by @var{module}.\n"
4103 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
4104 "@var{module} is made the current module. The current module\n"
4105 "is reset to its previous value when @var{eval} returns.")
4106 #define FUNC_NAME s_scm_eval
4108 SCM_VALIDATE_MODULE (2, module
);
4110 return scm_internal_dynamic_wind
4111 (change_environment
, inner_eval
, restore_environment
,
4112 (void *) SCM_UNPACK (exp
),
4113 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4117 #if (SCM_DEBUG_DEPRECATED == 0)
4119 /* Use scm_current_module () or scm_interaction_environment ()
4120 * instead. The former is the module selected during loading of code.
4121 * The latter is the module in which the user of this thread currently
4122 * types expressions.
4125 SCM scm_top_level_lookup_closure_var
;
4126 SCM scm_system_transformer
;
4128 /* Avoid using this functionality altogether (except for implementing
4129 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4131 * Applications should use either C level scm_eval_x or Scheme
4132 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4135 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4138 return scm_i_eval (obj
, env
);
4140 return scm_i_eval_x (obj
, env
);
4143 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4144 (SCM obj
, SCM env_thunk
),
4145 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4146 "designated by @var{lookup}, a symbol-lookup function."
4147 "Do not use this version of eval, it does not play well\n"
4148 "with the module system. Use @code{eval} or\n"
4149 "@code{primitive-eval} instead.")
4150 #define FUNC_NAME s_scm_eval2
4152 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4156 #endif /* DEPRECATED */
4159 /* At this point, scm_deval and scm_dapply are generated.
4162 #ifdef DEBUG_EXTENSIONS
4172 scm_init_opts (scm_evaluator_traps
,
4173 scm_evaluator_trap_table
,
4174 SCM_N_EVALUATOR_TRAPS
);
4175 scm_init_opts (scm_eval_options_interface
,
4177 SCM_N_EVAL_OPTIONS
);
4179 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4180 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4181 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4183 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4184 scm_undefineds
= scm_cons (SCM_UNDEFINED
, SCM_EOL
);
4185 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4186 scm_listofnull
= scm_cons (SCM_EOL
, SCM_EOL
);
4188 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4193 #if SCM_DEBUG_DEPRECATED == 0
4194 scm_top_level_lookup_closure_var
=
4195 scm_c_define ("*top-level-lookup-closure*", scm_make_fluid ());
4196 scm_system_transformer
=
4197 scm_c_define ("scm:eval-transformer", scm_make_fluid ());
4200 #ifndef SCM_MAGIC_SNARFER
4201 #include "libguile/eval.x"
4204 scm_c_define ("nil", scm_lisp_nil
);
4205 scm_c_define ("t", scm_lisp_t
);
4207 scm_add_feature ("delay");