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 */
82 #include "libguile/_scm.h"
83 #include "libguile/debug.h"
84 #include "libguile/dynwind.h"
85 #include "libguile/alist.h"
86 #include "libguile/eq.h"
87 #include "libguile/continuations.h"
88 #include "libguile/throw.h"
89 #include "libguile/smob.h"
90 #include "libguile/macros.h"
91 #include "libguile/procprop.h"
92 #include "libguile/hashtab.h"
93 #include "libguile/hash.h"
94 #include "libguile/srcprop.h"
95 #include "libguile/stackchk.h"
96 #include "libguile/objects.h"
97 #include "libguile/async.h"
98 #include "libguile/feature.h"
99 #include "libguile/modules.h"
100 #include "libguile/ports.h"
101 #include "libguile/root.h"
102 #include "libguile/vectors.h"
103 #include "libguile/fluids.h"
105 #include "libguile/validate.h"
106 #include "libguile/eval.h"
110 /* The evaluator contains a plethora of EVAL symbols.
111 * This is an attempt at explanation.
113 * The following macros should be used in code which is read twice
114 * (where the choice of evaluator is hard soldered):
116 * SCM_CEVAL is the symbol used within one evaluator to call itself.
117 * Originally, it is defined to scm_ceval, but is redefined to
118 * scm_deval during the second pass.
120 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
121 * only side effects of expressions matter. All immediates are
124 * SCM_EVALIM is used when it is known that the expression is an
125 * immediate. (This macro never calls an evaluator.)
127 * EVALCAR evaluates the car of an expression.
129 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
130 * car is a lisp cell.
132 * The following macros should be used in code which is read once
133 * (where the choice of evaluator is dynamic):
135 * SCM_XEVAL takes care of immediates without calling an evaluator. It
136 * then calls scm_ceval *or* scm_deval, depending on the debugging
139 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
140 * depending on the debugging mode.
142 * The main motivation for keeping this plethora is efficiency
143 * together with maintainability (=> locality of code).
146 #define SCM_CEVAL scm_ceval
147 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
149 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env))
153 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
154 ? (SCM_IMP (SCM_CAR (x)) \
155 ? SCM_EVALIM (SCM_CAR (x), env) \
156 : SCM_GLOC_VAL (SCM_CAR (x))) \
157 : EVALCELLCAR (x, env))
159 #define EXTEND_ENV SCM_EXTEND_ENV
161 #ifdef MEMOIZE_LOCALS
164 scm_ilookup (SCM iloc
, SCM env
)
166 register int ir
= SCM_IFRAME (iloc
);
167 register SCM er
= env
;
168 for (; 0 != ir
; --ir
)
171 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
173 if (SCM_ICDRP (iloc
))
174 return SCM_CDRLOC (er
);
175 return SCM_CARLOC (SCM_CDR (er
));
181 /* The Lookup Car Race
184 Memoization of variables and special forms is done while executing
185 the code for the first time. As long as there is only one thread
186 everything is fine, but as soon as two threads execute the same
187 code concurrently `for the first time' they can come into conflict.
189 This memoization includes rewriting variable references into more
190 efficient forms and expanding macros. Furthermore, macro expansion
191 includes `compiling' special forms like `let', `cond', etc. into
192 tree-code instructions.
194 There shouldn't normally be a problem with memoizing local and
195 global variable references (into ilocs and glocs), because all
196 threads will mutate the code in *exactly* the same way and (if I
197 read the C code correctly) it is not possible to observe a half-way
198 mutated cons cell. The lookup procedure can handle this
199 transparently without any critical sections.
201 It is different with macro expansion, because macro expansion
202 happens outside of the lookup procedure and can't be
203 undone. Therefore it can't cope with it. It has to indicate
204 failure when it detects a lost race and hope that the caller can
205 handle it. Luckily, it turns out that this is the case.
207 An example to illustrate this: Suppose that the follwing form will
208 be memoized concurrently by two threads
212 Let's first examine the lookup of X in the body. The first thread
213 decides that it has to find the symbol "x" in the environment and
214 starts to scan it. Then the other thread takes over and actually
215 overtakes the first. It looks up "x" and substitutes an
216 appropriate iloc for it. Now the first thread continues and
217 completes its lookup. It comes to exactly the same conclusions as
218 the second one and could - without much ado - just overwrite the
219 iloc with the same iloc.
221 But let's see what will happen when the race occurs while looking
222 up the symbol "let" at the start of the form. It could happen that
223 the second thread interrupts the lookup of the first thread and not
224 only substitutes a gloc for it but goes right ahead and replaces it
225 with the compiled form (#@let* (x 12) x). Now, when the first
226 thread completes its lookup, it would replace the #@let* with a
227 gloc pointing to the "let" binding, effectively reverting the form
228 to (let (x 12) x). This is wrong. It has to detect that it has
229 lost the race and the evaluator has to reconsider the changed form
232 This race condition could be resolved with some kind of traffic
233 light (like mutexes) around scm_lookupcar, but I think that it is
234 best to avoid them in this case. They would serialize memoization
235 completely and because lookup involves calling arbitrary Scheme
236 code (via the lookup-thunk), threads could be blocked for an
237 arbitrary amount of time or even deadlock. But with the current
238 solution a lot of unnecessary work is potentially done. */
240 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
241 return NULL to indicate a failed lookup due to some race conditions
242 between threads. This only happens when VLOC is the first cell of
243 a special form that will eventually be memoized (like `let', etc.)
244 In that case the whole lookup is bogus and the caller has to
245 reconsider the complete special form.
247 SCM_LOOKUPCAR is still there, of course. It just calls
248 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
249 should only be called when it is known that VLOC is not the first
250 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
251 for NULL. I think I've found the only places where this
254 #endif /* USE_THREADS */
256 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
260 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
263 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
267 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
269 register SCM var2
= var
;
271 #ifdef MEMOIZE_LOCALS
272 register SCM iloc
= SCM_ILOC00
;
274 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
276 if (!SCM_CONSP (SCM_CAR (env
)))
278 al
= SCM_CARLOC (env
);
279 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
283 if (SCM_EQ_P (fl
, var
))
285 #ifdef MEMOIZE_LOCALS
287 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
290 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
292 return SCM_CDRLOC (*al
);
297 al
= SCM_CDRLOC (*al
);
298 if (SCM_EQ_P (SCM_CAR (fl
), var
))
300 #ifdef MEMOIZE_LOCALS
301 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
302 if (SCM_UNBNDP (SCM_CAR (*al
)))
309 if (SCM_CAR (vloc
) != var
)
312 SCM_SETCAR (vloc
, iloc
);
314 return SCM_CARLOC (*al
);
316 #ifdef MEMOIZE_LOCALS
317 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
320 #ifdef MEMOIZE_LOCALS
321 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
325 SCM top_thunk
, vcell
;
328 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
332 top_thunk
= SCM_BOOL_F
;
333 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
334 if (SCM_FALSEP (vcell
))
340 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
344 /* scm_everr (vloc, genv,...) */
348 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
349 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
351 scm_misc_error (NULL
, "Damaged environment: ~S",
352 scm_cons (var
, SCM_EOL
));
355 /* A variable could not be found, but we shall not throw an error. */
356 static SCM undef_object
= SCM_UNDEFINED
;
357 return &undef_object
;
362 if (SCM_CAR (vloc
) != var2
)
364 /* Some other thread has changed the very cell we are working
365 on. In effect, it must have done our job or messed it up
368 var
= SCM_CAR (vloc
);
369 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
370 return SCM_GLOC_VAL_LOC (var
);
371 #ifdef MEMOIZE_LOCALS
372 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
373 return scm_ilookup (var
, genv
);
375 /* We can't cope with anything else than glocs and ilocs. When
376 a special form has been memoized (i.e. `let' into `#@let') we
377 return NULL and expect the calling function to do the right
378 thing. For the evaluator, this means going back and redoing
379 the dispatch on the car of the form. */
382 #endif /* USE_THREADS */
384 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
385 /* Except wait...what if the var is not a vcell,
386 * but syntax or something.... */
387 return SCM_CDRLOC (var
);
392 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
394 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
401 #define unmemocar scm_unmemocar
404 scm_unmemocar (SCM form
, SCM env
)
411 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
412 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
413 #ifdef MEMOIZE_LOCALS
414 #ifdef DEBUG_EXTENSIONS
415 else if (SCM_ILOCP (c
))
419 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
421 env
= SCM_CAR (SCM_CAR (env
));
422 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
424 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
433 scm_eval_car (SCM pair
, SCM env
)
435 return SCM_XEVALCAR (pair
, env
);
440 * The following rewrite expressions and
441 * some memoized forms have different syntax
444 const char scm_s_expression
[] = "missing or extra expression";
445 const char scm_s_test
[] = "bad test";
446 const char scm_s_body
[] = "bad body";
447 const char scm_s_bindings
[] = "bad 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";
452 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
453 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
454 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
455 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
456 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
460 #ifdef DEBUG_EXTENSIONS
461 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
462 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
463 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
464 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
468 /* Check that the body denoted by XORIG is valid and rewrite it into
469 its internal form. The internal form of a body is just the body
470 itself, but prefixed with an ISYM that denotes to what kind of
471 outer construct this body belongs. A lambda body starts with
472 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
473 etc. The one exception is a body that belongs to a letrec that has
474 been formed by rewriting internal defines: it starts with
477 /* XXX - Besides controlling the rewriting of internal defines, the
478 additional ISYM could be used for improved error messages.
479 This is not done yet. */
482 scm_m_body (SCM op
, SCM xorig
, const char *what
)
484 SCM_ASSYNT (scm_ilength (xorig
) >= 1, xorig
, scm_s_expression
, what
);
486 /* Don't add another ISYM if one is present already. */
487 if (SCM_ISYMP (SCM_CAR (xorig
)))
490 /* Retain possible doc string. */
491 if (!SCM_CONSP (SCM_CAR (xorig
)))
493 if (SCM_NNULLP (SCM_CDR(xorig
)))
494 return scm_cons (SCM_CAR (xorig
),
495 scm_m_body (op
, SCM_CDR(xorig
), what
));
499 return scm_cons (op
, xorig
);
502 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
503 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
506 scm_m_quote (SCM xorig
, SCM env
)
508 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
510 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
511 xorig
, scm_s_expression
, s_quote
);
512 return scm_cons (SCM_IM_QUOTE
, x
);
517 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
518 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
521 scm_m_begin (SCM xorig
, SCM env
)
523 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
524 xorig
, scm_s_expression
, s_begin
);
525 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
528 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
529 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
532 scm_m_if (SCM xorig
, SCM env
)
534 int len
= scm_ilength (SCM_CDR (xorig
));
535 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
536 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
540 /* Will go into the RnRS module when Guile is factorized.
541 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
542 const char scm_s_set_x
[] = "set!";
543 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
546 scm_m_set_x (SCM xorig
, SCM env
)
548 SCM x
= SCM_CDR (xorig
);
549 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
550 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
551 xorig
, scm_s_variable
, scm_s_set_x
);
552 return scm_cons (SCM_IM_SET_X
, x
);
556 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
557 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
560 scm_m_and (SCM xorig
, SCM env
)
562 int len
= scm_ilength (SCM_CDR (xorig
));
563 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
565 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
570 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
571 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
574 scm_m_or (SCM xorig
, SCM env
)
576 int len
= scm_ilength (SCM_CDR (xorig
));
577 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
579 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
585 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
586 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
589 scm_m_case (SCM xorig
, SCM env
)
591 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
592 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
593 while (SCM_NIMP (x
= SCM_CDR (x
)))
596 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
597 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
598 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
599 && SCM_NULLP (SCM_CDR (x
))),
600 xorig
, scm_s_clauses
, s_case
);
602 return scm_cons (SCM_IM_CASE
, cdrx
);
606 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
607 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
611 scm_m_cond (SCM xorig
, SCM env
)
613 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
614 int len
= scm_ilength (x
);
615 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
619 len
= scm_ilength (arg1
);
620 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
621 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
623 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
624 xorig
, "bad ELSE clause", s_cond
);
625 SCM_SETCAR (arg1
, SCM_BOOL_T
);
627 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
628 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
629 xorig
, "bad recipient", s_cond
);
632 return scm_cons (SCM_IM_COND
, cdrx
);
635 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
636 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
639 scm_m_lambda (SCM xorig
, SCM env
)
641 SCM proc
, x
= SCM_CDR (xorig
);
642 if (scm_ilength (x
) < 2)
645 if (SCM_NULLP (proc
))
647 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
651 if (SCM_SYMBOLP (proc
))
653 if (SCM_NCONSP (proc
))
655 while (SCM_NIMP (proc
))
657 if (SCM_NCONSP (proc
))
659 if (!SCM_SYMBOLP (proc
))
664 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
666 proc
= SCM_CDR (proc
);
668 if (SCM_NNULLP (proc
))
671 scm_wta (xorig
, scm_s_formals
, s_lambda
);
675 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
676 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
679 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
680 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
684 scm_m_letstar (SCM xorig
, SCM env
)
686 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
687 int len
= scm_ilength (x
);
688 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
690 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
691 while (SCM_NIMP (proc
))
693 arg1
= SCM_CAR (proc
);
694 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
695 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
696 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
697 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
698 proc
= SCM_CDR (proc
);
700 x
= scm_cons (vars
, SCM_CDR (x
));
702 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
703 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
706 /* DO gets the most radically altered syntax
707 (do ((<var1> <init1> <step1>)
713 (do_mem (varn ... var2 var1)
714 (<init1> <init2> ... <initn>)
717 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
720 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
721 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
724 scm_m_do (SCM xorig
, SCM env
)
726 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
727 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
728 SCM
*initloc
= &inits
, *steploc
= &steps
;
729 int len
= scm_ilength (x
);
730 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
732 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
733 while (SCM_NIMP(proc
))
735 arg1
= SCM_CAR (proc
);
736 len
= scm_ilength (arg1
);
737 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
738 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
739 /* vars reversed here, inits and steps reversed at evaluation */
740 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
741 arg1
= SCM_CDR (arg1
);
742 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
743 initloc
= SCM_CDRLOC (*initloc
);
744 arg1
= SCM_CDR (arg1
);
745 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
746 steploc
= SCM_CDRLOC (*steploc
);
747 proc
= SCM_CDR (proc
);
750 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
751 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
752 x
= scm_cons2 (vars
, inits
, x
);
753 return scm_cons (SCM_IM_DO
, x
);
756 /* evalcar is small version of inline EVALCAR when we don't care about
759 #define evalcar scm_eval_car
762 static SCM
iqq (SCM form
, SCM env
, int depth
);
764 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
765 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
768 scm_m_quasiquote (SCM xorig
, SCM env
)
770 SCM x
= SCM_CDR (xorig
);
771 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
772 return iqq (SCM_CAR (x
), env
, 1);
777 iqq (SCM form
,SCM env
,int depth
)
783 if (SCM_VECTORP (form
))
785 long i
= SCM_VECTOR_LENGTH (form
);
786 SCM
*data
= SCM_VELTS (form
);
789 tmp
= scm_cons (data
[i
], tmp
);
790 return scm_vector (iqq (tmp
, env
, depth
));
792 if (SCM_NCONSP(form
))
794 tmp
= SCM_CAR (form
);
795 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
800 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
804 form
= SCM_CDR (form
);
805 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
806 form
, SCM_ARG1
, s_quasiquote
);
808 return evalcar (form
, env
);
809 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
811 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
815 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
817 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
820 /* Here are acros which return values rather than code. */
822 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
823 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
826 scm_m_delay (SCM xorig
, SCM env
)
828 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
829 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
833 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
834 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
837 scm_m_define (SCM x
, SCM env
)
841 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
844 while (SCM_CONSP (proc
))
845 { /* nested define syntax */
846 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
847 proc
= SCM_CAR (proc
);
849 SCM_ASSYNT (SCM_SYMBOLP (proc
),
850 arg1
, scm_s_variable
, s_define
);
851 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
852 if (SCM_TOP_LEVEL (env
))
854 x
= evalcar (x
, env
);
855 #ifdef DEBUG_EXTENSIONS
856 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
860 if (SCM_CLOSUREP (arg1
)
861 /* Only the first definition determines the name. */
862 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
863 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
864 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
865 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
867 arg1
= SCM_CDR (arg1
);
872 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
873 SCM_SETCDR (arg1
, x
);
875 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
877 return SCM_UNSPECIFIED
;
880 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
886 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
888 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
889 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
890 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
891 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
894 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
897 /* vars scm_list reversed here, inits reversed at evaluation */
898 arg1
= SCM_CAR (proc
);
899 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
900 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
901 vars
= scm_cons (SCM_CAR (arg1
), vars
);
902 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
903 initloc
= SCM_CDRLOC (*initloc
);
905 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
907 return scm_cons2 (op
, vars
,
908 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
911 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
912 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
915 scm_m_letrec (SCM xorig
, SCM env
)
917 SCM x
= SCM_CDR (xorig
);
918 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
920 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
921 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
922 scm_m_body (SCM_IM_LETREC
,
927 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
930 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
931 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
934 scm_m_let (SCM xorig
, SCM env
)
936 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
937 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
938 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
940 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
944 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
946 /* null or single binding, let* is faster */
947 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
948 scm_m_body (SCM_IM_LET
,
954 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
955 if (SCM_CONSP (proc
))
957 /* plain let, proc is <bindings> */
958 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
961 if (!SCM_SYMBOLP (proc
))
962 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
963 name
= proc
; /* named let, build equiv letrec */
965 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
966 proc
= SCM_CAR (x
); /* bindings list */
967 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
968 while (SCM_NIMP (proc
))
969 { /* vars and inits both in order */
970 arg1
= SCM_CAR (proc
);
971 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
972 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
973 xorig
, scm_s_variable
, s_let
);
974 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
975 varloc
= SCM_CDRLOC (*varloc
);
976 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
977 initloc
= SCM_CDRLOC (*initloc
);
978 proc
= SCM_CDR (proc
);
981 proc
= scm_cons2 (scm_sym_lambda
, vars
,
982 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
983 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
985 scm_acons (name
, inits
, SCM_EOL
));
986 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
990 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
991 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
992 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
995 scm_m_apply (SCM xorig
, SCM env
)
997 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
998 xorig
, scm_s_expression
, s_atapply
);
999 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1003 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1004 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1008 scm_m_cont (SCM xorig
, SCM env
)
1010 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1011 xorig
, scm_s_expression
, s_atcall_cc
);
1012 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1015 /* Multi-language support */
1020 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1023 scm_m_nil_cond (SCM xorig
, SCM env
)
1025 int len
= scm_ilength (SCM_CDR (xorig
));
1026 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1027 scm_s_expression
, "nil-cond");
1028 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1031 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1034 scm_m_nil_ify (SCM xorig
, SCM env
)
1036 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1037 xorig
, scm_s_expression
, "nil-ify");
1038 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1041 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1044 scm_m_t_ify (SCM xorig
, SCM env
)
1046 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1047 xorig
, scm_s_expression
, "t-ify");
1048 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1051 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1054 scm_m_0_cond (SCM xorig
, SCM env
)
1056 int len
= scm_ilength (SCM_CDR (xorig
));
1057 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1058 scm_s_expression
, "0-cond");
1059 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1062 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1065 scm_m_0_ify (SCM xorig
, SCM env
)
1067 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1068 xorig
, scm_s_expression
, "0-ify");
1069 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1072 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1075 scm_m_1_ify (SCM xorig
, SCM env
)
1077 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1078 xorig
, scm_s_expression
, "1-ify");
1079 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1082 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1085 scm_m_atfop (SCM xorig
, SCM env
)
1087 SCM x
= SCM_CDR (xorig
), vcell
;
1088 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1089 vcell
= scm_symbol_fref (SCM_CAR (x
));
1090 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1091 "Symbol's function definition is void", NULL
);
1092 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1096 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1099 scm_m_atbind (SCM xorig
, SCM env
)
1101 SCM x
= SCM_CDR (xorig
);
1102 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1108 while (SCM_NIMP (SCM_CDR (env
)))
1109 env
= SCM_CDR (env
);
1110 env
= SCM_CAR (env
);
1111 if (SCM_CONSP (env
))
1116 while (SCM_NIMP (x
))
1118 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1121 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1125 scm_m_expand_body (SCM xorig
, SCM env
)
1127 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1128 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1130 while (SCM_NIMP (x
))
1133 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1135 if (SCM_IMP (SCM_CAR (form
)))
1137 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1140 form
= scm_macroexp (scm_cons_source (form
,
1145 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1147 defs
= scm_cons (SCM_CDR (form
), defs
);
1150 else if (SCM_NIMP(defs
))
1154 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1156 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1160 x
= scm_cons (form
, SCM_CDR(x
));
1165 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1166 if (SCM_NIMP (defs
))
1168 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1170 scm_cons2 (scm_sym_define
, defs
, x
),
1176 SCM_SETCAR (xorig
, SCM_CAR (x
));
1177 SCM_SETCDR (xorig
, SCM_CDR (x
));
1184 scm_macroexp (SCM x
, SCM env
)
1188 /* Don't bother to produce error messages here. We get them when we
1189 eventually execute the code for real. */
1192 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1197 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1198 if (proc_ptr
== NULL
)
1200 /* We have lost the race. */
1206 proc
= *scm_lookupcar (x
, env
, 0);
1209 /* Only handle memoizing macros. `Acros' and `macros' are really
1210 special forms and should not be evaluated here. */
1213 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1214 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1218 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1220 if (scm_ilength (res
) <= 0)
1221 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1224 SCM_SETCAR (x
, SCM_CAR (res
));
1225 SCM_SETCDR (x
, SCM_CDR (res
));
1231 /* scm_unmemocopy takes a memoized expression together with its
1232 * environment and rewrites it to its original form. Thus, it is the
1233 * inversion of the rewrite rules above. The procedure is not
1234 * optimized for speed. It's used in scm_iprin1 when printing the
1235 * code of a closure, in scm_procedure_source, in display_frame when
1236 * generating the source for a stackframe in a backtrace, and in
1237 * display_expression.
1240 /* We should introduce an anti-macro interface so that it is possible
1241 * to plug in transformers in both directions from other compilation
1242 * units. unmemocopy could then dispatch to anti-macro transformers.
1243 * (Those transformers could perhaps be written in slightly more
1244 * readable style... :)
1247 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1250 unmemocopy (SCM x
, SCM env
)
1253 #ifdef DEBUG_EXTENSIONS
1256 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1258 #ifdef DEBUG_EXTENSIONS
1259 p
= scm_whash_lookup (scm_source_whash
, x
);
1261 switch (SCM_TYP7 (x
))
1263 case SCM_BIT8(SCM_IM_AND
):
1264 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1266 case SCM_BIT8(SCM_IM_BEGIN
):
1267 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1269 case SCM_BIT8(SCM_IM_CASE
):
1270 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1272 case SCM_BIT8(SCM_IM_COND
):
1273 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1275 case SCM_BIT8(SCM_IM_DO
):
1276 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1278 case SCM_BIT8(SCM_IM_IF
):
1279 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1281 case SCM_BIT8(SCM_IM_LET
):
1282 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1284 case SCM_BIT8(SCM_IM_LETREC
):
1287 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1291 f
= v
= SCM_CAR (x
);
1293 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1295 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1296 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1299 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1300 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1302 /* build transformed binding list */
1304 while (SCM_NIMP (v
))
1306 z
= scm_acons (SCM_CAR (v
),
1307 scm_cons (SCM_CAR (e
),
1308 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1310 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1316 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1318 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1322 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1325 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1326 /* body forms are now to be found in SCM_CDR (x)
1327 (this is how *real* code look like! :) */
1331 case SCM_BIT8(SCM_IM_LETSTAR
):
1339 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1342 y
= z
= scm_acons (SCM_CAR (b
),
1344 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1346 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1347 b
= SCM_CDR (SCM_CDR (b
));
1350 SCM_SETCDR (y
, SCM_EOL
);
1351 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1356 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1358 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1361 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1362 b
= SCM_CDR (SCM_CDR (b
));
1364 while (SCM_NIMP (b
));
1365 SCM_SETCDR (z
, SCM_EOL
);
1367 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1370 case SCM_BIT8(SCM_IM_OR
):
1371 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1373 case SCM_BIT8(SCM_IM_LAMBDA
):
1375 ls
= scm_cons (scm_sym_lambda
,
1376 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1377 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1379 case SCM_BIT8(SCM_IM_QUOTE
):
1380 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1382 case SCM_BIT8(SCM_IM_SET_X
):
1383 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1385 case SCM_BIT8(SCM_IM_DEFINE
):
1389 ls
= scm_cons (scm_sym_define
,
1390 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1391 if (SCM_NNULLP (env
))
1392 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1395 case SCM_BIT8(SCM_MAKISYM (0)):
1399 switch (SCM_ISYMNUM (z
))
1401 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1402 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1404 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1405 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1407 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1408 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1412 /* appease the Sun compiler god: */ ;
1416 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1421 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1423 if (SCM_ISYMP (SCM_CAR (x
)))
1424 /* skip body markers */
1426 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1432 #ifdef DEBUG_EXTENSIONS
1433 if (SCM_NFALSEP (p
))
1434 scm_whash_insert (scm_source_whash
, ls
, p
);
1441 scm_unmemocopy (SCM x
, SCM env
)
1443 if (SCM_NNULLP (env
))
1444 /* Make a copy of the lowest frame to protect it from
1445 modifications by SCM_IM_DEFINE */
1446 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1448 return unmemocopy (x
, env
);
1451 #ifndef SCM_RECKLESS
1454 scm_badargsp (SCM formals
, SCM args
)
1456 while (SCM_NIMP (formals
))
1458 if (SCM_NCONSP (formals
))
1462 formals
= SCM_CDR (formals
);
1463 args
= SCM_CDR (args
);
1465 return SCM_NNULLP (args
) ? 1 : 0;
1470 scm_badformalsp (SCM closure
, int n
)
1472 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1473 while (SCM_NIMP (formals
))
1475 if (SCM_NCONSP (formals
))
1480 formals
= SCM_CDR (formals
);
1487 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1489 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1490 while (SCM_NIMP (l
))
1495 if (SCM_IMP (SCM_CAR (l
)))
1496 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1498 res
= EVALCELLCAR (l
, env
);
1500 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1502 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1504 res
= SCM_CAR (l
); /* struct planted in code */
1506 res
= SCM_PACK (vcell
);
1511 res
= EVALCAR (l
, env
);
1513 *lloc
= scm_cons (res
, SCM_EOL
);
1514 lloc
= SCM_CDRLOC (*lloc
);
1521 scm_wrong_num_args (proc
);
1528 scm_eval_body (SCM code
, SCM env
)
1533 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1535 if (SCM_IMP (SCM_CAR (code
)))
1537 if (SCM_ISYMP (SCM_CAR (code
)))
1539 code
= scm_m_expand_body (code
, env
);
1544 SCM_XEVAL (SCM_CAR (code
), env
);
1547 return SCM_XEVALCAR (code
, env
);
1554 /* SECTION: This code is specific for the debugging support. One
1555 * branch is read when DEVAL isn't defined, the other when DEVAL is
1561 #define SCM_APPLY scm_apply
1562 #define PREP_APPLY(proc, args)
1564 #define RETURN(x) return x;
1565 #ifdef STACK_CHECKING
1566 #ifndef NO_CEVAL_STACK_CHECKING
1567 #define EVAL_STACK_CHECKING
1574 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1576 #define SCM_APPLY scm_dapply
1578 #define PREP_APPLY(p, l) \
1579 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1581 #define ENTER_APPLY \
1583 SCM_SET_ARGSREADY (debug);\
1584 if (CHECK_APPLY && SCM_TRAPS_P)\
1585 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1587 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1588 SCM_SET_TRACED_FRAME (debug); \
1589 if (SCM_CHEAPTRAPS_P)\
1591 tmp = scm_make_debugobj (&debug);\
1592 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1597 tmp = scm_make_continuation (&first);\
1599 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1604 #define RETURN(e) {proc = (e); goto exit;}
1605 #ifdef STACK_CHECKING
1606 #ifndef EVAL_STACK_CHECKING
1607 #define EVAL_STACK_CHECKING
1611 /* scm_ceval_ptr points to the currently selected evaluator.
1612 * *fixme*: Although efficiency is important here, this state variable
1613 * should probably not be a global. It should be related to the
1618 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1620 /* scm_last_debug_frame contains a pointer to the last debugging
1621 * information stack frame. It is accessed very often from the
1622 * debugging evaluator, so it should probably not be indirectly
1623 * addressed. Better to save and restore it from the current root at
1628 scm_debug_frame
*scm_last_debug_frame
;
1631 /* scm_debug_eframe_size is the number of slots available for pseudo
1632 * stack frames at each real stack frame.
1635 int scm_debug_eframe_size
;
1637 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1641 scm_option scm_eval_opts
[] = {
1642 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1645 scm_option scm_debug_opts
[] = {
1646 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1647 "*Flyweight representation of the stack at traps." },
1648 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1649 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1650 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1651 "Record procedure names at definition." },
1652 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1653 "Display backtrace in anti-chronological order." },
1654 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1655 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1656 { SCM_OPTION_INTEGER
, "frames", 3,
1657 "Maximum number of tail-recursive frames in backtrace." },
1658 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1659 "Maximal number of stored backtrace frames." },
1660 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1661 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1662 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1663 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1666 scm_option scm_evaluator_trap_table
[] = {
1667 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1668 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1669 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1670 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1673 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1675 "Option interface for the evaluation options. Instead of using\n"
1676 "this procedure directly, use the procedures @code{eval-enable},\n"
1677 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1678 #define FUNC_NAME s_scm_eval_options_interface
1682 ans
= scm_options (setting
,
1686 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1692 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1694 "Option interface for the evaluator trap options.")
1695 #define FUNC_NAME s_scm_evaluator_traps
1699 ans
= scm_options (setting
,
1700 scm_evaluator_trap_table
,
1701 SCM_N_EVALUATOR_TRAPS
,
1703 SCM_RESET_DEBUG_MODE
;
1710 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1712 SCM
*results
= lloc
, res
;
1713 while (SCM_NIMP (l
))
1718 if (SCM_IMP (SCM_CAR (l
)))
1719 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1721 res
= EVALCELLCAR (l
, env
);
1723 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1725 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1727 res
= SCM_CAR (l
); /* struct planted in code */
1729 res
= SCM_PACK (vcell
);
1734 res
= EVALCAR (l
, env
);
1736 *lloc
= scm_cons (res
, SCM_EOL
);
1737 lloc
= SCM_CDRLOC (*lloc
);
1744 scm_wrong_num_args (proc
);
1753 /* SECTION: Some local definitions for the evaluator.
1757 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1760 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1762 /* SECTION: This is the evaluator. Like any real monster, it has
1763 * three heads. This code is compiled twice.
1769 scm_ceval (SCM x
, SCM env
)
1775 scm_deval (SCM x
, SCM env
)
1780 SCM_CEVAL (SCM x
, SCM env
)
1789 scm_debug_frame debug
;
1790 scm_debug_info
*debug_info_end
;
1791 debug
.prev
= scm_last_debug_frame
;
1792 debug
.status
= scm_debug_eframe_size
;
1794 * The debug.vect contains twice as much scm_debug_info frames as the
1795 * user has specified with (debug-set! frames <n>).
1797 * Even frames are eval frames, odd frames are apply frames.
1799 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1800 * sizeof (debug
.vect
[0]));
1801 debug
.info
= debug
.vect
;
1802 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1803 scm_last_debug_frame
= &debug
;
1805 #ifdef EVAL_STACK_CHECKING
1806 if (scm_stack_checking_enabled_p
1807 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1810 debug
.info
->e
.exp
= x
;
1811 debug
.info
->e
.env
= env
;
1813 scm_report_stack_overflow ();
1820 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1823 SCM_CLEAR_ARGSREADY (debug
);
1824 if (SCM_OVERFLOWP (debug
))
1827 * In theory, this should be the only place where it is necessary to
1828 * check for space in debug.vect since both eval frames and
1829 * available space are even.
1831 * For this to be the case, however, it is necessary that primitive
1832 * special forms which jump back to `loop', `begin' or some similar
1833 * label call PREP_APPLY. A convenient way to do this is to jump to
1834 * `loopnoap' or `cdrxnoap'.
1836 else if (++debug
.info
>= debug_info_end
)
1838 SCM_SET_OVERFLOW (debug
);
1842 debug
.info
->e
.exp
= x
;
1843 debug
.info
->e
.env
= env
;
1844 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1845 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1847 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1848 SCM_SET_TAILREC (debug
);
1849 if (SCM_CHEAPTRAPS_P
)
1850 t
.arg1
= scm_make_debugobj (&debug
);
1854 SCM val
= scm_make_continuation (&first
);
1866 /* This gives the possibility for the debugger to
1867 modify the source expression before evaluation. */
1871 scm_ithrow (scm_sym_enter_frame
,
1872 scm_cons2 (t
.arg1
, tail
,
1873 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1877 #if defined (USE_THREADS) || defined (DEVAL)
1881 switch (SCM_TYP7 (x
))
1883 case scm_tc7_symbol
:
1884 /* Only happens when called at top level.
1886 x
= scm_cons (x
, SCM_UNDEFINED
);
1889 case SCM_BIT8(SCM_IM_AND
):
1892 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1893 if (SCM_FALSEP (EVALCAR (x
, env
)))
1895 RETURN (SCM_BOOL_F
);
1899 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1902 case SCM_BIT8(SCM_IM_BEGIN
):
1904 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1909 /* If we are on toplevel with a lookup closure, we need to sync
1910 with the current module. */
1911 if (SCM_CONSP(env
) && !SCM_CONSP(SCM_CAR(env
)))
1914 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1916 env
= scm_top_level_env (scm_current_module_lookup_closure ());
1917 SIDEVAL (SCM_CAR(x
), env
);
1920 /* once more, for the last form */
1921 env
= scm_top_level_env (scm_current_module_lookup_closure ());
1926 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1928 if (SCM_IMP (SCM_CAR (x
)))
1930 if (SCM_ISYMP (SCM_CAR (x
)))
1932 x
= scm_m_expand_body (x
, env
);
1937 SCM_CEVAL (SCM_CAR (x
), env
);
1942 carloop
: /* scm_eval car of last form in list */
1943 if (SCM_NCELLP (SCM_CAR (x
)))
1946 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1949 if (SCM_SYMBOLP (SCM_CAR (x
)))
1952 RETURN (*scm_lookupcar (x
, env
, 1))
1956 goto loop
; /* tail recurse */
1959 case SCM_BIT8(SCM_IM_CASE
):
1961 t
.arg1
= EVALCAR (x
, env
);
1962 while (SCM_NIMP (x
= SCM_CDR (x
)))
1965 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1968 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1971 proc
= SCM_CAR (proc
);
1972 while (SCM_NIMP (proc
))
1974 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1976 x
= SCM_CDR (SCM_CAR (x
));
1977 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1980 proc
= SCM_CDR (proc
);
1983 RETURN (SCM_UNSPECIFIED
)
1986 case SCM_BIT8(SCM_IM_COND
):
1987 while (SCM_NIMP (x
= SCM_CDR (x
)))
1990 t
.arg1
= EVALCAR (proc
, env
);
1991 if (SCM_NFALSEP (t
.arg1
))
1998 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2000 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2004 proc
= EVALCAR (proc
, env
);
2005 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2006 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2008 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2009 goto umwrongnumargs
;
2013 RETURN (SCM_UNSPECIFIED
)
2016 case SCM_BIT8(SCM_IM_DO
):
2018 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2019 t
.arg1
= SCM_EOL
; /* values */
2020 while (SCM_NIMP (proc
))
2022 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2023 proc
= SCM_CDR (proc
);
2025 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2026 x
= SCM_CDR (SCM_CDR (x
));
2027 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2029 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2031 t
.arg1
= SCM_CAR (proc
); /* body */
2032 SIDEVAL (t
.arg1
, env
);
2034 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2036 proc
= SCM_CDR (proc
))
2037 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2038 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2042 RETURN (SCM_UNSPECIFIED
);
2043 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2047 case SCM_BIT8(SCM_IM_IF
):
2049 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2051 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2053 RETURN (SCM_UNSPECIFIED
);
2055 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2059 case SCM_BIT8(SCM_IM_LET
):
2061 proc
= SCM_CAR (SCM_CDR (x
));
2065 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2067 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2068 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2073 case SCM_BIT8(SCM_IM_LETREC
):
2075 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2081 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2083 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2084 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2088 case SCM_BIT8(SCM_IM_LETSTAR
):
2093 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2098 t
.arg1
= SCM_CAR (proc
);
2099 proc
= SCM_CDR (proc
);
2100 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2102 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2105 case SCM_BIT8(SCM_IM_OR
):
2108 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2110 x
= EVALCAR (x
, env
);
2111 if (SCM_NFALSEP (x
))
2117 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2121 case SCM_BIT8(SCM_IM_LAMBDA
):
2122 RETURN (scm_closure (SCM_CDR (x
), env
));
2125 case SCM_BIT8(SCM_IM_QUOTE
):
2126 RETURN (SCM_CAR (SCM_CDR (x
)));
2129 case SCM_BIT8(SCM_IM_SET_X
):
2132 switch (SCM_ITAG3 (proc
))
2135 t
.lloc
= scm_lookupcar (x
, env
, 1);
2137 case scm_tc3_cons_gloc
:
2138 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2140 #ifdef MEMOIZE_LOCALS
2142 t
.lloc
= scm_ilookup (proc
, env
);
2147 *t
.lloc
= EVALCAR (x
, env
);
2151 RETURN (SCM_UNSPECIFIED
);
2155 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2156 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2158 /* new syntactic forms go here. */
2159 case SCM_BIT8(SCM_MAKISYM (0)):
2161 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2162 switch SCM_ISYMNUM (proc
)
2164 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2166 proc
= EVALCAR (proc
, env
);
2167 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2168 if (SCM_CLOSUREP (proc
))
2171 PREP_APPLY (proc
, SCM_EOL
);
2172 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2173 t
.arg1
= EVALCAR (t
.arg1
, env
);
2175 debug
.info
->a
.args
= t
.arg1
;
2177 #ifndef SCM_RECKLESS
2178 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2182 /* Copy argument list */
2183 if (SCM_IMP (t
.arg1
))
2187 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2188 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2189 && SCM_CONSP (t
.arg1
))
2191 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2195 SCM_SETCDR (tl
, t
.arg1
);
2198 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2199 x
= SCM_CODE (proc
);
2205 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2208 SCM val
= scm_make_continuation (&first
);
2216 proc
= evalcar (proc
, env
);
2217 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2218 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2220 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2221 goto umwrongnumargs
;
2224 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2225 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2227 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2228 proc
= SCM_CADR (x
); /* unevaluated operands */
2229 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2231 arg2
= *scm_ilookup (proc
, env
);
2232 else if (SCM_NCONSP (proc
))
2234 if (SCM_NCELLP (proc
))
2235 arg2
= SCM_GLOC_VAL (proc
);
2237 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2241 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2242 t
.lloc
= SCM_CDRLOC (arg2
);
2243 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2245 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2246 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2251 /* The type dispatch code is duplicated here
2252 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2253 * cuts down execution time for type dispatch to 50%.
2256 int i
, n
, end
, mask
;
2257 SCM z
= SCM_CDDR (x
);
2258 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2259 proc
= SCM_CADR (z
);
2261 if (SCM_NIMP (proc
))
2263 /* Prepare for linear search */
2266 end
= SCM_VECTOR_LENGTH (proc
);
2270 /* Compute a hash value */
2271 int hashset
= SCM_INUM (proc
);
2273 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2274 proc
= SCM_CADR (z
);
2277 if (SCM_NIMP (t
.arg1
))
2280 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2281 [scm_si_hashsets
+ hashset
];
2282 t
.arg1
= SCM_CDR (t
.arg1
);
2284 while (j
-- && SCM_NIMP (t
.arg1
));
2289 /* Search for match */
2293 z
= SCM_VELTS (proc
)[i
];
2294 t
.arg1
= arg2
; /* list of arguments */
2295 if (SCM_NIMP (t
.arg1
))
2298 /* More arguments than specifiers => CLASS != ENV */
2299 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2301 t
.arg1
= SCM_CDR (t
.arg1
);
2304 while (j
-- && SCM_NIMP (t
.arg1
));
2305 /* Fewer arguments than specifiers => CAR != ENV */
2306 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2309 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2311 SCM_CMETHOD_ENV (z
));
2312 x
= SCM_CMETHOD_CODE (z
);
2318 z
= scm_memoize_method (x
, arg2
);
2322 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2324 t
.arg1
= EVALCAR (x
, env
);
2325 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2327 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2329 t
.arg1
= EVALCAR (x
, env
);
2332 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2333 = SCM_UNPACK (EVALCAR (proc
, env
));
2334 RETURN (SCM_UNSPECIFIED
)
2336 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2338 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2340 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2341 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2343 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2345 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2351 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2354 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2356 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2360 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2362 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2364 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2366 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2368 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2369 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2371 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2373 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2379 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2382 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2384 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2388 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2390 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2394 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2397 t
.arg1
= SCM_CAR (x
);
2398 arg2
= SCM_CDAR (env
);
2399 while (SCM_NIMP (arg2
))
2401 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2402 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2404 SCM_SETCAR (arg2
, proc
);
2405 t
.arg1
= SCM_CDR (t
.arg1
);
2406 arg2
= SCM_CDR (arg2
);
2408 t
.arg1
= SCM_CAR (x
);
2409 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2411 arg2
= x
= SCM_CDR (x
);
2412 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2414 SIDEVAL (SCM_CAR (x
), env
);
2417 proc
= EVALCAR (x
, env
);
2419 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2420 arg2
= SCM_CDAR (env
);
2421 while (SCM_NIMP (arg2
))
2423 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2425 t
.arg1
= SCM_CDR (t
.arg1
);
2426 arg2
= SCM_CDR (arg2
);
2438 /* scm_everr (x, env,...) */
2439 scm_misc_error (NULL
,
2440 "Wrong type to apply: ~S",
2441 scm_listify (proc
, SCM_UNDEFINED
));
2442 case scm_tc7_vector
:
2446 case scm_tc7_byvect
:
2453 #ifdef HAVE_LONG_LONGS
2454 case scm_tc7_llvect
:
2457 case scm_tc7_string
:
2458 case scm_tc7_substring
:
2460 case scm_tcs_closures
:
2466 #ifdef MEMOIZE_LOCALS
2467 case SCM_BIT8(SCM_ILOC00
):
2468 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2469 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2470 #ifndef SCM_RECKLESS
2476 #endif /* ifdef MEMOIZE_LOCALS */
2479 case scm_tcs_cons_gloc
: {
2480 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2482 /* This is a struct implanted in the code, not a gloc. */
2485 proc
= SCM_PACK (vcell
);
2486 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2487 #ifndef SCM_RECKLESS
2496 case scm_tcs_cons_nimcar
:
2497 if (SCM_SYMBOLP (SCM_CAR (x
)))
2500 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2503 /* we have lost the race, start again. */
2508 proc
= *scm_lookupcar (x
, env
, 1);
2516 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2522 /* Set a flag during macro expansion so that macro
2523 application frames can be deleted from the backtrace. */
2524 SCM_SET_MACROEXP (debug
);
2526 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2527 scm_cons (env
, scm_listofnull
));
2530 SCM_CLEAR_MACROEXP (debug
);
2532 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2535 if (scm_ilength (t
.arg1
) <= 0)
2536 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2538 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2541 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2542 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2546 /* Prevent memoizing of debug info expression. */
2547 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2552 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2553 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2557 if (SCM_NIMP (x
= t
.arg1
))
2565 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2566 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2567 #ifndef SCM_RECKLESS
2571 if (SCM_CLOSUREP (proc
))
2573 arg2
= SCM_CAR (SCM_CODE (proc
));
2574 t
.arg1
= SCM_CDR (x
);
2575 while (SCM_NIMP (arg2
))
2577 if (SCM_NCONSP (arg2
))
2579 if (SCM_IMP (t
.arg1
))
2580 goto umwrongnumargs
;
2581 arg2
= SCM_CDR (arg2
);
2582 t
.arg1
= SCM_CDR (t
.arg1
);
2584 if (SCM_NNULLP (t
.arg1
))
2585 goto umwrongnumargs
;
2587 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2588 goto handle_a_macro
;
2594 PREP_APPLY (proc
, SCM_EOL
);
2595 if (SCM_NULLP (SCM_CDR (x
))) {
2598 switch (SCM_TYP7 (proc
))
2599 { /* no arguments given */
2600 case scm_tc7_subr_0
:
2601 RETURN (SCM_SUBRF (proc
) ());
2602 case scm_tc7_subr_1o
:
2603 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2605 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2606 case scm_tc7_rpsubr
:
2607 RETURN (SCM_BOOL_T
);
2609 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2611 if (!SCM_SMOB_APPLICABLE_P (proc
))
2613 RETURN (SCM_SMOB_APPLY_0 (proc
));
2616 proc
= SCM_CCLO_SUBR (proc
);
2618 debug
.info
->a
.proc
= proc
;
2619 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2623 proc
= SCM_PROCEDURE (proc
);
2625 debug
.info
->a
.proc
= proc
;
2627 if (!SCM_CLOSUREP (proc
))
2629 if (scm_badformalsp (proc
, 0))
2630 goto umwrongnumargs
;
2631 case scm_tcs_closures
:
2632 x
= SCM_CODE (proc
);
2633 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2635 case scm_tcs_cons_gloc
:
2636 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2638 x
= SCM_ENTITY_PROCEDURE (proc
);
2642 else if (!SCM_I_OPERATORP (proc
))
2647 proc
= (SCM_I_ENTITYP (proc
)
2648 ? SCM_ENTITY_PROCEDURE (proc
)
2649 : SCM_OPERATOR_PROCEDURE (proc
));
2651 debug
.info
->a
.proc
= proc
;
2652 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2654 if (SCM_NIMP (proc
))
2659 case scm_tc7_subr_1
:
2660 case scm_tc7_subr_2
:
2661 case scm_tc7_subr_2o
:
2663 case scm_tc7_subr_3
:
2664 case scm_tc7_lsubr_2
:
2668 /* scm_everr (x, env,...) */
2669 scm_wrong_num_args (proc
);
2671 /* handle macros here */
2676 /* must handle macros by here */
2681 else if (SCM_CONSP (x
))
2683 if (SCM_IMP (SCM_CAR (x
)))
2684 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2686 t
.arg1
= EVALCELLCAR (x
, env
);
2688 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2690 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2692 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2694 t
.arg1
= SCM_PACK (vcell
);
2699 t
.arg1
= EVALCAR (x
, env
);
2702 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2709 switch (SCM_TYP7 (proc
))
2710 { /* have one argument in t.arg1 */
2711 case scm_tc7_subr_2o
:
2712 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2713 case scm_tc7_subr_1
:
2714 case scm_tc7_subr_1o
:
2715 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2717 if (SCM_SUBRF (proc
))
2719 if (SCM_INUMP (t
.arg1
))
2721 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2723 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2724 if (SCM_REALP (t
.arg1
))
2726 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2729 if (SCM_BIGP (t
.arg1
))
2731 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2735 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2736 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2738 proc
= SCM_SNAME (proc
);
2740 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2741 while ('c' != *--chrs
)
2743 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2744 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2745 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2749 case scm_tc7_rpsubr
:
2750 RETURN (SCM_BOOL_T
);
2752 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2755 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2757 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2760 if (!SCM_SMOB_APPLICABLE_P (proc
))
2762 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2766 proc
= SCM_CCLO_SUBR (proc
);
2768 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2769 debug
.info
->a
.proc
= proc
;
2773 proc
= SCM_PROCEDURE (proc
);
2775 debug
.info
->a
.proc
= proc
;
2777 if (!SCM_CLOSUREP (proc
))
2779 if (scm_badformalsp (proc
, 1))
2780 goto umwrongnumargs
;
2781 case scm_tcs_closures
:
2783 x
= SCM_CODE (proc
);
2785 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2787 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2790 case scm_tcs_cons_gloc
:
2791 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2793 x
= SCM_ENTITY_PROCEDURE (proc
);
2795 arg2
= debug
.info
->a
.args
;
2797 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2801 else if (!SCM_I_OPERATORP (proc
))
2807 proc
= (SCM_I_ENTITYP (proc
)
2808 ? SCM_ENTITY_PROCEDURE (proc
)
2809 : SCM_OPERATOR_PROCEDURE (proc
));
2811 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2812 debug
.info
->a
.proc
= proc
;
2814 if (SCM_NIMP (proc
))
2819 case scm_tc7_subr_2
:
2820 case scm_tc7_subr_0
:
2821 case scm_tc7_subr_3
:
2822 case scm_tc7_lsubr_2
:
2831 else if (SCM_CONSP (x
))
2833 if (SCM_IMP (SCM_CAR (x
)))
2834 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2836 arg2
= EVALCELLCAR (x
, env
);
2838 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2840 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2842 arg2
= SCM_CAR (x
); /* struct planted in code */
2844 arg2
= SCM_PACK (vcell
);
2849 arg2
= EVALCAR (x
, env
);
2851 { /* have two or more arguments */
2853 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2856 if (SCM_NULLP (x
)) {
2859 switch (SCM_TYP7 (proc
))
2860 { /* have two arguments */
2861 case scm_tc7_subr_2
:
2862 case scm_tc7_subr_2o
:
2863 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2866 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2868 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2870 case scm_tc7_lsubr_2
:
2871 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2872 case scm_tc7_rpsubr
:
2874 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2876 if (!SCM_SMOB_APPLICABLE_P (proc
))
2878 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2882 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2883 scm_cons (proc
, debug
.info
->a
.args
),
2886 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2887 scm_cons2 (proc
, t
.arg1
,
2894 case scm_tcs_cons_gloc
:
2895 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2897 x
= SCM_ENTITY_PROCEDURE (proc
);
2899 arg2
= debug
.info
->a
.args
;
2901 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2905 else if (!SCM_I_OPERATORP (proc
))
2911 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2912 ? SCM_ENTITY_PROCEDURE (proc
)
2913 : SCM_OPERATOR_PROCEDURE (proc
),
2914 scm_cons (proc
, debug
.info
->a
.args
),
2917 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2918 ? SCM_ENTITY_PROCEDURE (proc
)
2919 : SCM_OPERATOR_PROCEDURE (proc
),
2920 scm_cons2 (proc
, t
.arg1
,
2928 case scm_tc7_subr_0
:
2930 case scm_tc7_subr_1o
:
2931 case scm_tc7_subr_1
:
2932 case scm_tc7_subr_3
:
2937 proc
= SCM_PROCEDURE (proc
);
2939 debug
.info
->a
.proc
= proc
;
2941 if (!SCM_CLOSUREP (proc
))
2943 if (scm_badformalsp (proc
, 2))
2944 goto umwrongnumargs
;
2945 case scm_tcs_closures
:
2948 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2952 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2953 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2955 x
= SCM_CODE (proc
);
2960 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2964 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2965 scm_deval_args (x
, env
, proc
,
2966 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2970 switch (SCM_TYP7 (proc
))
2971 { /* have 3 or more arguments */
2973 case scm_tc7_subr_3
:
2974 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2975 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2976 SCM_CADDR (debug
.info
->a
.args
)));
2978 #ifdef BUILTIN_RPASUBR
2979 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2980 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2983 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2984 arg2
= SCM_CDR (arg2
);
2986 while (SCM_NIMP (arg2
));
2988 #endif /* BUILTIN_RPASUBR */
2989 case scm_tc7_rpsubr
:
2990 #ifdef BUILTIN_RPASUBR
2991 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2993 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2996 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2998 arg2
= SCM_CAR (t
.arg1
);
2999 t
.arg1
= SCM_CDR (t
.arg1
);
3001 while (SCM_NIMP (t
.arg1
));
3003 #else /* BUILTIN_RPASUBR */
3004 RETURN (SCM_APPLY (proc
, t
.arg1
,
3006 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3008 #endif /* BUILTIN_RPASUBR */
3009 case scm_tc7_lsubr_2
:
3010 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3011 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3013 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3015 if (!SCM_SMOB_APPLICABLE_P (proc
))
3017 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3018 SCM_CDDR (debug
.info
->a
.args
)));
3022 proc
= SCM_PROCEDURE (proc
);
3023 debug
.info
->a
.proc
= proc
;
3024 if (!SCM_CLOSUREP (proc
))
3026 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3027 goto umwrongnumargs
;
3028 case scm_tcs_closures
:
3029 SCM_SET_ARGSREADY (debug
);
3030 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3033 x
= SCM_CODE (proc
);
3036 case scm_tc7_subr_3
:
3037 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3038 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3040 #ifdef BUILTIN_RPASUBR
3041 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3044 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3047 while (SCM_NIMP (x
));
3049 #endif /* BUILTIN_RPASUBR */
3050 case scm_tc7_rpsubr
:
3051 #ifdef BUILTIN_RPASUBR
3052 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3056 t
.arg1
= EVALCAR (x
, env
);
3057 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3062 while (SCM_NIMP (x
));
3064 #else /* BUILTIN_RPASUBR */
3065 RETURN (SCM_APPLY (proc
, t
.arg1
,
3067 scm_eval_args (x
, env
, proc
),
3069 #endif /* BUILTIN_RPASUBR */
3070 case scm_tc7_lsubr_2
:
3071 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3073 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3075 scm_eval_args (x
, env
, proc
))));
3077 if (!SCM_SMOB_APPLICABLE_P (proc
))
3079 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3080 scm_eval_args (x
, env
, proc
)));
3084 proc
= SCM_PROCEDURE (proc
);
3085 if (!SCM_CLOSUREP (proc
))
3088 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3089 if (SCM_NULLP (formals
)
3090 || (SCM_CONSP (formals
)
3091 && (SCM_NULLP (SCM_CDR (formals
))
3092 || (SCM_CONSP (SCM_CDR (formals
))
3093 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3094 goto umwrongnumargs
;
3096 case scm_tcs_closures
:
3098 SCM_SET_ARGSREADY (debug
);
3100 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3103 scm_eval_args (x
, env
, proc
)),
3105 x
= SCM_CODE (proc
);
3108 case scm_tcs_cons_gloc
:
3109 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3112 arg2
= debug
.info
->a
.args
;
3114 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3116 x
= SCM_ENTITY_PROCEDURE (proc
);
3119 else if (!SCM_I_OPERATORP (proc
))
3123 case scm_tc7_subr_2
:
3124 case scm_tc7_subr_1o
:
3125 case scm_tc7_subr_2o
:
3126 case scm_tc7_subr_0
:
3128 case scm_tc7_subr_1
:
3136 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3137 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3139 SCM_CLEAR_TRACED_FRAME (debug
);
3140 if (SCM_CHEAPTRAPS_P
)
3141 t
.arg1
= scm_make_debugobj (&debug
);
3145 SCM val
= scm_make_continuation (&first
);
3155 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3158 scm_last_debug_frame
= debug
.prev
;
3164 /* SECTION: This code is compiled once.
3169 /* This code processes the arguments to apply:
3171 (apply PROC ARG1 ... ARGS)
3173 Given a list (ARG1 ... ARGS), this function conses the ARG1
3174 ... arguments onto the front of ARGS, and returns the resulting
3175 list. Note that ARGS is a list; thus, the argument to this
3176 function is a list whose last element is a list.
3178 Apply calls this function, and applies PROC to the elements of the
3179 result. apply:nconc2last takes care of building the list of
3180 arguments, given (ARG1 ... ARGS).
3182 Rather than do new consing, apply:nconc2last destroys its argument.
3183 On that topic, this code came into my care with the following
3184 beautifully cryptic comment on that topic: "This will only screw
3185 you if you do (scm_apply scm_apply '( ... ))" If you know what
3186 they're referring to, send me a patch to this comment. */
3188 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3190 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3191 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3192 "@var{args}, and returns the resulting list. Note that\n"
3193 "@var{args} is a list; thus, the argument to this function is\n"
3194 "a list whose last element is a list.\n"
3195 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3196 "destroys its argument, so use with care.")
3197 #define FUNC_NAME s_scm_nconc2last
3200 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3202 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3203 lloc
= SCM_CDRLOC (*lloc
);
3204 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3205 *lloc
= SCM_CAR (*lloc
);
3213 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3214 * It is compiled twice.
3220 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3227 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3232 /* Apply a function to a list of arguments.
3234 This function is exported to the Scheme level as taking two
3235 required arguments and a tail argument, as if it were:
3236 (lambda (proc arg1 . args) ...)
3237 Thus, if you just have a list of arguments to pass to a procedure,
3238 pass the list as ARG1, and '() for ARGS. If you have some fixed
3239 args, pass the first as ARG1, then cons any remaining fixed args
3240 onto the front of your argument list, and pass that as ARGS. */
3243 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3245 #ifdef DEBUG_EXTENSIONS
3247 scm_debug_frame debug
;
3248 scm_debug_info debug_vect_body
;
3249 debug
.prev
= scm_last_debug_frame
;
3250 debug
.status
= SCM_APPLYFRAME
;
3251 debug
.vect
= &debug_vect_body
;
3252 debug
.vect
[0].a
.proc
= proc
;
3253 debug
.vect
[0].a
.args
= SCM_EOL
;
3254 scm_last_debug_frame
= &debug
;
3257 return scm_dapply (proc
, arg1
, args
);
3261 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3263 /* If ARGS is the empty list, then we're calling apply with only two
3264 arguments --- ARG1 is the list of arguments for PROC. Whatever
3265 the case, futz with things so that ARG1 is the first argument to
3266 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3269 Setting the debug apply frame args this way is pretty messy.
3270 Perhaps we should store arg1 and args directly in the frame as
3271 received, and let scm_frame_arguments unpack them, because that's
3272 a relatively rare operation. This works for now; if the Guile
3273 developer archives are still around, see Mikael's post of
3275 if (SCM_NULLP (args
))
3277 if (SCM_NULLP (arg1
))
3279 arg1
= SCM_UNDEFINED
;
3281 debug
.vect
[0].a
.args
= SCM_EOL
;
3287 debug
.vect
[0].a
.args
= arg1
;
3289 args
= SCM_CDR (arg1
);
3290 arg1
= SCM_CAR (arg1
);
3295 args
= scm_nconc2last (args
);
3297 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3301 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3304 if (SCM_CHEAPTRAPS_P
)
3305 tmp
= scm_make_debugobj (&debug
);
3310 tmp
= scm_make_continuation (&first
);
3314 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3320 switch (SCM_TYP7 (proc
))
3322 case scm_tc7_subr_2o
:
3323 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3324 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3325 case scm_tc7_subr_2
:
3326 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3328 args
= SCM_CAR (args
);
3329 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3330 case scm_tc7_subr_0
:
3331 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3332 RETURN (SCM_SUBRF (proc
) ())
3333 case scm_tc7_subr_1
:
3334 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3335 case scm_tc7_subr_1o
:
3336 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3337 RETURN (SCM_SUBRF (proc
) (arg1
))
3339 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3340 if (SCM_SUBRF (proc
))
3342 if (SCM_INUMP (arg1
))
3344 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3346 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3347 if (SCM_REALP (arg1
))
3349 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3352 if (SCM_BIGP (arg1
))
3353 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3356 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3357 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3359 proc
= SCM_SNAME (proc
);
3361 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3362 while ('c' != *--chrs
)
3364 SCM_ASSERT (SCM_CONSP (arg1
),
3365 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3366 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3370 case scm_tc7_subr_3
:
3371 SCM_ASRTGO (SCM_NNULLP (args
)
3372 && SCM_NNULLP (SCM_CDR (args
))
3373 && SCM_NULLP (SCM_CDDR (args
)),
3375 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3378 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3380 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3382 case scm_tc7_lsubr_2
:
3383 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3384 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3386 if (SCM_NULLP (args
))
3387 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3388 while (SCM_NIMP (args
))
3390 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3391 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3392 args
= SCM_CDR (args
);
3395 case scm_tc7_rpsubr
:
3396 if (SCM_NULLP (args
))
3397 RETURN (SCM_BOOL_T
);
3398 while (SCM_NIMP (args
))
3400 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3401 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3402 RETURN (SCM_BOOL_F
);
3403 arg1
= SCM_CAR (args
);
3404 args
= SCM_CDR (args
);
3406 RETURN (SCM_BOOL_T
);
3407 case scm_tcs_closures
:
3409 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3411 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3413 #ifndef SCM_RECKLESS
3414 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3418 /* Copy argument list */
3423 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3424 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3426 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3430 SCM_SETCDR (tl
, arg1
);
3433 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3434 proc
= SCM_CDR (SCM_CODE (proc
));
3437 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3439 if (SCM_IMP (SCM_CAR (proc
)))
3441 if (SCM_ISYMP (SCM_CAR (proc
)))
3443 proc
= scm_m_expand_body (proc
, args
);
3448 SCM_CEVAL (SCM_CAR (proc
), args
);
3451 RETURN (EVALCAR (proc
, args
));
3453 if (!SCM_SMOB_APPLICABLE_P (proc
))
3455 if (SCM_UNBNDP (arg1
))
3456 RETURN (SCM_SMOB_APPLY_0 (proc
))
3457 else if (SCM_NULLP (args
))
3458 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3459 else if (SCM_NULLP (SCM_CDR (args
)))
3460 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3462 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3465 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3467 proc
= SCM_CCLO_SUBR (proc
);
3468 debug
.vect
[0].a
.proc
= proc
;
3469 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3471 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3473 proc
= SCM_CCLO_SUBR (proc
);
3477 proc
= SCM_PROCEDURE (proc
);
3479 debug
.vect
[0].a
.proc
= proc
;
3482 case scm_tcs_cons_gloc
:
3483 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3486 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3488 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3490 RETURN (scm_apply_generic (proc
, args
));
3492 else if (!SCM_I_OPERATORP (proc
))
3497 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3499 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3502 proc
= (SCM_I_ENTITYP (proc
)
3503 ? SCM_ENTITY_PROCEDURE (proc
)
3504 : SCM_OPERATOR_PROCEDURE (proc
));
3506 debug
.vect
[0].a
.proc
= proc
;
3507 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3509 if (SCM_NIMP (proc
))
3515 scm_wrong_num_args (proc
);
3518 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3523 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3524 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3526 SCM_CLEAR_TRACED_FRAME (debug
);
3527 if (SCM_CHEAPTRAPS_P
)
3528 arg1
= scm_make_debugobj (&debug
);
3532 SCM val
= scm_make_continuation (&first
);
3542 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3545 scm_last_debug_frame
= debug
.prev
;
3551 /* SECTION: The rest of this file is only read once.
3556 /* Typechecking for multi-argument MAP and FOR-EACH.
3558 Verify that each element of the vector ARGV, except for the first,
3559 is a proper list whose length is LEN. Attribute errors to WHO,
3560 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3562 check_map_args (SCM argv
,
3569 SCM
*ve
= SCM_VELTS (argv
);
3572 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3574 int elt_len
= scm_ilength (ve
[i
]);
3579 scm_apply_generic (gf
, scm_cons (proc
, args
));
3581 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3585 scm_out_of_range (who
, ve
[i
]);
3588 scm_remember_upto_here_1 (argv
);
3592 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3594 /* Note: Currently, scm_map applies PROC to the argument list(s)
3595 sequentially, starting with the first element(s). This is used in
3596 evalext.c where the Scheme procedure `map-in-order', which guarantees
3597 sequential behaviour, is implemented using scm_map. If the
3598 behaviour changes, we need to update `map-in-order'.
3602 scm_map (SCM proc
, SCM arg1
, SCM args
)
3603 #define FUNC_NAME s_map
3608 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3610 len
= scm_ilength (arg1
);
3611 SCM_GASSERTn (len
>= 0,
3612 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3613 SCM_VALIDATE_REST_ARGUMENT (args
);
3614 if (SCM_NULLP (args
))
3616 while (SCM_NIMP (arg1
))
3618 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3620 pres
= SCM_CDRLOC (*pres
);
3621 arg1
= SCM_CDR (arg1
);
3625 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3626 ve
= SCM_VELTS (args
);
3627 #ifndef SCM_RECKLESS
3628 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3633 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3635 if (SCM_IMP (ve
[i
]))
3637 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3638 ve
[i
] = SCM_CDR (ve
[i
]);
3640 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3641 pres
= SCM_CDRLOC (*pres
);
3647 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3650 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3651 #define FUNC_NAME s_for_each
3653 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3655 len
= scm_ilength (arg1
);
3656 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3657 SCM_ARG2
, s_for_each
);
3658 SCM_VALIDATE_REST_ARGUMENT (args
);
3661 while SCM_NIMP (arg1
)
3663 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3664 arg1
= SCM_CDR (arg1
);
3666 return SCM_UNSPECIFIED
;
3668 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3669 ve
= SCM_VELTS (args
);
3670 #ifndef SCM_RECKLESS
3671 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3676 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3679 (ve
[i
]) return SCM_UNSPECIFIED
;
3680 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3681 ve
[i
] = SCM_CDR (ve
[i
]);
3683 scm_apply (proc
, arg1
, SCM_EOL
);
3690 scm_closure (SCM code
, SCM env
)
3694 SCM_SETCODE (z
, code
);
3695 SCM_SETENV (z
, env
);
3700 scm_bits_t scm_tc16_promise
;
3703 scm_makprom (SCM code
)
3705 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3711 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3713 int writingp
= SCM_WRITINGP (pstate
);
3714 scm_puts ("#<promise ", port
);
3715 SCM_SET_WRITINGP (pstate
, 1);
3716 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3717 SCM_SET_WRITINGP (pstate
, writingp
);
3718 scm_putc ('>', port
);
3723 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3725 "If the promise X has not been computed yet, compute and return\n"
3726 "X, otherwise just return the previously computed value.")
3727 #define FUNC_NAME s_scm_force
3729 SCM_VALIDATE_SMOB (1, x
, promise
);
3730 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3732 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3733 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3736 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3737 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3741 return SCM_CELL_OBJECT_1 (x
);
3746 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3748 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3749 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3750 #define FUNC_NAME s_scm_promise_p
3752 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, x
));
3757 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3758 (SCM xorig
, SCM x
, SCM y
),
3759 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3760 "Any source properties associated with @var{xorig} are also associated\n"
3761 "with the new pair.")
3762 #define FUNC_NAME s_scm_cons_source
3766 SCM_SET_CELL_OBJECT_0 (z
, x
);
3767 SCM_SET_CELL_OBJECT_1 (z
, y
);
3768 /* Copy source properties possibly associated with xorig. */
3769 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3771 scm_whash_insert (scm_source_whash
, z
, p
);
3777 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3779 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3780 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3781 "contents of both pairs and vectors (since both cons cells and vector\n"
3782 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3783 "any other object.")
3784 #define FUNC_NAME s_scm_copy_tree
3789 if (SCM_VECTORP (obj
))
3791 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3792 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3794 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3797 if (SCM_NCONSP (obj
))
3799 ans
= tl
= scm_cons_source (obj
,
3800 scm_copy_tree (SCM_CAR (obj
)),
3802 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3804 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3808 SCM_SETCDR (tl
, obj
);
3814 /* We have three levels of EVAL here:
3816 - scm_i_eval (exp, env)
3818 evaluates EXP in environment ENV. ENV is a lexical environment
3819 structure as used by the actual tree code evaluator. When ENV is
3820 a top-level environment, then changes to the current module are
3821 tracked by modifying ENV so that it continues to be in sync with
3824 - scm_primitive_eval (exp)
3826 evaluates EXP in the top-level environment as determined by the
3827 current module. This is done by constructing a suitable
3828 environment and calling scm_i_eval. Thus, changes to the
3829 top-level module are tracked normally.
3831 - scm_eval (exp, mod)
3833 evaluates EXP while MOD is the current module. Thius is done by
3834 setting the current module to MOD, invoking scm_primitive_eval on
3835 EXP, and then restoring the current module to the value it had
3836 previously. That is, while EXP is evaluated, changes to the
3837 current module are tracked, but these changes do not persist when
3840 For each level of evals, there are two variants, distinguished by a
3841 _x suffix: the ordinary variant does not modify EXP while the _x
3842 variant can destructively modify EXP into something completely
3843 unintelligible. A Scheme data structure passed as EXP to one of the
3844 _x variants should not ever be used again for anything. So when in
3845 doubt, use the ordinary variant.
3849 SCM scm_system_transformer
;
3851 /* XXX - scm_i_eval is meant to be useable for evaluation in
3852 non-toplevel environments, for example when used by the debugger.
3853 Can the system transform deal with this? */
3856 scm_i_eval_x (SCM exp
, SCM env
)
3858 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3859 if (SCM_NIMP (transformer
))
3860 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3861 return SCM_XEVAL (exp
, env
);
3865 scm_i_eval (SCM exp
, SCM env
)
3867 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3868 if (SCM_NIMP (transformer
))
3869 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3870 exp
= scm_copy_tree (exp
);
3871 return SCM_XEVAL (exp
, env
);
3875 scm_primitive_eval_x (SCM exp
)
3877 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3878 return scm_i_eval_x (exp
, env
);
3881 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3883 "Evaluate @var{exp} in the top-level environment specified by\n"
3884 "the current module.")
3885 #define FUNC_NAME s_scm_primitive_eval
3887 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3888 return scm_i_eval (exp
, env
);
3892 /* Eval does not take the second arg optionally. This is intentional
3893 * in order to be R5RS compatible, and to prepare for the new module
3894 * system, where we would like to make the choice of evaluation
3895 * environment explicit. */
3898 change_environment (void *data
)
3900 SCM pair
= SCM_PACK (data
);
3901 SCM new_module
= SCM_CAR (pair
);
3902 SCM old_module
= scm_current_module ();
3903 SCM_SETCDR (pair
, old_module
);
3904 scm_set_current_module (new_module
);
3909 restore_environment (void *data
)
3911 SCM pair
= SCM_PACK (data
);
3912 SCM old_module
= SCM_CDR (pair
);
3913 SCM new_module
= scm_current_module ();
3914 SCM_SETCAR (pair
, new_module
);
3915 scm_set_current_module (old_module
);
3919 inner_eval_x (void *data
)
3921 return scm_primitive_eval_x (SCM_PACK(data
));
3925 scm_eval_x (SCM exp
, SCM module
)
3926 #define FUNC_NAME "eval!"
3928 SCM_VALIDATE_MODULE (2, module
);
3930 return scm_internal_dynamic_wind
3931 (change_environment
, inner_eval_x
, restore_environment
,
3932 (void *) SCM_UNPACK (exp
),
3933 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3938 inner_eval (void *data
)
3940 return scm_primitive_eval (SCM_PACK(data
));
3943 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3944 (SCM exp
, SCM module
),
3945 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3946 "in the top-level environment specified by @var{module}.\n"
3947 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
3948 "@var{module} is made the current module. The current module\n"
3949 "is reset to its previous value when @var{eval} returns.")
3950 #define FUNC_NAME s_scm_eval
3952 SCM_VALIDATE_MODULE (2, module
);
3954 return scm_internal_dynamic_wind
3955 (change_environment
, inner_eval
, restore_environment
,
3956 (void *) SCM_UNPACK (exp
),
3957 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3961 #if (SCM_DEBUG_DEPRECATED == 0)
3963 /* Use scm_current_module () or scm_interaction_environment ()
3964 * instead. The former is the module selected during loading of code.
3965 * The latter is the module in which the user of this thread currently
3966 * types expressions.
3969 SCM scm_top_level_lookup_closure_var
;
3971 /* Avoid using this functionality altogether (except for implementing
3972 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3974 * Applications should use either C level scm_eval_x or Scheme
3975 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
3978 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3981 return scm_i_eval (obj
, env
);
3983 return scm_i_eval_x (obj
, env
);
3986 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3987 (SCM obj
, SCM env_thunk
),
3988 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
3989 "designated by @var{lookup}, a symbol-lookup function."
3990 "Do not use this version of eval, it does not play well\n"
3991 "with the module system. Use @code{eval} or\n"
3992 "@code{primitive-eval} instead.")
3993 #define FUNC_NAME s_scm_eval2
3995 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3999 #endif /* DEPRECATED */
4002 /* At this point, scm_deval and scm_dapply are generated.
4005 #ifdef DEBUG_EXTENSIONS
4015 scm_init_opts (scm_evaluator_traps
,
4016 scm_evaluator_trap_table
,
4017 SCM_N_EVALUATOR_TRAPS
);
4018 scm_init_opts (scm_eval_options_interface
,
4020 SCM_N_EVAL_OPTIONS
);
4022 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4023 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4024 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4026 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4027 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
4030 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
4031 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
4032 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
4033 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
4034 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
4035 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
4040 #if SCM_DEBUG_DEPRECATED == 0
4041 scm_top_level_lookup_closure_var
=
4042 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
4045 #ifndef SCM_MAGIC_SNARFER
4046 #include "libguile/eval.x"
4049 scm_add_feature ("delay");