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
,
2479 "Wrong type to apply: ~S",
2480 scm_listify (proc
, SCM_UNDEFINED
));
2481 case scm_tc7_vector
:
2485 case scm_tc7_byvect
:
2492 #ifdef HAVE_LONG_LONGS
2493 case scm_tc7_llvect
:
2496 case scm_tc7_string
:
2497 case scm_tc7_substring
:
2499 case scm_tcs_closures
:
2505 #ifdef MEMOIZE_LOCALS
2506 case SCM_BIT8(SCM_ILOC00
):
2507 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2508 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2509 #ifndef SCM_RECKLESS
2515 #endif /* ifdef MEMOIZE_LOCALS */
2518 case scm_tcs_cons_gloc
: {
2519 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2521 /* This is a struct implanted in the code, not a gloc. */
2524 proc
= SCM_PACK (vcell
);
2525 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2526 #ifndef SCM_RECKLESS
2535 case scm_tcs_cons_nimcar
:
2536 if (SCM_SYMBOLP (SCM_CAR (x
)))
2539 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2542 /* we have lost the race, start again. */
2547 proc
= *scm_lookupcar (x
, env
, 1);
2555 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2561 /* Set a flag during macro expansion so that macro
2562 application frames can be deleted from the backtrace. */
2563 SCM_SET_MACROEXP (debug
);
2565 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2566 scm_cons (env
, scm_listofnull
));
2569 SCM_CLEAR_MACROEXP (debug
);
2571 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2574 if (scm_ilength (t
.arg1
) <= 0)
2575 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2577 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2580 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2581 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2585 /* Prevent memoizing of debug info expression. */
2586 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2591 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2592 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2596 if (SCM_NIMP (x
= t
.arg1
))
2604 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2605 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2606 #ifndef SCM_RECKLESS
2610 if (SCM_CLOSUREP (proc
))
2612 arg2
= SCM_CAR (SCM_CODE (proc
));
2613 t
.arg1
= SCM_CDR (x
);
2614 while (SCM_NIMP (arg2
))
2616 if (SCM_NCONSP (arg2
))
2618 if (SCM_IMP (t
.arg1
))
2619 goto umwrongnumargs
;
2620 arg2
= SCM_CDR (arg2
);
2621 t
.arg1
= SCM_CDR (t
.arg1
);
2623 if (SCM_NNULLP (t
.arg1
))
2624 goto umwrongnumargs
;
2626 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2627 goto handle_a_macro
;
2633 PREP_APPLY (proc
, SCM_EOL
);
2634 if (SCM_NULLP (SCM_CDR (x
))) {
2637 switch (SCM_TYP7 (proc
))
2638 { /* no arguments given */
2639 case scm_tc7_subr_0
:
2640 RETURN (SCM_SUBRF (proc
) ());
2641 case scm_tc7_subr_1o
:
2642 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2644 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2645 case scm_tc7_rpsubr
:
2646 RETURN (SCM_BOOL_T
);
2648 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2650 if (!SCM_SMOB_APPLICABLE_P (proc
))
2652 RETURN (SCM_SMOB_APPLY_0 (proc
));
2655 proc
= SCM_CCLO_SUBR (proc
);
2657 debug
.info
->a
.proc
= proc
;
2658 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2662 proc
= SCM_PROCEDURE (proc
);
2664 debug
.info
->a
.proc
= proc
;
2666 if (!SCM_CLOSUREP (proc
))
2668 if (scm_badformalsp (proc
, 0))
2669 goto umwrongnumargs
;
2670 case scm_tcs_closures
:
2671 x
= SCM_CODE (proc
);
2672 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2673 goto nontoplevel_cdrxbegin
;
2674 case scm_tcs_cons_gloc
:
2675 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2677 x
= SCM_ENTITY_PROCEDURE (proc
);
2681 else if (!SCM_I_OPERATORP (proc
))
2686 proc
= (SCM_I_ENTITYP (proc
)
2687 ? SCM_ENTITY_PROCEDURE (proc
)
2688 : SCM_OPERATOR_PROCEDURE (proc
));
2690 debug
.info
->a
.proc
= proc
;
2691 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2693 if (SCM_NIMP (proc
))
2698 case scm_tc7_subr_1
:
2699 case scm_tc7_subr_2
:
2700 case scm_tc7_subr_2o
:
2702 case scm_tc7_subr_3
:
2703 case scm_tc7_lsubr_2
:
2707 /* scm_everr (x, env,...) */
2708 scm_wrong_num_args (proc
);
2710 /* handle macros here */
2715 /* must handle macros by here */
2720 else if (SCM_CONSP (x
))
2722 if (SCM_IMP (SCM_CAR (x
)))
2723 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2725 t
.arg1
= EVALCELLCAR (x
, env
);
2727 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2729 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2731 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2733 t
.arg1
= SCM_PACK (vcell
);
2738 t
.arg1
= EVALCAR (x
, env
);
2741 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2748 switch (SCM_TYP7 (proc
))
2749 { /* have one argument in t.arg1 */
2750 case scm_tc7_subr_2o
:
2751 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2752 case scm_tc7_subr_1
:
2753 case scm_tc7_subr_1o
:
2754 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2756 if (SCM_SUBRF (proc
))
2758 if (SCM_INUMP (t
.arg1
))
2760 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2762 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2763 if (SCM_REALP (t
.arg1
))
2765 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2768 if (SCM_BIGP (t
.arg1
))
2770 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2774 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2775 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2777 proc
= SCM_SNAME (proc
);
2779 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2780 while ('c' != *--chrs
)
2782 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2783 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2784 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2788 case scm_tc7_rpsubr
:
2789 RETURN (SCM_BOOL_T
);
2791 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2794 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2796 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2799 if (!SCM_SMOB_APPLICABLE_P (proc
))
2801 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2805 proc
= SCM_CCLO_SUBR (proc
);
2807 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2808 debug
.info
->a
.proc
= proc
;
2812 proc
= SCM_PROCEDURE (proc
);
2814 debug
.info
->a
.proc
= proc
;
2816 if (!SCM_CLOSUREP (proc
))
2818 if (scm_badformalsp (proc
, 1))
2819 goto umwrongnumargs
;
2820 case scm_tcs_closures
:
2822 x
= SCM_CODE (proc
);
2824 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2826 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2828 goto nontoplevel_cdrxbegin
;
2829 case scm_tcs_cons_gloc
:
2830 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2832 x
= SCM_ENTITY_PROCEDURE (proc
);
2834 arg2
= debug
.info
->a
.args
;
2836 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2840 else if (!SCM_I_OPERATORP (proc
))
2846 proc
= (SCM_I_ENTITYP (proc
)
2847 ? SCM_ENTITY_PROCEDURE (proc
)
2848 : SCM_OPERATOR_PROCEDURE (proc
));
2850 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2851 debug
.info
->a
.proc
= proc
;
2853 if (SCM_NIMP (proc
))
2858 case scm_tc7_subr_2
:
2859 case scm_tc7_subr_0
:
2860 case scm_tc7_subr_3
:
2861 case scm_tc7_lsubr_2
:
2870 else if (SCM_CONSP (x
))
2872 if (SCM_IMP (SCM_CAR (x
)))
2873 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2875 arg2
= EVALCELLCAR (x
, env
);
2877 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2879 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2881 arg2
= SCM_CAR (x
); /* struct planted in code */
2883 arg2
= SCM_PACK (vcell
);
2888 arg2
= EVALCAR (x
, env
);
2890 { /* have two or more arguments */
2892 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2895 if (SCM_NULLP (x
)) {
2898 switch (SCM_TYP7 (proc
))
2899 { /* have two arguments */
2900 case scm_tc7_subr_2
:
2901 case scm_tc7_subr_2o
:
2902 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2905 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2907 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2909 case scm_tc7_lsubr_2
:
2910 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2911 case scm_tc7_rpsubr
:
2913 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2915 if (!SCM_SMOB_APPLICABLE_P (proc
))
2917 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2921 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2922 scm_cons (proc
, debug
.info
->a
.args
),
2925 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2926 scm_cons2 (proc
, t
.arg1
,
2933 case scm_tcs_cons_gloc
:
2934 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2936 x
= SCM_ENTITY_PROCEDURE (proc
);
2938 arg2
= debug
.info
->a
.args
;
2940 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2944 else if (!SCM_I_OPERATORP (proc
))
2950 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2951 ? SCM_ENTITY_PROCEDURE (proc
)
2952 : SCM_OPERATOR_PROCEDURE (proc
),
2953 scm_cons (proc
, debug
.info
->a
.args
),
2956 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2957 ? SCM_ENTITY_PROCEDURE (proc
)
2958 : SCM_OPERATOR_PROCEDURE (proc
),
2959 scm_cons2 (proc
, t
.arg1
,
2967 case scm_tc7_subr_0
:
2969 case scm_tc7_subr_1o
:
2970 case scm_tc7_subr_1
:
2971 case scm_tc7_subr_3
:
2976 proc
= SCM_PROCEDURE (proc
);
2978 debug
.info
->a
.proc
= proc
;
2980 if (!SCM_CLOSUREP (proc
))
2982 if (scm_badformalsp (proc
, 2))
2983 goto umwrongnumargs
;
2984 case scm_tcs_closures
:
2987 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2991 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2992 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2994 x
= SCM_CODE (proc
);
2995 goto nontoplevel_cdrxbegin
;
2999 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3003 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3004 scm_deval_args (x
, env
, proc
,
3005 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3009 switch (SCM_TYP7 (proc
))
3010 { /* have 3 or more arguments */
3012 case scm_tc7_subr_3
:
3013 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3014 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3015 SCM_CADDR (debug
.info
->a
.args
)));
3017 #ifdef BUILTIN_RPASUBR
3018 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3019 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3022 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3023 arg2
= SCM_CDR (arg2
);
3025 while (SCM_NIMP (arg2
));
3027 #endif /* BUILTIN_RPASUBR */
3028 case scm_tc7_rpsubr
:
3029 #ifdef BUILTIN_RPASUBR
3030 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3032 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3035 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3037 arg2
= SCM_CAR (t
.arg1
);
3038 t
.arg1
= SCM_CDR (t
.arg1
);
3040 while (SCM_NIMP (t
.arg1
));
3042 #else /* BUILTIN_RPASUBR */
3043 RETURN (SCM_APPLY (proc
, t
.arg1
,
3045 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3047 #endif /* BUILTIN_RPASUBR */
3048 case scm_tc7_lsubr_2
:
3049 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3050 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3052 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3054 if (!SCM_SMOB_APPLICABLE_P (proc
))
3056 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3057 SCM_CDDR (debug
.info
->a
.args
)));
3061 proc
= SCM_PROCEDURE (proc
);
3062 debug
.info
->a
.proc
= proc
;
3063 if (!SCM_CLOSUREP (proc
))
3065 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3066 goto umwrongnumargs
;
3067 case scm_tcs_closures
:
3068 SCM_SET_ARGSREADY (debug
);
3069 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3072 x
= SCM_CODE (proc
);
3073 goto nontoplevel_cdrxbegin
;
3075 case scm_tc7_subr_3
:
3076 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3077 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3079 #ifdef BUILTIN_RPASUBR
3080 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3083 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3086 while (SCM_NIMP (x
));
3088 #endif /* BUILTIN_RPASUBR */
3089 case scm_tc7_rpsubr
:
3090 #ifdef BUILTIN_RPASUBR
3091 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3095 t
.arg1
= EVALCAR (x
, env
);
3096 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3101 while (SCM_NIMP (x
));
3103 #else /* BUILTIN_RPASUBR */
3104 RETURN (SCM_APPLY (proc
, t
.arg1
,
3106 scm_eval_args (x
, env
, proc
),
3108 #endif /* BUILTIN_RPASUBR */
3109 case scm_tc7_lsubr_2
:
3110 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3112 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3114 scm_eval_args (x
, env
, proc
))));
3116 if (!SCM_SMOB_APPLICABLE_P (proc
))
3118 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3119 scm_eval_args (x
, env
, proc
)));
3123 proc
= SCM_PROCEDURE (proc
);
3124 if (!SCM_CLOSUREP (proc
))
3127 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3128 if (SCM_NULLP (formals
)
3129 || (SCM_CONSP (formals
)
3130 && (SCM_NULLP (SCM_CDR (formals
))
3131 || (SCM_CONSP (SCM_CDR (formals
))
3132 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3133 goto umwrongnumargs
;
3135 case scm_tcs_closures
:
3137 SCM_SET_ARGSREADY (debug
);
3139 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3142 scm_eval_args (x
, env
, proc
)),
3144 x
= SCM_CODE (proc
);
3145 goto nontoplevel_cdrxbegin
;
3147 case scm_tcs_cons_gloc
:
3148 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3151 arg2
= debug
.info
->a
.args
;
3153 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3155 x
= SCM_ENTITY_PROCEDURE (proc
);
3158 else if (!SCM_I_OPERATORP (proc
))
3162 case scm_tc7_subr_2
:
3163 case scm_tc7_subr_1o
:
3164 case scm_tc7_subr_2o
:
3165 case scm_tc7_subr_0
:
3167 case scm_tc7_subr_1
:
3175 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3176 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3178 SCM_CLEAR_TRACED_FRAME (debug
);
3179 if (SCM_CHEAPTRAPS_P
)
3180 t
.arg1
= scm_make_debugobj (&debug
);
3184 SCM val
= scm_make_continuation (&first
);
3194 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3197 scm_last_debug_frame
= debug
.prev
;
3203 /* SECTION: This code is compiled once.
3208 /* This code processes the arguments to apply:
3210 (apply PROC ARG1 ... ARGS)
3212 Given a list (ARG1 ... ARGS), this function conses the ARG1
3213 ... arguments onto the front of ARGS, and returns the resulting
3214 list. Note that ARGS is a list; thus, the argument to this
3215 function is a list whose last element is a list.
3217 Apply calls this function, and applies PROC to the elements of the
3218 result. apply:nconc2last takes care of building the list of
3219 arguments, given (ARG1 ... ARGS).
3221 Rather than do new consing, apply:nconc2last destroys its argument.
3222 On that topic, this code came into my care with the following
3223 beautifully cryptic comment on that topic: "This will only screw
3224 you if you do (scm_apply scm_apply '( ... ))" If you know what
3225 they're referring to, send me a patch to this comment. */
3227 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3229 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3230 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3231 "@var{args}, and returns the resulting list. Note that\n"
3232 "@var{args} is a list; thus, the argument to this function is\n"
3233 "a list whose last element is a list.\n"
3234 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3235 "destroys its argument, so use with care.")
3236 #define FUNC_NAME s_scm_nconc2last
3239 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3241 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3242 lloc
= SCM_CDRLOC (*lloc
);
3243 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3244 *lloc
= SCM_CAR (*lloc
);
3252 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3253 * It is compiled twice.
3259 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3266 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3271 /* Apply a function to a list of arguments.
3273 This function is exported to the Scheme level as taking two
3274 required arguments and a tail argument, as if it were:
3275 (lambda (proc arg1 . args) ...)
3276 Thus, if you just have a list of arguments to pass to a procedure,
3277 pass the list as ARG1, and '() for ARGS. If you have some fixed
3278 args, pass the first as ARG1, then cons any remaining fixed args
3279 onto the front of your argument list, and pass that as ARGS. */
3282 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3284 #ifdef DEBUG_EXTENSIONS
3286 scm_debug_frame debug
;
3287 scm_debug_info debug_vect_body
;
3288 debug
.prev
= scm_last_debug_frame
;
3289 debug
.status
= SCM_APPLYFRAME
;
3290 debug
.vect
= &debug_vect_body
;
3291 debug
.vect
[0].a
.proc
= proc
;
3292 debug
.vect
[0].a
.args
= SCM_EOL
;
3293 scm_last_debug_frame
= &debug
;
3296 return scm_dapply (proc
, arg1
, args
);
3300 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3302 /* If ARGS is the empty list, then we're calling apply with only two
3303 arguments --- ARG1 is the list of arguments for PROC. Whatever
3304 the case, futz with things so that ARG1 is the first argument to
3305 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3308 Setting the debug apply frame args this way is pretty messy.
3309 Perhaps we should store arg1 and args directly in the frame as
3310 received, and let scm_frame_arguments unpack them, because that's
3311 a relatively rare operation. This works for now; if the Guile
3312 developer archives are still around, see Mikael's post of
3314 if (SCM_NULLP (args
))
3316 if (SCM_NULLP (arg1
))
3318 arg1
= SCM_UNDEFINED
;
3320 debug
.vect
[0].a
.args
= SCM_EOL
;
3326 debug
.vect
[0].a
.args
= arg1
;
3328 args
= SCM_CDR (arg1
);
3329 arg1
= SCM_CAR (arg1
);
3334 args
= scm_nconc2last (args
);
3336 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3340 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3343 if (SCM_CHEAPTRAPS_P
)
3344 tmp
= scm_make_debugobj (&debug
);
3349 tmp
= scm_make_continuation (&first
);
3353 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3359 switch (SCM_TYP7 (proc
))
3361 case scm_tc7_subr_2o
:
3362 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3363 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3364 case scm_tc7_subr_2
:
3365 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3367 args
= SCM_CAR (args
);
3368 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3369 case scm_tc7_subr_0
:
3370 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3371 RETURN (SCM_SUBRF (proc
) ())
3372 case scm_tc7_subr_1
:
3373 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3374 case scm_tc7_subr_1o
:
3375 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3376 RETURN (SCM_SUBRF (proc
) (arg1
))
3378 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3379 if (SCM_SUBRF (proc
))
3381 if (SCM_INUMP (arg1
))
3383 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3385 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3386 if (SCM_REALP (arg1
))
3388 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3391 if (SCM_BIGP (arg1
))
3392 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3395 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3396 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3398 proc
= SCM_SNAME (proc
);
3400 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3401 while ('c' != *--chrs
)
3403 SCM_ASSERT (SCM_CONSP (arg1
),
3404 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3405 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3409 case scm_tc7_subr_3
:
3410 SCM_ASRTGO (SCM_NNULLP (args
)
3411 && SCM_NNULLP (SCM_CDR (args
))
3412 && SCM_NULLP (SCM_CDDR (args
)),
3414 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3417 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3419 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3421 case scm_tc7_lsubr_2
:
3422 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3423 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3425 if (SCM_NULLP (args
))
3426 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3427 while (SCM_NIMP (args
))
3429 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3430 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3431 args
= SCM_CDR (args
);
3434 case scm_tc7_rpsubr
:
3435 if (SCM_NULLP (args
))
3436 RETURN (SCM_BOOL_T
);
3437 while (SCM_NIMP (args
))
3439 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3440 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3441 RETURN (SCM_BOOL_F
);
3442 arg1
= SCM_CAR (args
);
3443 args
= SCM_CDR (args
);
3445 RETURN (SCM_BOOL_T
);
3446 case scm_tcs_closures
:
3448 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3450 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3452 #ifndef SCM_RECKLESS
3453 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3457 /* Copy argument list */
3462 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3463 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3465 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3469 SCM_SETCDR (tl
, arg1
);
3472 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3473 proc
= SCM_CDR (SCM_CODE (proc
));
3476 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3478 if (SCM_IMP (SCM_CAR (proc
)))
3480 if (SCM_ISYMP (SCM_CAR (proc
)))
3482 proc
= scm_m_expand_body (proc
, args
);
3486 SCM_EVALIM2 (SCM_CAR (proc
));
3489 SCM_CEVAL (SCM_CAR (proc
), args
);
3492 RETURN (EVALCAR (proc
, args
));
3494 if (!SCM_SMOB_APPLICABLE_P (proc
))
3496 if (SCM_UNBNDP (arg1
))
3497 RETURN (SCM_SMOB_APPLY_0 (proc
))
3498 else if (SCM_NULLP (args
))
3499 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3500 else if (SCM_NULLP (SCM_CDR (args
)))
3501 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3503 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3506 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3508 proc
= SCM_CCLO_SUBR (proc
);
3509 debug
.vect
[0].a
.proc
= proc
;
3510 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3512 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3514 proc
= SCM_CCLO_SUBR (proc
);
3518 proc
= SCM_PROCEDURE (proc
);
3520 debug
.vect
[0].a
.proc
= proc
;
3523 case scm_tcs_cons_gloc
:
3524 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3527 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3529 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3531 RETURN (scm_apply_generic (proc
, args
));
3533 else if (!SCM_I_OPERATORP (proc
))
3538 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3540 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3543 proc
= (SCM_I_ENTITYP (proc
)
3544 ? SCM_ENTITY_PROCEDURE (proc
)
3545 : SCM_OPERATOR_PROCEDURE (proc
));
3547 debug
.vect
[0].a
.proc
= proc
;
3548 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3550 if (SCM_NIMP (proc
))
3556 scm_wrong_num_args (proc
);
3559 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3564 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3565 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3567 SCM_CLEAR_TRACED_FRAME (debug
);
3568 if (SCM_CHEAPTRAPS_P
)
3569 arg1
= scm_make_debugobj (&debug
);
3573 SCM val
= scm_make_continuation (&first
);
3583 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3586 scm_last_debug_frame
= debug
.prev
;
3592 /* SECTION: The rest of this file is only read once.
3597 /* Typechecking for multi-argument MAP and FOR-EACH.
3599 Verify that each element of the vector ARGV, except for the first,
3600 is a proper list whose length is LEN. Attribute errors to WHO,
3601 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3603 check_map_args (SCM argv
,
3610 SCM
*ve
= SCM_VELTS (argv
);
3613 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3615 int elt_len
= scm_ilength (ve
[i
]);
3620 scm_apply_generic (gf
, scm_cons (proc
, args
));
3622 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3626 scm_out_of_range (who
, ve
[i
]);
3629 scm_remember_upto_here_1 (argv
);
3633 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3635 /* Note: Currently, scm_map applies PROC to the argument list(s)
3636 sequentially, starting with the first element(s). This is used in
3637 evalext.c where the Scheme procedure `map-in-order', which guarantees
3638 sequential behaviour, is implemented using scm_map. If the
3639 behaviour changes, we need to update `map-in-order'.
3643 scm_map (SCM proc
, SCM arg1
, SCM args
)
3644 #define FUNC_NAME s_map
3649 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3651 len
= scm_ilength (arg1
);
3652 SCM_GASSERTn (len
>= 0,
3653 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3654 SCM_VALIDATE_REST_ARGUMENT (args
);
3655 if (SCM_NULLP (args
))
3657 while (SCM_NIMP (arg1
))
3659 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3661 pres
= SCM_CDRLOC (*pres
);
3662 arg1
= SCM_CDR (arg1
);
3666 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3667 ve
= SCM_VELTS (args
);
3668 #ifndef SCM_RECKLESS
3669 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3674 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3676 if (SCM_IMP (ve
[i
]))
3678 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3679 ve
[i
] = SCM_CDR (ve
[i
]);
3681 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3682 pres
= SCM_CDRLOC (*pres
);
3688 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3691 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3692 #define FUNC_NAME s_for_each
3694 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3696 len
= scm_ilength (arg1
);
3697 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3698 SCM_ARG2
, s_for_each
);
3699 SCM_VALIDATE_REST_ARGUMENT (args
);
3702 while SCM_NIMP (arg1
)
3704 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3705 arg1
= SCM_CDR (arg1
);
3707 return SCM_UNSPECIFIED
;
3709 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3710 ve
= SCM_VELTS (args
);
3711 #ifndef SCM_RECKLESS
3712 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3717 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3720 (ve
[i
]) return SCM_UNSPECIFIED
;
3721 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3722 ve
[i
] = SCM_CDR (ve
[i
]);
3724 scm_apply (proc
, arg1
, SCM_EOL
);
3731 scm_closure (SCM code
, SCM env
)
3735 SCM_SETCODE (z
, code
);
3736 SCM_SETENV (z
, env
);
3741 scm_bits_t scm_tc16_promise
;
3744 scm_makprom (SCM code
)
3746 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3752 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3754 int writingp
= SCM_WRITINGP (pstate
);
3755 scm_puts ("#<promise ", port
);
3756 SCM_SET_WRITINGP (pstate
, 1);
3757 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3758 SCM_SET_WRITINGP (pstate
, writingp
);
3759 scm_putc ('>', port
);
3764 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3766 "If the promise X has not been computed yet, compute and return\n"
3767 "X, otherwise just return the previously computed value.")
3768 #define FUNC_NAME s_scm_force
3770 SCM_VALIDATE_SMOB (1, x
, promise
);
3771 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3773 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3774 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3777 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3778 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3782 return SCM_CELL_OBJECT_1 (x
);
3787 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3789 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3790 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3791 #define FUNC_NAME s_scm_promise_p
3793 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, x
));
3798 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3799 (SCM xorig
, SCM x
, SCM y
),
3800 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3801 "Any source properties associated with @var{xorig} are also associated\n"
3802 "with the new pair.")
3803 #define FUNC_NAME s_scm_cons_source
3807 SCM_SET_CELL_OBJECT_0 (z
, x
);
3808 SCM_SET_CELL_OBJECT_1 (z
, y
);
3809 /* Copy source properties possibly associated with xorig. */
3810 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3812 scm_whash_insert (scm_source_whash
, z
, p
);
3818 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3820 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3821 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3822 "contents of both pairs and vectors (since both cons cells and vector\n"
3823 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3824 "any other object.")
3825 #define FUNC_NAME s_scm_copy_tree
3830 if (SCM_VECTORP (obj
))
3832 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3833 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3835 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3838 if (SCM_NCONSP (obj
))
3840 ans
= tl
= scm_cons_source (obj
,
3841 scm_copy_tree (SCM_CAR (obj
)),
3843 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3845 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3849 SCM_SETCDR (tl
, obj
);
3855 /* We have three levels of EVAL here:
3857 - scm_i_eval (exp, env)
3859 evaluates EXP in environment ENV. ENV is a lexical environment
3860 structure as used by the actual tree code evaluator. When ENV is
3861 a top-level environment, then changes to the current module are
3862 tracked by modifying ENV so that it continues to be in sync with
3865 - scm_primitive_eval (exp)
3867 evaluates EXP in the top-level environment as determined by the
3868 current module. This is done by constructing a suitable
3869 environment and calling scm_i_eval. Thus, changes to the
3870 top-level module are tracked normally.
3872 - scm_eval (exp, mod)
3874 evaluates EXP while MOD is the current module. Thius is done by
3875 setting the current module to MOD, invoking scm_primitive_eval on
3876 EXP, and then restoring the current module to the value it had
3877 previously. That is, while EXP is evaluated, changes to the
3878 current module are tracked, but these changes do not persist when
3881 For each level of evals, there are two variants, distinguished by a
3882 _x suffix: the ordinary variant does not modify EXP while the _x
3883 variant can destructively modify EXP into something completely
3884 unintelligible. A Scheme data structure passed as EXP to one of the
3885 _x variants should not ever be used again for anything. So when in
3886 doubt, use the ordinary variant.
3890 SCM scm_system_transformer
;
3892 /* XXX - scm_i_eval is meant to be useable for evaluation in
3893 non-toplevel environments, for example when used by the debugger.
3894 Can the system transform deal with this? */
3897 scm_i_eval_x (SCM exp
, SCM env
)
3899 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3900 if (SCM_NIMP (transformer
))
3901 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3902 return SCM_XEVAL (exp
, env
);
3906 scm_i_eval (SCM exp
, SCM env
)
3908 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3909 if (SCM_NIMP (transformer
))
3910 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3911 exp
= scm_copy_tree (exp
);
3912 return SCM_XEVAL (exp
, env
);
3916 scm_primitive_eval_x (SCM exp
)
3918 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3919 return scm_i_eval_x (exp
, env
);
3922 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3924 "Evaluate @var{exp} in the top-level environment specified by\n"
3925 "the current module.")
3926 #define FUNC_NAME s_scm_primitive_eval
3928 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3929 return scm_i_eval (exp
, env
);
3933 /* Eval does not take the second arg optionally. This is intentional
3934 * in order to be R5RS compatible, and to prepare for the new module
3935 * system, where we would like to make the choice of evaluation
3936 * environment explicit. */
3939 change_environment (void *data
)
3941 SCM pair
= SCM_PACK (data
);
3942 SCM new_module
= SCM_CAR (pair
);
3943 SCM old_module
= scm_current_module ();
3944 SCM_SETCDR (pair
, old_module
);
3945 scm_set_current_module (new_module
);
3950 restore_environment (void *data
)
3952 SCM pair
= SCM_PACK (data
);
3953 SCM old_module
= SCM_CDR (pair
);
3954 SCM new_module
= scm_current_module ();
3955 SCM_SETCAR (pair
, new_module
);
3956 scm_set_current_module (old_module
);
3960 inner_eval_x (void *data
)
3962 return scm_primitive_eval_x (SCM_PACK(data
));
3966 scm_eval_x (SCM exp
, SCM module
)
3967 #define FUNC_NAME "eval!"
3969 SCM_VALIDATE_MODULE (2, module
);
3971 return scm_internal_dynamic_wind
3972 (change_environment
, inner_eval_x
, restore_environment
,
3973 (void *) SCM_UNPACK (exp
),
3974 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3979 inner_eval (void *data
)
3981 return scm_primitive_eval (SCM_PACK(data
));
3984 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3985 (SCM exp
, SCM module
),
3986 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3987 "in the top-level environment specified by @var{module}.\n"
3988 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
3989 "@var{module} is made the current module. The current module\n"
3990 "is reset to its previous value when @var{eval} returns.")
3991 #define FUNC_NAME s_scm_eval
3993 SCM_VALIDATE_MODULE (2, module
);
3995 return scm_internal_dynamic_wind
3996 (change_environment
, inner_eval
, restore_environment
,
3997 (void *) SCM_UNPACK (exp
),
3998 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4002 #if (SCM_DEBUG_DEPRECATED == 0)
4004 /* Use scm_current_module () or scm_interaction_environment ()
4005 * instead. The former is the module selected during loading of code.
4006 * The latter is the module in which the user of this thread currently
4007 * types expressions.
4010 SCM scm_top_level_lookup_closure_var
;
4012 /* Avoid using this functionality altogether (except for implementing
4013 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4015 * Applications should use either C level scm_eval_x or Scheme
4016 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4019 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4022 return scm_i_eval (obj
, env
);
4024 return scm_i_eval_x (obj
, env
);
4027 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4028 (SCM obj
, SCM env_thunk
),
4029 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4030 "designated by @var{lookup}, a symbol-lookup function."
4031 "Do not use this version of eval, it does not play well\n"
4032 "with the module system. Use @code{eval} or\n"
4033 "@code{primitive-eval} instead.")
4034 #define FUNC_NAME s_scm_eval2
4036 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4040 #endif /* DEPRECATED */
4043 /* At this point, scm_deval and scm_dapply are generated.
4046 #ifdef DEBUG_EXTENSIONS
4056 scm_init_opts (scm_evaluator_traps
,
4057 scm_evaluator_trap_table
,
4058 SCM_N_EVALUATOR_TRAPS
);
4059 scm_init_opts (scm_eval_options_interface
,
4061 SCM_N_EVAL_OPTIONS
);
4063 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4064 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4065 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4067 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4068 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
4071 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
4072 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
4073 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
4074 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
4075 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
4076 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
4081 #if SCM_DEBUG_DEPRECATED == 0
4082 scm_top_level_lookup_closure_var
=
4083 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
4086 #ifndef SCM_MAGIC_SNARFER
4087 #include "libguile/eval.x"
4090 scm_add_feature ("delay");