1 /* Copyright (C) 1995, 96, 97, 98, 99, 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:".
56 /* SECTION: This code is compiled once.
61 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
62 #include "libguile/scmconfig.h"
64 /* AIX requires this to be the first thing in the file. The #pragma
65 directive is indented so pre-ANSI compilers will ignore it, rather
74 # ifndef alloca /* predefined by HP cc +Olibcalls */
81 #include "libguile/_scm.h"
82 #include "libguile/debug.h"
83 #include "libguile/dynwind.h"
84 #include "libguile/alist.h"
85 #include "libguile/eq.h"
86 #include "libguile/continuations.h"
87 #include "libguile/throw.h"
88 #include "libguile/smob.h"
89 #include "libguile/macros.h"
90 #include "libguile/procprop.h"
91 #include "libguile/hashtab.h"
92 #include "libguile/hash.h"
93 #include "libguile/srcprop.h"
94 #include "libguile/stackchk.h"
95 #include "libguile/objects.h"
96 #include "libguile/async.h"
97 #include "libguile/feature.h"
98 #include "libguile/modules.h"
99 #include "libguile/ports.h"
100 #include "libguile/root.h"
101 #include "libguile/vectors.h"
102 #include "libguile/fluids.h"
104 #include "libguile/validate.h"
105 #include "libguile/eval.h"
109 /* The evaluator contains a plethora of EVAL symbols.
110 * This is an attempt at explanation.
112 * The following macros should be used in code which is read twice
113 * (where the choice of evaluator is hard soldered):
115 * SCM_CEVAL is the symbol used within one evaluator to call itself.
116 * Originally, it is defined to scm_ceval, but is redefined to
117 * scm_deval during the second pass.
119 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
120 * only side effects of expressions matter. All immediates are
123 * SCM_EVALIM is used when it is known that the expression is an
124 * immediate. (This macro never calls an evaluator.)
126 * EVALCAR evaluates the car of an expression.
128 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
129 * car is a lisp cell.
131 * The following macros should be used in code which is read once
132 * (where the choice of evaluator is dynamic):
134 * SCM_XEVAL takes care of immediates without calling an evaluator. It
135 * then calls scm_ceval *or* scm_deval, depending on the debugging
138 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
139 * depending on the debugging mode.
141 * The main motivation for keeping this plethora is efficiency
142 * together with maintainability (=> locality of code).
145 #define SCM_CEVAL scm_ceval
146 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
148 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
149 ? *scm_lookupcar (x, env, 1) \
150 : SCM_CEVAL (SCM_CAR (x), env))
152 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
153 ? (SCM_IMP (SCM_CAR (x)) \
154 ? SCM_EVALIM (SCM_CAR (x), env) \
155 : SCM_GLOC_VAL (SCM_CAR (x))) \
156 : EVALCELLCAR (x, env))
158 #define EXTEND_ENV SCM_EXTEND_ENV
160 #ifdef MEMOIZE_LOCALS
163 scm_ilookup (SCM iloc
, SCM env
)
165 register int ir
= SCM_IFRAME (iloc
);
166 register SCM er
= env
;
167 for (; 0 != ir
; --ir
)
170 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
172 if (SCM_ICDRP (iloc
))
173 return SCM_CDRLOC (er
);
174 return SCM_CARLOC (SCM_CDR (er
));
180 /* The Lookup Car Race
183 Memoization of variables and special forms is done while executing
184 the code for the first time. As long as there is only one thread
185 everything is fine, but as soon as two threads execute the same
186 code concurrently `for the first time' they can come into conflict.
188 This memoization includes rewriting variable references into more
189 efficient forms and expanding macros. Furthermore, macro expansion
190 includes `compiling' special forms like `let', `cond', etc. into
191 tree-code instructions.
193 There shouldn't normally be a problem with memoizing local and
194 global variable references (into ilocs and glocs), because all
195 threads will mutate the code in *exactly* the same way and (if I
196 read the C code correctly) it is not possible to observe a half-way
197 mutated cons cell. The lookup procedure can handle this
198 transparently without any critical sections.
200 It is different with macro expansion, because macro expansion
201 happens outside of the lookup procedure and can't be
202 undone. Therefore it can't cope with it. It has to indicate
203 failure when it detects a lost race and hope that the caller can
204 handle it. Luckily, it turns out that this is the case.
206 An example to illustrate this: Suppose that the follwing form will
207 be memoized concurrently by two threads
211 Let's first examine the lookup of X in the body. The first thread
212 decides that it has to find the symbol "x" in the environment and
213 starts to scan it. Then the other thread takes over and actually
214 overtakes the first. It looks up "x" and substitutes an
215 appropriate iloc for it. Now the first thread continues and
216 completes its lookup. It comes to exactly the same conclusions as
217 the second one and could - without much ado - just overwrite the
218 iloc with the same iloc.
220 But let's see what will happen when the race occurs while looking
221 up the symbol "let" at the start of the form. It could happen that
222 the second thread interrupts the lookup of the first thread and not
223 only substitutes a gloc for it but goes right ahead and replaces it
224 with the compiled form (#@let* (x 12) x). Now, when the first
225 thread completes its lookup, it would replace the #@let* with a
226 gloc pointing to the "let" binding, effectively reverting the form
227 to (let (x 12) x). This is wrong. It has to detect that it has
228 lost the race and the evaluator has to reconsider the changed form
231 This race condition could be resolved with some kind of traffic
232 light (like mutexes) around scm_lookupcar, but I think that it is
233 best to avoid them in this case. They would serialize memoization
234 completely and because lookup involves calling arbitrary Scheme
235 code (via the lookup-thunk), threads could be blocked for an
236 arbitrary amount of time or even deadlock. But with the current
237 solution a lot of unnecessary work is potentially done. */
239 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
240 return NULL to indicate a failed lookup due to some race conditions
241 between threads. This only happens when VLOC is the first cell of
242 a special form that will eventually be memoized (like `let', etc.)
243 In that case the whole lookup is bogus and the caller has to
244 reconsider the complete special form.
246 SCM_LOOKUPCAR is still there, of course. It just calls
247 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
248 should only be called when it is known that VLOC is not the first
249 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
250 for NULL. I think I've found the only places where this
253 #endif /* USE_THREADS */
255 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
259 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
262 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
266 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
268 register SCM var2
= var
;
270 #ifdef MEMOIZE_LOCALS
271 register SCM iloc
= SCM_ILOC00
;
273 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
275 if (!SCM_CONSP (SCM_CAR (env
)))
277 al
= SCM_CARLOC (env
);
278 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
282 if (SCM_EQ_P (fl
, var
))
284 #ifdef MEMOIZE_LOCALS
286 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
289 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
291 return SCM_CDRLOC (*al
);
296 al
= SCM_CDRLOC (*al
);
297 if (SCM_EQ_P (SCM_CAR (fl
), var
))
299 #ifdef MEMOIZE_LOCALS
300 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
301 if (SCM_UNBNDP (SCM_CAR (*al
)))
308 if (SCM_CAR (vloc
) != var
)
311 SCM_SETCAR (vloc
, iloc
);
313 return SCM_CARLOC (*al
);
315 #ifdef MEMOIZE_LOCALS
316 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
319 #ifdef MEMOIZE_LOCALS
320 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
324 SCM top_thunk
, vcell
;
327 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
331 top_thunk
= SCM_BOOL_F
;
332 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
333 if (SCM_FALSEP (vcell
))
339 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
343 /* scm_everr (vloc, genv,...) */
347 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
348 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
350 scm_misc_error (NULL
, "Damaged environment: ~S",
351 scm_cons (var
, SCM_EOL
));
354 /* A variable could not be found, but we shall not throw an error. */
355 static SCM undef_object
= SCM_UNDEFINED
;
356 return &undef_object
;
361 if (SCM_CAR (vloc
) != var2
)
363 /* Some other thread has changed the very cell we are working
364 on. In effect, it must have done our job or messed it up
367 var
= SCM_CAR (vloc
);
368 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
369 return SCM_GLOC_VAL_LOC (var
);
370 #ifdef MEMOIZE_LOCALS
371 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
372 return scm_ilookup (var
, genv
);
374 /* We can't cope with anything else than glocs and ilocs. When
375 a special form has been memoized (i.e. `let' into `#@let') we
376 return NULL and expect the calling function to do the right
377 thing. For the evaluator, this means going back and redoing
378 the dispatch on the car of the form. */
381 #endif /* USE_THREADS */
383 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
384 /* Except wait...what if the var is not a vcell,
385 * but syntax or something.... */
386 return SCM_CDRLOC (var
);
391 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
393 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
400 #define unmemocar scm_unmemocar
403 scm_unmemocar (SCM form
, SCM env
)
410 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
411 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
412 #ifdef MEMOIZE_LOCALS
413 #ifdef DEBUG_EXTENSIONS
414 else if (SCM_ILOCP (c
))
418 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
420 env
= SCM_CAR (SCM_CAR (env
));
421 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
423 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
432 scm_eval_car (SCM pair
, SCM env
)
434 return SCM_XEVALCAR (pair
, env
);
439 * The following rewrite expressions and
440 * some memoized forms have different syntax
443 const char scm_s_expression
[] = "missing or extra expression";
444 const char scm_s_test
[] = "bad test";
445 const char scm_s_body
[] = "bad body";
446 const char scm_s_bindings
[] = "bad bindings";
447 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
448 const char scm_s_variable
[] = "bad variable";
449 const char scm_s_clauses
[] = "bad or missing clauses";
450 const char scm_s_formals
[] = "bad formals";
451 const char scm_s_duplicate_formals
[] = "duplicate formals";
453 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
454 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
455 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
456 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
457 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
461 #ifdef DEBUG_EXTENSIONS
462 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
463 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
464 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
465 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
469 /* Check that the body denoted by XORIG is valid and rewrite it into
470 its internal form. The internal form of a body is just the body
471 itself, but prefixed with an ISYM that denotes to what kind of
472 outer construct this body belongs. A lambda body starts with
473 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
474 etc. The one exception is a body that belongs to a letrec that has
475 been formed by rewriting internal defines: it starts with
478 /* XXX - Besides controlling the rewriting of internal defines, the
479 additional ISYM could be used for improved error messages.
480 This is not done yet. */
483 scm_m_body (SCM op
, SCM xorig
, const char *what
)
485 SCM_ASSYNT (scm_ilength (xorig
) >= 1, xorig
, scm_s_expression
, what
);
487 /* Don't add another ISYM if one is present already. */
488 if (SCM_ISYMP (SCM_CAR (xorig
)))
491 /* Retain possible doc string. */
492 if (!SCM_CONSP (SCM_CAR (xorig
)))
494 if (SCM_NNULLP (SCM_CDR(xorig
)))
495 return scm_cons (SCM_CAR (xorig
),
496 scm_m_body (op
, SCM_CDR(xorig
), what
));
500 return scm_cons (op
, xorig
);
503 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
504 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
507 scm_m_quote (SCM xorig
, SCM env
)
509 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
511 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
512 xorig
, scm_s_expression
, s_quote
);
513 return scm_cons (SCM_IM_QUOTE
, x
);
518 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
519 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
522 scm_m_begin (SCM xorig
, SCM env
)
524 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
525 xorig
, scm_s_expression
, s_begin
);
526 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
529 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
530 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
533 scm_m_if (SCM xorig
, SCM env
)
535 int len
= scm_ilength (SCM_CDR (xorig
));
536 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
537 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
541 /* Will go into the RnRS module when Guile is factorized.
542 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
543 const char scm_s_set_x
[] = "set!";
544 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
547 scm_m_set_x (SCM xorig
, SCM env
)
549 SCM x
= SCM_CDR (xorig
);
550 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
551 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
552 xorig
, scm_s_variable
, scm_s_set_x
);
553 return scm_cons (SCM_IM_SET_X
, x
);
557 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
558 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
561 scm_m_and (SCM xorig
, SCM env
)
563 int len
= scm_ilength (SCM_CDR (xorig
));
564 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
566 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
571 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
572 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
575 scm_m_or (SCM xorig
, SCM env
)
577 int len
= scm_ilength (SCM_CDR (xorig
));
578 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
580 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
586 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
587 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
590 scm_m_case (SCM xorig
, SCM env
)
592 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
593 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
594 while (SCM_NIMP (x
= SCM_CDR (x
)))
597 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
598 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
599 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
600 && SCM_NULLP (SCM_CDR (x
))),
601 xorig
, scm_s_clauses
, s_case
);
603 return scm_cons (SCM_IM_CASE
, cdrx
);
607 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
608 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
612 scm_m_cond (SCM xorig
, SCM env
)
614 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
615 int len
= scm_ilength (x
);
616 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
620 len
= scm_ilength (arg1
);
621 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
622 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
624 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
625 xorig
, "bad ELSE clause", s_cond
);
626 SCM_SETCAR (arg1
, SCM_BOOL_T
);
628 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
629 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
630 xorig
, "bad recipient", s_cond
);
633 return scm_cons (SCM_IM_COND
, cdrx
);
636 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
637 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
639 /* Return #t if OBJ is `eq?' to one of the elements of LIST or to the
640 cdr of the last cons. (Thus, LIST is not required to be a proper
641 list and when OBJ also found in the improper ending.) */
644 scm_c_improper_memq (SCM obj
, SCM list
)
646 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
648 if (SCM_EQ_P (SCM_CAR (list
), obj
))
651 return SCM_EQ_P (list
, obj
);
655 scm_m_lambda (SCM xorig
, SCM env
)
657 SCM proc
, x
= SCM_CDR (xorig
);
658 if (scm_ilength (x
) < 2)
661 if (SCM_NULLP (proc
))
663 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
667 if (SCM_SYMBOLP (proc
))
669 if (SCM_NCONSP (proc
))
671 while (SCM_NIMP (proc
))
673 if (SCM_NCONSP (proc
))
675 if (!SCM_SYMBOLP (proc
))
680 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
682 else if (scm_c_improper_memq (SCM_CAR(proc
), SCM_CDR(proc
)))
683 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
684 proc
= SCM_CDR (proc
);
686 if (SCM_NNULLP (proc
))
689 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
693 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
694 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
697 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
698 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
702 scm_m_letstar (SCM xorig
, SCM env
)
704 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
705 int len
= scm_ilength (x
);
706 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
708 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
709 while (SCM_NIMP (proc
))
711 arg1
= SCM_CAR (proc
);
712 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
713 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
714 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
715 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
716 proc
= SCM_CDR (proc
);
718 x
= scm_cons (vars
, SCM_CDR (x
));
720 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
721 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
724 /* DO gets the most radically altered syntax
725 (do ((<var1> <init1> <step1>)
731 (do_mem (varn ... var2 var1)
732 (<init1> <init2> ... <initn>)
735 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
738 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
739 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
742 scm_m_do (SCM xorig
, SCM env
)
744 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
745 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
746 SCM
*initloc
= &inits
, *steploc
= &steps
;
747 int len
= scm_ilength (x
);
748 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
750 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
751 while (SCM_NIMP(proc
))
753 arg1
= SCM_CAR (proc
);
754 len
= scm_ilength (arg1
);
755 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
756 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
757 /* vars reversed here, inits and steps reversed at evaluation */
758 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
759 arg1
= SCM_CDR (arg1
);
760 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
761 initloc
= SCM_CDRLOC (*initloc
);
762 arg1
= SCM_CDR (arg1
);
763 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
764 steploc
= SCM_CDRLOC (*steploc
);
765 proc
= SCM_CDR (proc
);
768 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
769 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
770 x
= scm_cons2 (vars
, inits
, x
);
771 return scm_cons (SCM_IM_DO
, x
);
774 /* evalcar is small version of inline EVALCAR when we don't care about
777 #define evalcar scm_eval_car
780 static SCM
iqq (SCM form
, SCM env
, int depth
);
782 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
783 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
786 scm_m_quasiquote (SCM xorig
, SCM env
)
788 SCM x
= SCM_CDR (xorig
);
789 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
790 return iqq (SCM_CAR (x
), env
, 1);
795 iqq (SCM form
,SCM env
,int depth
)
801 if (SCM_VECTORP (form
))
803 long i
= SCM_VECTOR_LENGTH (form
);
804 SCM
*data
= SCM_VELTS (form
);
807 tmp
= scm_cons (data
[i
], tmp
);
808 return scm_vector (iqq (tmp
, env
, depth
));
810 if (SCM_NCONSP(form
))
812 tmp
= SCM_CAR (form
);
813 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
818 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
822 form
= SCM_CDR (form
);
823 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
824 form
, SCM_ARG1
, s_quasiquote
);
826 return evalcar (form
, env
);
827 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
829 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
833 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
835 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
838 /* Here are acros which return values rather than code. */
840 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
841 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
844 scm_m_delay (SCM xorig
, SCM env
)
846 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
847 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
851 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
852 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
855 scm_m_define (SCM x
, SCM env
)
859 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
862 while (SCM_CONSP (proc
))
863 { /* nested define syntax */
864 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
865 proc
= SCM_CAR (proc
);
867 SCM_ASSYNT (SCM_SYMBOLP (proc
),
868 arg1
, scm_s_variable
, s_define
);
869 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
870 if (SCM_TOP_LEVEL (env
))
872 x
= evalcar (x
, env
);
873 #ifdef DEBUG_EXTENSIONS
874 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
878 if (SCM_CLOSUREP (arg1
)
879 /* Only the first definition determines the name. */
880 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
881 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
882 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
883 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
885 arg1
= SCM_CDR (arg1
);
890 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
891 SCM_SETCDR (arg1
, x
);
893 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
895 return SCM_UNSPECIFIED
;
898 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
904 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
906 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
907 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
908 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
909 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
912 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
915 /* vars scm_list reversed here, inits reversed at evaluation */
916 arg1
= SCM_CAR (proc
);
917 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
918 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
919 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
920 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
921 vars
= scm_cons (SCM_CAR (arg1
), vars
);
922 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
923 initloc
= SCM_CDRLOC (*initloc
);
925 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
927 return scm_cons2 (op
, vars
,
928 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
931 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
932 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
935 scm_m_letrec (SCM xorig
, SCM env
)
937 SCM x
= SCM_CDR (xorig
);
938 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
940 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
941 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
942 scm_m_body (SCM_IM_LETREC
,
947 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
950 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
951 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
954 scm_m_let (SCM xorig
, SCM env
)
956 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
957 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
958 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
960 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
964 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
966 /* null or single binding, let* is faster */
967 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
968 scm_m_body (SCM_IM_LET
,
974 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
975 if (SCM_CONSP (proc
))
977 /* plain let, proc is <bindings> */
978 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
981 if (!SCM_SYMBOLP (proc
))
982 scm_misc_error (s_let
, scm_s_bindings
, SCM_EOL
); /* bad let */
983 name
= proc
; /* named let, build equiv letrec */
985 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
986 proc
= SCM_CAR (x
); /* bindings list */
987 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
988 while (SCM_NIMP (proc
))
989 { /* vars and inits both in order */
990 arg1
= SCM_CAR (proc
);
991 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
992 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
993 xorig
, scm_s_variable
, s_let
);
994 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
995 varloc
= SCM_CDRLOC (*varloc
);
996 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
997 initloc
= SCM_CDRLOC (*initloc
);
998 proc
= SCM_CDR (proc
);
1001 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1002 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1003 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1005 scm_acons (name
, inits
, SCM_EOL
));
1006 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1010 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1011 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1012 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1015 scm_m_apply (SCM xorig
, SCM env
)
1017 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1018 xorig
, scm_s_expression
, s_atapply
);
1019 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1023 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1024 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1028 scm_m_cont (SCM xorig
, SCM env
)
1030 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1031 xorig
, scm_s_expression
, s_atcall_cc
);
1032 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1035 /* Multi-language support */
1040 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1043 scm_m_nil_cond (SCM xorig
, SCM env
)
1045 int len
= scm_ilength (SCM_CDR (xorig
));
1046 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1047 scm_s_expression
, "nil-cond");
1048 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1051 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1054 scm_m_nil_ify (SCM xorig
, SCM env
)
1056 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1057 xorig
, scm_s_expression
, "nil-ify");
1058 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1061 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1064 scm_m_t_ify (SCM xorig
, SCM env
)
1066 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1067 xorig
, scm_s_expression
, "t-ify");
1068 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1071 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1074 scm_m_0_cond (SCM xorig
, SCM env
)
1076 int len
= scm_ilength (SCM_CDR (xorig
));
1077 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1078 scm_s_expression
, "0-cond");
1079 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1082 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1085 scm_m_0_ify (SCM xorig
, SCM env
)
1087 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1088 xorig
, scm_s_expression
, "0-ify");
1089 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1095 scm_m_1_ify (SCM xorig
, SCM env
)
1097 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1098 xorig
, scm_s_expression
, "1-ify");
1099 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1102 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1105 scm_m_atfop (SCM xorig
, SCM env
)
1107 SCM x
= SCM_CDR (xorig
), vcell
;
1108 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1109 vcell
= scm_symbol_fref (SCM_CAR (x
));
1110 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1111 "Symbol's function definition is void", NULL
);
1112 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1116 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1119 scm_m_atbind (SCM xorig
, SCM env
)
1121 SCM x
= SCM_CDR (xorig
);
1122 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1128 while (SCM_NIMP (SCM_CDR (env
)))
1129 env
= SCM_CDR (env
);
1130 env
= SCM_CAR (env
);
1131 if (SCM_CONSP (env
))
1136 while (SCM_NIMP (x
))
1138 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1141 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1145 scm_m_expand_body (SCM xorig
, SCM env
)
1147 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1148 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1150 while (SCM_NIMP (x
))
1153 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1155 if (SCM_IMP (SCM_CAR (form
)))
1157 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1160 form
= scm_macroexp (scm_cons_source (form
,
1165 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1167 defs
= scm_cons (SCM_CDR (form
), defs
);
1170 else if (SCM_NIMP(defs
))
1174 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1176 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1180 x
= scm_cons (form
, SCM_CDR(x
));
1185 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1186 if (SCM_NIMP (defs
))
1188 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1190 scm_cons2 (scm_sym_define
, defs
, x
),
1196 SCM_SETCAR (xorig
, SCM_CAR (x
));
1197 SCM_SETCDR (xorig
, SCM_CDR (x
));
1204 scm_macroexp (SCM x
, SCM env
)
1208 /* Don't bother to produce error messages here. We get them when we
1209 eventually execute the code for real. */
1212 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1217 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1218 if (proc_ptr
== NULL
)
1220 /* We have lost the race. */
1226 proc
= *scm_lookupcar (x
, env
, 0);
1229 /* Only handle memoizing macros. `Acros' and `macros' are really
1230 special forms and should not be evaluated here. */
1233 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1234 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1238 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1240 if (scm_ilength (res
) <= 0)
1241 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1244 SCM_SETCAR (x
, SCM_CAR (res
));
1245 SCM_SETCDR (x
, SCM_CDR (res
));
1251 /* scm_unmemocopy takes a memoized expression together with its
1252 * environment and rewrites it to its original form. Thus, it is the
1253 * inversion of the rewrite rules above. The procedure is not
1254 * optimized for speed. It's used in scm_iprin1 when printing the
1255 * code of a closure, in scm_procedure_source, in display_frame when
1256 * generating the source for a stackframe in a backtrace, and in
1257 * display_expression.
1260 /* We should introduce an anti-macro interface so that it is possible
1261 * to plug in transformers in both directions from other compilation
1262 * units. unmemocopy could then dispatch to anti-macro transformers.
1263 * (Those transformers could perhaps be written in slightly more
1264 * readable style... :)
1267 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1270 unmemocopy (SCM x
, SCM env
)
1273 #ifdef DEBUG_EXTENSIONS
1276 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1278 #ifdef DEBUG_EXTENSIONS
1279 p
= scm_whash_lookup (scm_source_whash
, x
);
1281 switch (SCM_TYP7 (x
))
1283 case SCM_BIT8(SCM_IM_AND
):
1284 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1286 case SCM_BIT8(SCM_IM_BEGIN
):
1287 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1289 case SCM_BIT8(SCM_IM_CASE
):
1290 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1292 case SCM_BIT8(SCM_IM_COND
):
1293 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1295 case SCM_BIT8(SCM_IM_DO
):
1296 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1298 case SCM_BIT8(SCM_IM_IF
):
1299 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1301 case SCM_BIT8(SCM_IM_LET
):
1302 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1304 case SCM_BIT8(SCM_IM_LETREC
):
1307 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1311 f
= v
= SCM_CAR (x
);
1313 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1315 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1316 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1319 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1320 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1322 /* build transformed binding list */
1324 while (SCM_NIMP (v
))
1326 z
= scm_acons (SCM_CAR (v
),
1327 scm_cons (SCM_CAR (e
),
1328 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1330 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1336 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1338 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1342 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1345 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1346 /* body forms are now to be found in SCM_CDR (x)
1347 (this is how *real* code look like! :) */
1351 case SCM_BIT8(SCM_IM_LETSTAR
):
1359 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1362 y
= z
= scm_acons (SCM_CAR (b
),
1364 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1366 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1367 b
= SCM_CDR (SCM_CDR (b
));
1370 SCM_SETCDR (y
, SCM_EOL
);
1371 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1376 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1378 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1381 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1382 b
= SCM_CDR (SCM_CDR (b
));
1384 while (SCM_NIMP (b
));
1385 SCM_SETCDR (z
, SCM_EOL
);
1387 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1390 case SCM_BIT8(SCM_IM_OR
):
1391 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1393 case SCM_BIT8(SCM_IM_LAMBDA
):
1395 ls
= scm_cons (scm_sym_lambda
,
1396 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1397 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1399 case SCM_BIT8(SCM_IM_QUOTE
):
1400 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1402 case SCM_BIT8(SCM_IM_SET_X
):
1403 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1405 case SCM_BIT8(SCM_IM_DEFINE
):
1409 ls
= scm_cons (scm_sym_define
,
1410 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1411 if (SCM_NNULLP (env
))
1412 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1415 case SCM_BIT8(SCM_MAKISYM (0)):
1419 switch (SCM_ISYMNUM (z
))
1421 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1422 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1424 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1425 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1427 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1428 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1432 /* appease the Sun compiler god: */ ;
1436 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1441 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1443 if (SCM_ISYMP (SCM_CAR (x
)))
1444 /* skip body markers */
1446 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1452 #ifdef DEBUG_EXTENSIONS
1453 if (SCM_NFALSEP (p
))
1454 scm_whash_insert (scm_source_whash
, ls
, p
);
1461 scm_unmemocopy (SCM x
, SCM env
)
1463 if (SCM_NNULLP (env
))
1464 /* Make a copy of the lowest frame to protect it from
1465 modifications by SCM_IM_DEFINE */
1466 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1468 return unmemocopy (x
, env
);
1471 #ifndef SCM_RECKLESS
1474 scm_badargsp (SCM formals
, SCM args
)
1476 while (SCM_NIMP (formals
))
1478 if (SCM_NCONSP (formals
))
1482 formals
= SCM_CDR (formals
);
1483 args
= SCM_CDR (args
);
1485 return SCM_NNULLP (args
) ? 1 : 0;
1490 scm_badformalsp (SCM closure
, int n
)
1492 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1493 while (SCM_NIMP (formals
))
1495 if (SCM_NCONSP (formals
))
1500 formals
= SCM_CDR (formals
);
1507 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1509 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1510 while (SCM_NIMP (l
))
1515 if (SCM_IMP (SCM_CAR (l
)))
1516 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1518 res
= EVALCELLCAR (l
, env
);
1520 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1522 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1524 res
= SCM_CAR (l
); /* struct planted in code */
1526 res
= SCM_PACK (vcell
);
1531 res
= EVALCAR (l
, env
);
1533 *lloc
= scm_cons (res
, SCM_EOL
);
1534 lloc
= SCM_CDRLOC (*lloc
);
1541 scm_wrong_num_args (proc
);
1548 scm_eval_body (SCM code
, SCM env
)
1553 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1555 if (SCM_IMP (SCM_CAR (code
)))
1557 if (SCM_ISYMP (SCM_CAR (code
)))
1559 code
= scm_m_expand_body (code
, env
);
1564 SCM_XEVAL (SCM_CAR (code
), env
);
1567 return SCM_XEVALCAR (code
, env
);
1574 /* SECTION: This code is specific for the debugging support. One
1575 * branch is read when DEVAL isn't defined, the other when DEVAL is
1581 #define SCM_APPLY scm_apply
1582 #define PREP_APPLY(proc, args)
1584 #define RETURN(x) return x;
1585 #ifdef STACK_CHECKING
1586 #ifndef NO_CEVAL_STACK_CHECKING
1587 #define EVAL_STACK_CHECKING
1594 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1596 #define SCM_APPLY scm_dapply
1598 #define PREP_APPLY(p, l) \
1599 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1601 #define ENTER_APPLY \
1603 SCM_SET_ARGSREADY (debug);\
1604 if (CHECK_APPLY && SCM_TRAPS_P)\
1605 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1607 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1608 SCM_SET_TRACED_FRAME (debug); \
1609 if (SCM_CHEAPTRAPS_P)\
1611 tmp = scm_make_debugobj (&debug);\
1612 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1617 tmp = scm_make_continuation (&first);\
1619 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1624 #define RETURN(e) {proc = (e); goto exit;}
1625 #ifdef STACK_CHECKING
1626 #ifndef EVAL_STACK_CHECKING
1627 #define EVAL_STACK_CHECKING
1631 /* scm_ceval_ptr points to the currently selected evaluator.
1632 * *fixme*: Although efficiency is important here, this state variable
1633 * should probably not be a global. It should be related to the
1638 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1640 /* scm_last_debug_frame contains a pointer to the last debugging
1641 * information stack frame. It is accessed very often from the
1642 * debugging evaluator, so it should probably not be indirectly
1643 * addressed. Better to save and restore it from the current root at
1648 scm_debug_frame
*scm_last_debug_frame
;
1651 /* scm_debug_eframe_size is the number of slots available for pseudo
1652 * stack frames at each real stack frame.
1655 int scm_debug_eframe_size
;
1657 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1661 scm_option scm_eval_opts
[] = {
1662 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1665 scm_option scm_debug_opts
[] = {
1666 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1667 "*Flyweight representation of the stack at traps." },
1668 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1669 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1670 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1671 "Record procedure names at definition." },
1672 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1673 "Display backtrace in anti-chronological order." },
1674 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1675 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1676 { SCM_OPTION_INTEGER
, "frames", 3,
1677 "Maximum number of tail-recursive frames in backtrace." },
1678 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1679 "Maximal number of stored backtrace frames." },
1680 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1681 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1682 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1683 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1686 scm_option scm_evaluator_trap_table
[] = {
1687 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1688 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1689 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1690 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1693 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1695 "Option interface for the evaluation options. Instead of using\n"
1696 "this procedure directly, use the procedures @code{eval-enable},\n"
1697 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1698 #define FUNC_NAME s_scm_eval_options_interface
1702 ans
= scm_options (setting
,
1706 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1712 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1714 "Option interface for the evaluator trap options.")
1715 #define FUNC_NAME s_scm_evaluator_traps
1719 ans
= scm_options (setting
,
1720 scm_evaluator_trap_table
,
1721 SCM_N_EVALUATOR_TRAPS
,
1723 SCM_RESET_DEBUG_MODE
;
1730 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1732 SCM
*results
= lloc
, res
;
1733 while (SCM_NIMP (l
))
1738 if (SCM_IMP (SCM_CAR (l
)))
1739 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1741 res
= EVALCELLCAR (l
, env
);
1743 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1745 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1747 res
= SCM_CAR (l
); /* struct planted in code */
1749 res
= SCM_PACK (vcell
);
1754 res
= EVALCAR (l
, env
);
1756 *lloc
= scm_cons (res
, SCM_EOL
);
1757 lloc
= SCM_CDRLOC (*lloc
);
1764 scm_wrong_num_args (proc
);
1773 /* SECTION: Some local definitions for the evaluator.
1776 /* Update the toplevel environment frame ENV so that it refers to the
1779 #define UPDATE_TOPLEVEL_ENV(env) \
1781 SCM p = scm_current_module_lookup_closure (); \
1782 if (p != SCM_CAR(env)) \
1783 env = scm_top_level_env (p); \
1787 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1790 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1792 /* SECTION: This is the evaluator. Like any real monster, it has
1793 * three heads. This code is compiled twice.
1799 scm_ceval (SCM x
, SCM env
)
1805 scm_deval (SCM x
, SCM env
)
1810 SCM_CEVAL (SCM x
, SCM env
)
1819 scm_debug_frame debug
;
1820 scm_debug_info
*debug_info_end
;
1821 debug
.prev
= scm_last_debug_frame
;
1822 debug
.status
= scm_debug_eframe_size
;
1824 * The debug.vect contains twice as much scm_debug_info frames as the
1825 * user has specified with (debug-set! frames <n>).
1827 * Even frames are eval frames, odd frames are apply frames.
1829 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1830 * sizeof (debug
.vect
[0]));
1831 debug
.info
= debug
.vect
;
1832 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1833 scm_last_debug_frame
= &debug
;
1835 #ifdef EVAL_STACK_CHECKING
1836 if (scm_stack_checking_enabled_p
1837 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1840 debug
.info
->e
.exp
= x
;
1841 debug
.info
->e
.env
= env
;
1843 scm_report_stack_overflow ();
1850 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1853 SCM_CLEAR_ARGSREADY (debug
);
1854 if (SCM_OVERFLOWP (debug
))
1857 * In theory, this should be the only place where it is necessary to
1858 * check for space in debug.vect since both eval frames and
1859 * available space are even.
1861 * For this to be the case, however, it is necessary that primitive
1862 * special forms which jump back to `loop', `begin' or some similar
1863 * label call PREP_APPLY. A convenient way to do this is to jump to
1864 * `loopnoap' or `cdrxnoap'.
1866 else if (++debug
.info
>= debug_info_end
)
1868 SCM_SET_OVERFLOW (debug
);
1872 debug
.info
->e
.exp
= x
;
1873 debug
.info
->e
.env
= env
;
1874 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1875 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1877 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1878 SCM_SET_TAILREC (debug
);
1879 if (SCM_CHEAPTRAPS_P
)
1880 t
.arg1
= scm_make_debugobj (&debug
);
1884 SCM val
= scm_make_continuation (&first
);
1896 /* This gives the possibility for the debugger to
1897 modify the source expression before evaluation. */
1901 scm_ithrow (scm_sym_enter_frame
,
1902 scm_cons2 (t
.arg1
, tail
,
1903 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1907 #if defined (USE_THREADS) || defined (DEVAL)
1911 switch (SCM_TYP7 (x
))
1913 case scm_tc7_symbol
:
1914 /* Only happens when called at top level.
1916 x
= scm_cons (x
, SCM_UNDEFINED
);
1919 case SCM_BIT8(SCM_IM_AND
):
1922 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1923 if (SCM_FALSEP (EVALCAR (x
, env
)))
1925 RETURN (SCM_BOOL_F
);
1929 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1932 case SCM_BIT8(SCM_IM_BEGIN
):
1933 /* (currently unused)
1935 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1936 /* (currently unused)
1941 /* If we are on toplevel with a lookup closure, we need to sync
1942 with the current module. */
1943 if (SCM_CONSP(env
) && !SCM_CONSP(SCM_CAR(env
)))
1946 UPDATE_TOPLEVEL_ENV (env
);
1947 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1951 UPDATE_TOPLEVEL_ENV (env
);
1956 goto nontoplevel_begin
;
1958 nontoplevel_cdrxnoap
:
1959 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1960 nontoplevel_cdrxbegin
:
1964 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1966 if (SCM_IMP (SCM_CAR (x
)))
1968 if (SCM_ISYMP (SCM_CAR (x
)))
1970 x
= scm_m_expand_body (x
, env
);
1971 goto nontoplevel_begin
;
1974 SCM_EVALIM2 (SCM_CAR(x
));
1977 SCM_CEVAL (SCM_CAR (x
), env
);
1981 carloop
: /* scm_eval car of last form in list */
1982 if (SCM_NCELLP (SCM_CAR (x
)))
1985 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1988 if (SCM_SYMBOLP (SCM_CAR (x
)))
1991 RETURN (*scm_lookupcar (x
, env
, 1))
1995 goto loop
; /* tail recurse */
1998 case SCM_BIT8(SCM_IM_CASE
):
2000 t
.arg1
= EVALCAR (x
, env
);
2001 while (SCM_NIMP (x
= SCM_CDR (x
)))
2004 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2007 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2010 proc
= SCM_CAR (proc
);
2011 while (SCM_NIMP (proc
))
2013 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2015 x
= SCM_CDR (SCM_CAR (x
));
2016 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2019 proc
= SCM_CDR (proc
);
2022 RETURN (SCM_UNSPECIFIED
)
2025 case SCM_BIT8(SCM_IM_COND
):
2026 while (SCM_NIMP (x
= SCM_CDR (x
)))
2029 t
.arg1
= EVALCAR (proc
, env
);
2030 if (SCM_NFALSEP (t
.arg1
))
2037 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2039 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2043 proc
= EVALCAR (proc
, env
);
2044 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2045 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2047 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2048 goto umwrongnumargs
;
2052 RETURN (SCM_UNSPECIFIED
)
2055 case SCM_BIT8(SCM_IM_DO
):
2057 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2058 t
.arg1
= SCM_EOL
; /* values */
2059 while (SCM_NIMP (proc
))
2061 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2062 proc
= SCM_CDR (proc
);
2064 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2065 x
= SCM_CDR (SCM_CDR (x
));
2066 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2068 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2070 t
.arg1
= SCM_CAR (proc
); /* body */
2071 SIDEVAL (t
.arg1
, env
);
2073 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2075 proc
= SCM_CDR (proc
))
2076 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2077 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2081 RETURN (SCM_UNSPECIFIED
);
2082 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2083 goto nontoplevel_begin
;
2086 case SCM_BIT8(SCM_IM_IF
):
2088 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2090 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2092 RETURN (SCM_UNSPECIFIED
);
2094 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2098 case SCM_BIT8(SCM_IM_LET
):
2100 proc
= SCM_CAR (SCM_CDR (x
));
2104 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2106 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2107 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2109 goto nontoplevel_cdrxnoap
;
2112 case SCM_BIT8(SCM_IM_LETREC
):
2114 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2120 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2122 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2123 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2124 goto nontoplevel_cdrxnoap
;
2127 case SCM_BIT8(SCM_IM_LETSTAR
):
2132 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2133 goto nontoplevel_cdrxnoap
;
2137 t
.arg1
= SCM_CAR (proc
);
2138 proc
= SCM_CDR (proc
);
2139 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2141 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2142 goto nontoplevel_cdrxnoap
;
2144 case SCM_BIT8(SCM_IM_OR
):
2147 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2149 x
= EVALCAR (x
, env
);
2150 if (SCM_NFALSEP (x
))
2156 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2160 case SCM_BIT8(SCM_IM_LAMBDA
):
2161 RETURN (scm_closure (SCM_CDR (x
), env
));
2164 case SCM_BIT8(SCM_IM_QUOTE
):
2165 RETURN (SCM_CAR (SCM_CDR (x
)));
2168 case SCM_BIT8(SCM_IM_SET_X
):
2171 switch (SCM_ITAG3 (proc
))
2174 t
.lloc
= scm_lookupcar (x
, env
, 1);
2176 case scm_tc3_cons_gloc
:
2177 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2179 #ifdef MEMOIZE_LOCALS
2181 t
.lloc
= scm_ilookup (proc
, env
);
2186 *t
.lloc
= EVALCAR (x
, env
);
2190 RETURN (SCM_UNSPECIFIED
);
2194 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2195 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2197 /* new syntactic forms go here. */
2198 case SCM_BIT8(SCM_MAKISYM (0)):
2200 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2201 switch SCM_ISYMNUM (proc
)
2203 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2205 proc
= EVALCAR (proc
, env
);
2206 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2207 if (SCM_CLOSUREP (proc
))
2210 PREP_APPLY (proc
, SCM_EOL
);
2211 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2212 t
.arg1
= EVALCAR (t
.arg1
, env
);
2214 debug
.info
->a
.args
= t
.arg1
;
2216 #ifndef SCM_RECKLESS
2217 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2221 /* Copy argument list */
2222 if (SCM_IMP (t
.arg1
))
2226 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2227 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2228 && SCM_CONSP (t
.arg1
))
2230 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2234 SCM_SETCDR (tl
, t
.arg1
);
2237 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2238 x
= SCM_CODE (proc
);
2239 goto nontoplevel_cdrxbegin
;
2244 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2247 SCM val
= scm_make_continuation (&first
);
2255 proc
= evalcar (proc
, env
);
2256 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2257 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2259 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2260 goto umwrongnumargs
;
2263 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2264 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2266 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2267 proc
= SCM_CADR (x
); /* unevaluated operands */
2268 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2270 arg2
= *scm_ilookup (proc
, env
);
2271 else if (SCM_NCONSP (proc
))
2273 if (SCM_NCELLP (proc
))
2274 arg2
= SCM_GLOC_VAL (proc
);
2276 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2280 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2281 t
.lloc
= SCM_CDRLOC (arg2
);
2282 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2284 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2285 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2290 /* The type dispatch code is duplicated here
2291 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2292 * cuts down execution time for type dispatch to 50%.
2295 int i
, n
, end
, mask
;
2296 SCM z
= SCM_CDDR (x
);
2297 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2298 proc
= SCM_CADR (z
);
2300 if (SCM_NIMP (proc
))
2302 /* Prepare for linear search */
2305 end
= SCM_VECTOR_LENGTH (proc
);
2309 /* Compute a hash value */
2310 int hashset
= SCM_INUM (proc
);
2312 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2313 proc
= SCM_CADR (z
);
2316 if (SCM_NIMP (t
.arg1
))
2319 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2320 [scm_si_hashsets
+ hashset
];
2321 t
.arg1
= SCM_CDR (t
.arg1
);
2323 while (j
-- && SCM_NIMP (t
.arg1
));
2328 /* Search for match */
2332 z
= SCM_VELTS (proc
)[i
];
2333 t
.arg1
= arg2
; /* list of arguments */
2334 if (SCM_NIMP (t
.arg1
))
2337 /* More arguments than specifiers => CLASS != ENV */
2338 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2340 t
.arg1
= SCM_CDR (t
.arg1
);
2343 while (j
-- && SCM_NIMP (t
.arg1
));
2344 /* Fewer arguments than specifiers => CAR != ENV */
2345 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2348 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2350 SCM_CMETHOD_ENV (z
));
2351 x
= SCM_CMETHOD_CODE (z
);
2352 goto nontoplevel_cdrxbegin
;
2357 z
= scm_memoize_method (x
, arg2
);
2361 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2363 t
.arg1
= EVALCAR (x
, env
);
2364 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2366 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2368 t
.arg1
= EVALCAR (x
, env
);
2371 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2372 = SCM_UNPACK (EVALCAR (proc
, env
));
2373 RETURN (SCM_UNSPECIFIED
)
2375 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2377 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2379 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2380 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2382 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2384 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2390 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2393 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2395 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2399 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2401 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2403 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2405 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2407 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2408 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2410 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2412 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2418 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2421 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2423 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2427 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2429 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2433 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2436 t
.arg1
= SCM_CAR (x
);
2437 arg2
= SCM_CDAR (env
);
2438 while (SCM_NIMP (arg2
))
2440 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2441 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2443 SCM_SETCAR (arg2
, proc
);
2444 t
.arg1
= SCM_CDR (t
.arg1
);
2445 arg2
= SCM_CDR (arg2
);
2447 t
.arg1
= SCM_CAR (x
);
2448 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2450 arg2
= x
= SCM_CDR (x
);
2451 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2453 SIDEVAL (SCM_CAR (x
), env
);
2456 proc
= EVALCAR (x
, env
);
2458 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2459 arg2
= SCM_CDAR (env
);
2460 while (SCM_NIMP (arg2
))
2462 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2464 t
.arg1
= SCM_CDR (t
.arg1
);
2465 arg2
= SCM_CDR (arg2
);
2477 /* scm_everr (x, env,...) */
2478 scm_misc_error (NULL
, "Wrong type to apply: ~S", SCM_LIST1 (proc
));
2479 case scm_tc7_vector
:
2483 case scm_tc7_byvect
:
2490 #ifdef HAVE_LONG_LONGS
2491 case scm_tc7_llvect
:
2494 case scm_tc7_string
:
2495 case scm_tc7_substring
:
2497 case scm_tcs_closures
:
2503 #ifdef MEMOIZE_LOCALS
2504 case SCM_BIT8(SCM_ILOC00
):
2505 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2506 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2507 #ifndef SCM_RECKLESS
2513 #endif /* ifdef MEMOIZE_LOCALS */
2516 case scm_tcs_cons_gloc
: {
2517 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2519 /* This is a struct implanted in the code, not a gloc. */
2522 proc
= SCM_PACK (vcell
);
2523 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2524 #ifndef SCM_RECKLESS
2533 case scm_tcs_cons_nimcar
:
2534 if (SCM_SYMBOLP (SCM_CAR (x
)))
2537 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2540 /* we have lost the race, start again. */
2545 proc
= *scm_lookupcar (x
, env
, 1);
2553 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2559 /* Set a flag during macro expansion so that macro
2560 application frames can be deleted from the backtrace. */
2561 SCM_SET_MACROEXP (debug
);
2563 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2564 scm_cons (env
, scm_listofnull
));
2567 SCM_CLEAR_MACROEXP (debug
);
2569 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2572 if (scm_ilength (t
.arg1
) <= 0)
2573 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2575 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2578 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2579 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2583 /* Prevent memoizing of debug info expression. */
2584 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2589 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2590 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2594 if (SCM_NIMP (x
= t
.arg1
))
2602 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2603 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2604 #ifndef SCM_RECKLESS
2608 if (SCM_CLOSUREP (proc
))
2610 arg2
= SCM_CAR (SCM_CODE (proc
));
2611 t
.arg1
= SCM_CDR (x
);
2612 while (SCM_NIMP (arg2
))
2614 if (SCM_NCONSP (arg2
))
2616 if (SCM_IMP (t
.arg1
))
2617 goto umwrongnumargs
;
2618 arg2
= SCM_CDR (arg2
);
2619 t
.arg1
= SCM_CDR (t
.arg1
);
2621 if (SCM_NNULLP (t
.arg1
))
2622 goto umwrongnumargs
;
2624 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2625 goto handle_a_macro
;
2631 PREP_APPLY (proc
, SCM_EOL
);
2632 if (SCM_NULLP (SCM_CDR (x
))) {
2635 switch (SCM_TYP7 (proc
))
2636 { /* no arguments given */
2637 case scm_tc7_subr_0
:
2638 RETURN (SCM_SUBRF (proc
) ());
2639 case scm_tc7_subr_1o
:
2640 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2642 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2643 case scm_tc7_rpsubr
:
2644 RETURN (SCM_BOOL_T
);
2646 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2648 if (!SCM_SMOB_APPLICABLE_P (proc
))
2650 RETURN (SCM_SMOB_APPLY_0 (proc
));
2653 proc
= SCM_CCLO_SUBR (proc
);
2655 debug
.info
->a
.proc
= proc
;
2656 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2660 proc
= SCM_PROCEDURE (proc
);
2662 debug
.info
->a
.proc
= proc
;
2664 if (!SCM_CLOSUREP (proc
))
2666 if (scm_badformalsp (proc
, 0))
2667 goto umwrongnumargs
;
2668 case scm_tcs_closures
:
2669 x
= SCM_CODE (proc
);
2670 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2671 goto nontoplevel_cdrxbegin
;
2672 case scm_tcs_cons_gloc
:
2673 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2675 x
= SCM_ENTITY_PROCEDURE (proc
);
2679 else if (!SCM_I_OPERATORP (proc
))
2684 proc
= (SCM_I_ENTITYP (proc
)
2685 ? SCM_ENTITY_PROCEDURE (proc
)
2686 : SCM_OPERATOR_PROCEDURE (proc
));
2688 debug
.info
->a
.proc
= proc
;
2689 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2691 if (SCM_NIMP (proc
))
2696 case scm_tc7_subr_1
:
2697 case scm_tc7_subr_2
:
2698 case scm_tc7_subr_2o
:
2700 case scm_tc7_subr_3
:
2701 case scm_tc7_lsubr_2
:
2705 /* scm_everr (x, env,...) */
2706 scm_wrong_num_args (proc
);
2708 /* handle macros here */
2713 /* must handle macros by here */
2718 else if (SCM_CONSP (x
))
2720 if (SCM_IMP (SCM_CAR (x
)))
2721 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2723 t
.arg1
= EVALCELLCAR (x
, env
);
2725 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2727 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2729 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2731 t
.arg1
= SCM_PACK (vcell
);
2736 t
.arg1
= EVALCAR (x
, env
);
2739 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2746 switch (SCM_TYP7 (proc
))
2747 { /* have one argument in t.arg1 */
2748 case scm_tc7_subr_2o
:
2749 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2750 case scm_tc7_subr_1
:
2751 case scm_tc7_subr_1o
:
2752 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2754 if (SCM_SUBRF (proc
))
2756 if (SCM_INUMP (t
.arg1
))
2758 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2760 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2761 if (SCM_REALP (t
.arg1
))
2763 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2766 if (SCM_BIGP (t
.arg1
))
2768 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2772 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2773 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2775 proc
= SCM_SNAME (proc
);
2777 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2778 while ('c' != *--chrs
)
2780 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2781 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2782 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2786 case scm_tc7_rpsubr
:
2787 RETURN (SCM_BOOL_T
);
2789 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2792 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2794 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2797 if (!SCM_SMOB_APPLICABLE_P (proc
))
2799 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2803 proc
= SCM_CCLO_SUBR (proc
);
2805 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2806 debug
.info
->a
.proc
= proc
;
2810 proc
= SCM_PROCEDURE (proc
);
2812 debug
.info
->a
.proc
= proc
;
2814 if (!SCM_CLOSUREP (proc
))
2816 if (scm_badformalsp (proc
, 1))
2817 goto umwrongnumargs
;
2818 case scm_tcs_closures
:
2820 x
= SCM_CODE (proc
);
2822 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2824 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2826 goto nontoplevel_cdrxbegin
;
2827 case scm_tcs_cons_gloc
:
2828 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2830 x
= SCM_ENTITY_PROCEDURE (proc
);
2832 arg2
= debug
.info
->a
.args
;
2834 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2838 else if (!SCM_I_OPERATORP (proc
))
2844 proc
= (SCM_I_ENTITYP (proc
)
2845 ? SCM_ENTITY_PROCEDURE (proc
)
2846 : SCM_OPERATOR_PROCEDURE (proc
));
2848 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2849 debug
.info
->a
.proc
= proc
;
2851 if (SCM_NIMP (proc
))
2856 case scm_tc7_subr_2
:
2857 case scm_tc7_subr_0
:
2858 case scm_tc7_subr_3
:
2859 case scm_tc7_lsubr_2
:
2868 else if (SCM_CONSP (x
))
2870 if (SCM_IMP (SCM_CAR (x
)))
2871 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2873 arg2
= EVALCELLCAR (x
, env
);
2875 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2877 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2879 arg2
= SCM_CAR (x
); /* struct planted in code */
2881 arg2
= SCM_PACK (vcell
);
2886 arg2
= EVALCAR (x
, env
);
2888 { /* have two or more arguments */
2890 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2893 if (SCM_NULLP (x
)) {
2896 switch (SCM_TYP7 (proc
))
2897 { /* have two arguments */
2898 case scm_tc7_subr_2
:
2899 case scm_tc7_subr_2o
:
2900 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2903 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2905 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2907 case scm_tc7_lsubr_2
:
2908 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2909 case scm_tc7_rpsubr
:
2911 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2913 if (!SCM_SMOB_APPLICABLE_P (proc
))
2915 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2919 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2920 scm_cons (proc
, debug
.info
->a
.args
),
2923 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2924 scm_cons2 (proc
, t
.arg1
,
2931 case scm_tcs_cons_gloc
:
2932 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2934 x
= SCM_ENTITY_PROCEDURE (proc
);
2936 arg2
= debug
.info
->a
.args
;
2938 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2942 else if (!SCM_I_OPERATORP (proc
))
2948 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2949 ? SCM_ENTITY_PROCEDURE (proc
)
2950 : SCM_OPERATOR_PROCEDURE (proc
),
2951 scm_cons (proc
, debug
.info
->a
.args
),
2954 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2955 ? SCM_ENTITY_PROCEDURE (proc
)
2956 : SCM_OPERATOR_PROCEDURE (proc
),
2957 scm_cons2 (proc
, t
.arg1
,
2965 case scm_tc7_subr_0
:
2967 case scm_tc7_subr_1o
:
2968 case scm_tc7_subr_1
:
2969 case scm_tc7_subr_3
:
2974 proc
= SCM_PROCEDURE (proc
);
2976 debug
.info
->a
.proc
= proc
;
2978 if (!SCM_CLOSUREP (proc
))
2980 if (scm_badformalsp (proc
, 2))
2981 goto umwrongnumargs
;
2982 case scm_tcs_closures
:
2985 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2989 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2990 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2992 x
= SCM_CODE (proc
);
2993 goto nontoplevel_cdrxbegin
;
2997 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3001 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3002 scm_deval_args (x
, env
, proc
,
3003 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3007 switch (SCM_TYP7 (proc
))
3008 { /* have 3 or more arguments */
3010 case scm_tc7_subr_3
:
3011 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3012 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3013 SCM_CADDR (debug
.info
->a
.args
)));
3015 #ifdef BUILTIN_RPASUBR
3016 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3017 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3020 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3021 arg2
= SCM_CDR (arg2
);
3023 while (SCM_NIMP (arg2
));
3025 #endif /* BUILTIN_RPASUBR */
3026 case scm_tc7_rpsubr
:
3027 #ifdef BUILTIN_RPASUBR
3028 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3030 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3033 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3035 arg2
= SCM_CAR (t
.arg1
);
3036 t
.arg1
= SCM_CDR (t
.arg1
);
3038 while (SCM_NIMP (t
.arg1
));
3040 #else /* BUILTIN_RPASUBR */
3041 RETURN (SCM_APPLY (proc
, t
.arg1
,
3043 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3045 #endif /* BUILTIN_RPASUBR */
3046 case scm_tc7_lsubr_2
:
3047 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3048 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3050 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3052 if (!SCM_SMOB_APPLICABLE_P (proc
))
3054 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3055 SCM_CDDR (debug
.info
->a
.args
)));
3059 proc
= SCM_PROCEDURE (proc
);
3060 debug
.info
->a
.proc
= proc
;
3061 if (!SCM_CLOSUREP (proc
))
3063 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3064 goto umwrongnumargs
;
3065 case scm_tcs_closures
:
3066 SCM_SET_ARGSREADY (debug
);
3067 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3070 x
= SCM_CODE (proc
);
3071 goto nontoplevel_cdrxbegin
;
3073 case scm_tc7_subr_3
:
3074 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3075 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3077 #ifdef BUILTIN_RPASUBR
3078 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3081 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3084 while (SCM_NIMP (x
));
3086 #endif /* BUILTIN_RPASUBR */
3087 case scm_tc7_rpsubr
:
3088 #ifdef BUILTIN_RPASUBR
3089 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3093 t
.arg1
= EVALCAR (x
, env
);
3094 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3099 while (SCM_NIMP (x
));
3101 #else /* BUILTIN_RPASUBR */
3102 RETURN (SCM_APPLY (proc
, t
.arg1
,
3104 scm_eval_args (x
, env
, proc
),
3106 #endif /* BUILTIN_RPASUBR */
3107 case scm_tc7_lsubr_2
:
3108 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3110 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3112 scm_eval_args (x
, env
, proc
))));
3114 if (!SCM_SMOB_APPLICABLE_P (proc
))
3116 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3117 scm_eval_args (x
, env
, proc
)));
3121 proc
= SCM_PROCEDURE (proc
);
3122 if (!SCM_CLOSUREP (proc
))
3125 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3126 if (SCM_NULLP (formals
)
3127 || (SCM_CONSP (formals
)
3128 && (SCM_NULLP (SCM_CDR (formals
))
3129 || (SCM_CONSP (SCM_CDR (formals
))
3130 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3131 goto umwrongnumargs
;
3133 case scm_tcs_closures
:
3135 SCM_SET_ARGSREADY (debug
);
3137 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3140 scm_eval_args (x
, env
, proc
)),
3142 x
= SCM_CODE (proc
);
3143 goto nontoplevel_cdrxbegin
;
3145 case scm_tcs_cons_gloc
:
3146 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3149 arg2
= debug
.info
->a
.args
;
3151 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3153 x
= SCM_ENTITY_PROCEDURE (proc
);
3156 else if (!SCM_I_OPERATORP (proc
))
3160 case scm_tc7_subr_2
:
3161 case scm_tc7_subr_1o
:
3162 case scm_tc7_subr_2o
:
3163 case scm_tc7_subr_0
:
3165 case scm_tc7_subr_1
:
3173 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3174 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3176 SCM_CLEAR_TRACED_FRAME (debug
);
3177 if (SCM_CHEAPTRAPS_P
)
3178 t
.arg1
= scm_make_debugobj (&debug
);
3182 SCM val
= scm_make_continuation (&first
);
3192 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3195 scm_last_debug_frame
= debug
.prev
;
3201 /* SECTION: This code is compiled once.
3206 /* This code processes the arguments to apply:
3208 (apply PROC ARG1 ... ARGS)
3210 Given a list (ARG1 ... ARGS), this function conses the ARG1
3211 ... arguments onto the front of ARGS, and returns the resulting
3212 list. Note that ARGS is a list; thus, the argument to this
3213 function is a list whose last element is a list.
3215 Apply calls this function, and applies PROC to the elements of the
3216 result. apply:nconc2last takes care of building the list of
3217 arguments, given (ARG1 ... ARGS).
3219 Rather than do new consing, apply:nconc2last destroys its argument.
3220 On that topic, this code came into my care with the following
3221 beautifully cryptic comment on that topic: "This will only screw
3222 you if you do (scm_apply scm_apply '( ... ))" If you know what
3223 they're referring to, send me a patch to this comment. */
3225 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3227 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3228 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3229 "@var{args}, and returns the resulting list. Note that\n"
3230 "@var{args} is a list; thus, the argument to this function is\n"
3231 "a list whose last element is a list.\n"
3232 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3233 "destroys its argument, so use with care.")
3234 #define FUNC_NAME s_scm_nconc2last
3237 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3239 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3240 lloc
= SCM_CDRLOC (*lloc
);
3241 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3242 *lloc
= SCM_CAR (*lloc
);
3250 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3251 * It is compiled twice.
3257 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3264 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3269 /* Apply a function to a list of arguments.
3271 This function is exported to the Scheme level as taking two
3272 required arguments and a tail argument, as if it were:
3273 (lambda (proc arg1 . args) ...)
3274 Thus, if you just have a list of arguments to pass to a procedure,
3275 pass the list as ARG1, and '() for ARGS. If you have some fixed
3276 args, pass the first as ARG1, then cons any remaining fixed args
3277 onto the front of your argument list, and pass that as ARGS. */
3280 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3282 #ifdef DEBUG_EXTENSIONS
3284 scm_debug_frame debug
;
3285 scm_debug_info debug_vect_body
;
3286 debug
.prev
= scm_last_debug_frame
;
3287 debug
.status
= SCM_APPLYFRAME
;
3288 debug
.vect
= &debug_vect_body
;
3289 debug
.vect
[0].a
.proc
= proc
;
3290 debug
.vect
[0].a
.args
= SCM_EOL
;
3291 scm_last_debug_frame
= &debug
;
3294 return scm_dapply (proc
, arg1
, args
);
3298 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3300 /* If ARGS is the empty list, then we're calling apply with only two
3301 arguments --- ARG1 is the list of arguments for PROC. Whatever
3302 the case, futz with things so that ARG1 is the first argument to
3303 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3306 Setting the debug apply frame args this way is pretty messy.
3307 Perhaps we should store arg1 and args directly in the frame as
3308 received, and let scm_frame_arguments unpack them, because that's
3309 a relatively rare operation. This works for now; if the Guile
3310 developer archives are still around, see Mikael's post of
3312 if (SCM_NULLP (args
))
3314 if (SCM_NULLP (arg1
))
3316 arg1
= SCM_UNDEFINED
;
3318 debug
.vect
[0].a
.args
= SCM_EOL
;
3324 debug
.vect
[0].a
.args
= arg1
;
3326 args
= SCM_CDR (arg1
);
3327 arg1
= SCM_CAR (arg1
);
3332 args
= scm_nconc2last (args
);
3334 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3338 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3341 if (SCM_CHEAPTRAPS_P
)
3342 tmp
= scm_make_debugobj (&debug
);
3347 tmp
= scm_make_continuation (&first
);
3351 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3357 switch (SCM_TYP7 (proc
))
3359 case scm_tc7_subr_2o
:
3360 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3361 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3362 case scm_tc7_subr_2
:
3363 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3365 args
= SCM_CAR (args
);
3366 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3367 case scm_tc7_subr_0
:
3368 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3369 RETURN (SCM_SUBRF (proc
) ())
3370 case scm_tc7_subr_1
:
3371 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3372 case scm_tc7_subr_1o
:
3373 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3374 RETURN (SCM_SUBRF (proc
) (arg1
))
3376 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3377 if (SCM_SUBRF (proc
))
3379 if (SCM_INUMP (arg1
))
3381 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3383 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3384 if (SCM_REALP (arg1
))
3386 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3389 if (SCM_BIGP (arg1
))
3390 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3393 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3394 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3396 proc
= SCM_SNAME (proc
);
3398 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3399 while ('c' != *--chrs
)
3401 SCM_ASSERT (SCM_CONSP (arg1
),
3402 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3403 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3407 case scm_tc7_subr_3
:
3408 SCM_ASRTGO (SCM_NNULLP (args
)
3409 && SCM_NNULLP (SCM_CDR (args
))
3410 && SCM_NULLP (SCM_CDDR (args
)),
3412 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3415 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3417 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3419 case scm_tc7_lsubr_2
:
3420 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3421 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3423 if (SCM_NULLP (args
))
3424 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3425 while (SCM_NIMP (args
))
3427 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3428 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3429 args
= SCM_CDR (args
);
3432 case scm_tc7_rpsubr
:
3433 if (SCM_NULLP (args
))
3434 RETURN (SCM_BOOL_T
);
3435 while (SCM_NIMP (args
))
3437 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3438 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3439 RETURN (SCM_BOOL_F
);
3440 arg1
= SCM_CAR (args
);
3441 args
= SCM_CDR (args
);
3443 RETURN (SCM_BOOL_T
);
3444 case scm_tcs_closures
:
3446 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3448 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3450 #ifndef SCM_RECKLESS
3451 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3455 /* Copy argument list */
3460 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3461 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3463 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3467 SCM_SETCDR (tl
, arg1
);
3470 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3471 proc
= SCM_CDR (SCM_CODE (proc
));
3474 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3476 if (SCM_IMP (SCM_CAR (proc
)))
3478 if (SCM_ISYMP (SCM_CAR (proc
)))
3480 proc
= scm_m_expand_body (proc
, args
);
3484 SCM_EVALIM2 (SCM_CAR (proc
));
3487 SCM_CEVAL (SCM_CAR (proc
), args
);
3490 RETURN (EVALCAR (proc
, args
));
3492 if (!SCM_SMOB_APPLICABLE_P (proc
))
3494 if (SCM_UNBNDP (arg1
))
3495 RETURN (SCM_SMOB_APPLY_0 (proc
))
3496 else if (SCM_NULLP (args
))
3497 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3498 else if (SCM_NULLP (SCM_CDR (args
)))
3499 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3501 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3504 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3506 proc
= SCM_CCLO_SUBR (proc
);
3507 debug
.vect
[0].a
.proc
= proc
;
3508 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3510 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3512 proc
= SCM_CCLO_SUBR (proc
);
3516 proc
= SCM_PROCEDURE (proc
);
3518 debug
.vect
[0].a
.proc
= proc
;
3521 case scm_tcs_cons_gloc
:
3522 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3525 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3527 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3529 RETURN (scm_apply_generic (proc
, args
));
3531 else if (!SCM_I_OPERATORP (proc
))
3536 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3538 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3541 proc
= (SCM_I_ENTITYP (proc
)
3542 ? SCM_ENTITY_PROCEDURE (proc
)
3543 : SCM_OPERATOR_PROCEDURE (proc
));
3545 debug
.vect
[0].a
.proc
= proc
;
3546 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3548 if (SCM_NIMP (proc
))
3554 scm_wrong_num_args (proc
);
3557 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3562 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3563 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3565 SCM_CLEAR_TRACED_FRAME (debug
);
3566 if (SCM_CHEAPTRAPS_P
)
3567 arg1
= scm_make_debugobj (&debug
);
3571 SCM val
= scm_make_continuation (&first
);
3581 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3584 scm_last_debug_frame
= debug
.prev
;
3590 /* SECTION: The rest of this file is only read once.
3595 /* Typechecking for multi-argument MAP and FOR-EACH.
3597 Verify that each element of the vector ARGV, except for the first,
3598 is a proper list whose length is LEN. Attribute errors to WHO,
3599 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3601 check_map_args (SCM argv
,
3608 SCM
*ve
= SCM_VELTS (argv
);
3611 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3613 int elt_len
= scm_ilength (ve
[i
]);
3618 scm_apply_generic (gf
, scm_cons (proc
, args
));
3620 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3624 scm_out_of_range (who
, ve
[i
]);
3627 scm_remember_upto_here_1 (argv
);
3631 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3633 /* Note: Currently, scm_map applies PROC to the argument list(s)
3634 sequentially, starting with the first element(s). This is used in
3635 evalext.c where the Scheme procedure `map-in-order', which guarantees
3636 sequential behaviour, is implemented using scm_map. If the
3637 behaviour changes, we need to update `map-in-order'.
3641 scm_map (SCM proc
, SCM arg1
, SCM args
)
3642 #define FUNC_NAME s_map
3647 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3649 len
= scm_ilength (arg1
);
3650 SCM_GASSERTn (len
>= 0,
3651 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3652 SCM_VALIDATE_REST_ARGUMENT (args
);
3653 if (SCM_NULLP (args
))
3655 while (SCM_NIMP (arg1
))
3657 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3659 pres
= SCM_CDRLOC (*pres
);
3660 arg1
= SCM_CDR (arg1
);
3664 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3665 ve
= SCM_VELTS (args
);
3666 #ifndef SCM_RECKLESS
3667 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3672 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3674 if (SCM_IMP (ve
[i
]))
3676 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3677 ve
[i
] = SCM_CDR (ve
[i
]);
3679 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3680 pres
= SCM_CDRLOC (*pres
);
3686 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3689 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3690 #define FUNC_NAME s_for_each
3692 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3694 len
= scm_ilength (arg1
);
3695 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3696 SCM_ARG2
, s_for_each
);
3697 SCM_VALIDATE_REST_ARGUMENT (args
);
3700 while SCM_NIMP (arg1
)
3702 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3703 arg1
= SCM_CDR (arg1
);
3705 return SCM_UNSPECIFIED
;
3707 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3708 ve
= SCM_VELTS (args
);
3709 #ifndef SCM_RECKLESS
3710 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3715 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3718 (ve
[i
]) return SCM_UNSPECIFIED
;
3719 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3720 ve
[i
] = SCM_CDR (ve
[i
]);
3722 scm_apply (proc
, arg1
, SCM_EOL
);
3729 scm_closure (SCM code
, SCM env
)
3733 SCM_SETCODE (z
, code
);
3734 SCM_SETENV (z
, env
);
3739 scm_bits_t scm_tc16_promise
;
3742 scm_makprom (SCM code
)
3744 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3750 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3752 int writingp
= SCM_WRITINGP (pstate
);
3753 scm_puts ("#<promise ", port
);
3754 SCM_SET_WRITINGP (pstate
, 1);
3755 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3756 SCM_SET_WRITINGP (pstate
, writingp
);
3757 scm_putc ('>', port
);
3762 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3764 "If the promise X has not been computed yet, compute and return\n"
3765 "X, otherwise just return the previously computed value.")
3766 #define FUNC_NAME s_scm_force
3768 SCM_VALIDATE_SMOB (1, x
, promise
);
3769 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3771 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3772 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3775 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3776 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3780 return SCM_CELL_OBJECT_1 (x
);
3785 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3787 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3788 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3789 #define FUNC_NAME s_scm_promise_p
3791 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, x
));
3796 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3797 (SCM xorig
, SCM x
, SCM y
),
3798 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3799 "Any source properties associated with @var{xorig} are also associated\n"
3800 "with the new pair.")
3801 #define FUNC_NAME s_scm_cons_source
3805 SCM_SET_CELL_OBJECT_0 (z
, x
);
3806 SCM_SET_CELL_OBJECT_1 (z
, y
);
3807 /* Copy source properties possibly associated with xorig. */
3808 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3810 scm_whash_insert (scm_source_whash
, z
, p
);
3816 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3818 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3819 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3820 "contents of both pairs and vectors (since both cons cells and vector\n"
3821 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3822 "any other object.")
3823 #define FUNC_NAME s_scm_copy_tree
3828 if (SCM_VECTORP (obj
))
3830 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3831 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3833 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3836 if (SCM_NCONSP (obj
))
3838 ans
= tl
= scm_cons_source (obj
,
3839 scm_copy_tree (SCM_CAR (obj
)),
3841 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3843 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3847 SCM_SETCDR (tl
, obj
);
3853 /* We have three levels of EVAL here:
3855 - scm_i_eval (exp, env)
3857 evaluates EXP in environment ENV. ENV is a lexical environment
3858 structure as used by the actual tree code evaluator. When ENV is
3859 a top-level environment, then changes to the current module are
3860 tracked by modifying ENV so that it continues to be in sync with
3863 - scm_primitive_eval (exp)
3865 evaluates EXP in the top-level environment as determined by the
3866 current module. This is done by constructing a suitable
3867 environment and calling scm_i_eval. Thus, changes to the
3868 top-level module are tracked normally.
3870 - scm_eval (exp, mod)
3872 evaluates EXP while MOD is the current module. Thius is done by
3873 setting the current module to MOD, invoking scm_primitive_eval on
3874 EXP, and then restoring the current module to the value it had
3875 previously. That is, while EXP is evaluated, changes to the
3876 current module are tracked, but these changes do not persist when
3879 For each level of evals, there are two variants, distinguished by a
3880 _x suffix: the ordinary variant does not modify EXP while the _x
3881 variant can destructively modify EXP into something completely
3882 unintelligible. A Scheme data structure passed as EXP to one of the
3883 _x variants should not ever be used again for anything. So when in
3884 doubt, use the ordinary variant.
3888 SCM scm_system_transformer
;
3890 /* XXX - scm_i_eval is meant to be useable for evaluation in
3891 non-toplevel environments, for example when used by the debugger.
3892 Can the system transform deal with this? */
3895 scm_i_eval_x (SCM exp
, SCM env
)
3897 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3898 if (SCM_NIMP (transformer
))
3899 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3900 return SCM_XEVAL (exp
, env
);
3904 scm_i_eval (SCM exp
, SCM env
)
3906 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3907 if (SCM_NIMP (transformer
))
3908 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3909 exp
= scm_copy_tree (exp
);
3910 return SCM_XEVAL (exp
, env
);
3914 scm_primitive_eval_x (SCM exp
)
3916 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3917 return scm_i_eval_x (exp
, env
);
3920 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3922 "Evaluate @var{exp} in the top-level environment specified by\n"
3923 "the current module.")
3924 #define FUNC_NAME s_scm_primitive_eval
3926 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3927 return scm_i_eval (exp
, env
);
3931 /* Eval does not take the second arg optionally. This is intentional
3932 * in order to be R5RS compatible, and to prepare for the new module
3933 * system, where we would like to make the choice of evaluation
3934 * environment explicit. */
3937 change_environment (void *data
)
3939 SCM pair
= SCM_PACK (data
);
3940 SCM new_module
= SCM_CAR (pair
);
3941 SCM old_module
= scm_current_module ();
3942 SCM_SETCDR (pair
, old_module
);
3943 scm_set_current_module (new_module
);
3948 restore_environment (void *data
)
3950 SCM pair
= SCM_PACK (data
);
3951 SCM old_module
= SCM_CDR (pair
);
3952 SCM new_module
= scm_current_module ();
3953 SCM_SETCAR (pair
, new_module
);
3954 scm_set_current_module (old_module
);
3958 inner_eval_x (void *data
)
3960 return scm_primitive_eval_x (SCM_PACK(data
));
3964 scm_eval_x (SCM exp
, SCM module
)
3965 #define FUNC_NAME "eval!"
3967 SCM_VALIDATE_MODULE (2, module
);
3969 return scm_internal_dynamic_wind
3970 (change_environment
, inner_eval_x
, restore_environment
,
3971 (void *) SCM_UNPACK (exp
),
3972 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3977 inner_eval (void *data
)
3979 return scm_primitive_eval (SCM_PACK(data
));
3982 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3983 (SCM exp
, SCM module
),
3984 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3985 "in the top-level environment specified by @var{module}.\n"
3986 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
3987 "@var{module} is made the current module. The current module\n"
3988 "is reset to its previous value when @var{eval} returns.")
3989 #define FUNC_NAME s_scm_eval
3991 SCM_VALIDATE_MODULE (2, module
);
3993 return scm_internal_dynamic_wind
3994 (change_environment
, inner_eval
, restore_environment
,
3995 (void *) SCM_UNPACK (exp
),
3996 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4000 #if (SCM_DEBUG_DEPRECATED == 0)
4002 /* Use scm_current_module () or scm_interaction_environment ()
4003 * instead. The former is the module selected during loading of code.
4004 * The latter is the module in which the user of this thread currently
4005 * types expressions.
4008 SCM scm_top_level_lookup_closure_var
;
4010 /* Avoid using this functionality altogether (except for implementing
4011 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4013 * Applications should use either C level scm_eval_x or Scheme
4014 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4017 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4020 return scm_i_eval (obj
, env
);
4022 return scm_i_eval_x (obj
, env
);
4025 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4026 (SCM obj
, SCM env_thunk
),
4027 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4028 "designated by @var{lookup}, a symbol-lookup function."
4029 "Do not use this version of eval, it does not play well\n"
4030 "with the module system. Use @code{eval} or\n"
4031 "@code{primitive-eval} instead.")
4032 #define FUNC_NAME s_scm_eval2
4034 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4038 #endif /* DEPRECATED */
4041 /* At this point, scm_deval and scm_dapply are generated.
4044 #ifdef DEBUG_EXTENSIONS
4054 scm_init_opts (scm_evaluator_traps
,
4055 scm_evaluator_trap_table
,
4056 SCM_N_EVALUATOR_TRAPS
);
4057 scm_init_opts (scm_eval_options_interface
,
4059 SCM_N_EVAL_OPTIONS
);
4061 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4062 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4063 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4065 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4066 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
4069 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
4070 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
4071 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
4072 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
4073 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
4074 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
4079 #if SCM_DEBUG_DEPRECATED == 0
4080 scm_top_level_lookup_closure_var
=
4081 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
4084 #ifndef SCM_MAGIC_SNARFER
4085 #include "libguile/eval.x"
4088 scm_add_feature ("delay");