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,
1676 #define FUNC_NAME s_scm_eval_options_interface
1680 ans
= scm_options (setting
,
1684 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1690 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1693 #define FUNC_NAME s_scm_evaluator_traps
1697 ans
= scm_options (setting
,
1698 scm_evaluator_trap_table
,
1699 SCM_N_EVALUATOR_TRAPS
,
1701 SCM_RESET_DEBUG_MODE
;
1708 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1710 SCM
*results
= lloc
, res
;
1711 while (SCM_NIMP (l
))
1716 if (SCM_IMP (SCM_CAR (l
)))
1717 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1719 res
= EVALCELLCAR (l
, env
);
1721 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1723 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1725 res
= SCM_CAR (l
); /* struct planted in code */
1727 res
= SCM_PACK (vcell
);
1732 res
= EVALCAR (l
, env
);
1734 *lloc
= scm_cons (res
, SCM_EOL
);
1735 lloc
= SCM_CDRLOC (*lloc
);
1742 scm_wrong_num_args (proc
);
1751 /* SECTION: Some local definitions for the evaluator.
1755 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1758 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1760 /* SECTION: This is the evaluator. Like any real monster, it has
1761 * three heads. This code is compiled twice.
1767 scm_ceval (SCM x
, SCM env
)
1773 scm_deval (SCM x
, SCM env
)
1778 SCM_CEVAL (SCM x
, SCM env
)
1787 scm_debug_frame debug
;
1788 scm_debug_info
*debug_info_end
;
1789 debug
.prev
= scm_last_debug_frame
;
1790 debug
.status
= scm_debug_eframe_size
;
1792 * The debug.vect contains twice as much scm_debug_info frames as the
1793 * user has specified with (debug-set! frames <n>).
1795 * Even frames are eval frames, odd frames are apply frames.
1797 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1798 * sizeof (debug
.vect
[0]));
1799 debug
.info
= debug
.vect
;
1800 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1801 scm_last_debug_frame
= &debug
;
1803 #ifdef EVAL_STACK_CHECKING
1804 if (scm_stack_checking_enabled_p
1805 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1808 debug
.info
->e
.exp
= x
;
1809 debug
.info
->e
.env
= env
;
1811 scm_report_stack_overflow ();
1818 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1821 SCM_CLEAR_ARGSREADY (debug
);
1822 if (SCM_OVERFLOWP (debug
))
1825 * In theory, this should be the only place where it is necessary to
1826 * check for space in debug.vect since both eval frames and
1827 * available space are even.
1829 * For this to be the case, however, it is necessary that primitive
1830 * special forms which jump back to `loop', `begin' or some similar
1831 * label call PREP_APPLY. A convenient way to do this is to jump to
1832 * `loopnoap' or `cdrxnoap'.
1834 else if (++debug
.info
>= debug_info_end
)
1836 SCM_SET_OVERFLOW (debug
);
1840 debug
.info
->e
.exp
= x
;
1841 debug
.info
->e
.env
= env
;
1842 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1843 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1845 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1846 SCM_SET_TAILREC (debug
);
1847 if (SCM_CHEAPTRAPS_P
)
1848 t
.arg1
= scm_make_debugobj (&debug
);
1852 SCM val
= scm_make_continuation (&first
);
1864 /* This gives the possibility for the debugger to
1865 modify the source expression before evaluation. */
1869 scm_ithrow (scm_sym_enter_frame
,
1870 scm_cons2 (t
.arg1
, tail
,
1871 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1875 #if defined (USE_THREADS) || defined (DEVAL)
1879 switch (SCM_TYP7 (x
))
1881 case scm_tc7_symbol
:
1882 /* Only happens when called at top level.
1884 x
= scm_cons (x
, SCM_UNDEFINED
);
1887 case SCM_BIT8(SCM_IM_AND
):
1890 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1891 if (SCM_FALSEP (EVALCAR (x
, env
)))
1893 RETURN (SCM_BOOL_F
);
1897 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1900 case SCM_BIT8(SCM_IM_BEGIN
):
1902 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1908 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1910 if (SCM_IMP (SCM_CAR (x
)))
1912 if (SCM_ISYMP (SCM_CAR (x
)))
1914 x
= scm_m_expand_body (x
, env
);
1919 SCM_CEVAL (SCM_CAR (x
), env
);
1923 carloop
: /* scm_eval car of last form in list */
1924 if (SCM_NCELLP (SCM_CAR (x
)))
1927 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1930 if (SCM_SYMBOLP (SCM_CAR (x
)))
1933 RETURN (*scm_lookupcar (x
, env
, 1))
1937 goto loop
; /* tail recurse */
1940 case SCM_BIT8(SCM_IM_CASE
):
1942 t
.arg1
= EVALCAR (x
, env
);
1943 while (SCM_NIMP (x
= SCM_CDR (x
)))
1946 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1949 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1952 proc
= SCM_CAR (proc
);
1953 while (SCM_NIMP (proc
))
1955 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1957 x
= SCM_CDR (SCM_CAR (x
));
1958 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1961 proc
= SCM_CDR (proc
);
1964 RETURN (SCM_UNSPECIFIED
)
1967 case SCM_BIT8(SCM_IM_COND
):
1968 while (SCM_NIMP (x
= SCM_CDR (x
)))
1971 t
.arg1
= EVALCAR (proc
, env
);
1972 if (SCM_NFALSEP (t
.arg1
))
1979 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
1981 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1985 proc
= EVALCAR (proc
, env
);
1986 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1987 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1992 RETURN (SCM_UNSPECIFIED
)
1995 case SCM_BIT8(SCM_IM_DO
):
1997 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1998 t
.arg1
= SCM_EOL
; /* values */
1999 while (SCM_NIMP (proc
))
2001 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2002 proc
= SCM_CDR (proc
);
2004 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2005 x
= SCM_CDR (SCM_CDR (x
));
2006 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2008 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2010 t
.arg1
= SCM_CAR (proc
); /* body */
2011 SIDEVAL (t
.arg1
, env
);
2013 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2015 proc
= SCM_CDR (proc
))
2016 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2017 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2021 RETURN (SCM_UNSPECIFIED
);
2022 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2026 case SCM_BIT8(SCM_IM_IF
):
2028 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2030 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2032 RETURN (SCM_UNSPECIFIED
);
2034 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2038 case SCM_BIT8(SCM_IM_LET
):
2040 proc
= SCM_CAR (SCM_CDR (x
));
2044 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2046 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2047 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2052 case SCM_BIT8(SCM_IM_LETREC
):
2054 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2060 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2062 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2063 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2067 case SCM_BIT8(SCM_IM_LETSTAR
):
2072 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2077 t
.arg1
= SCM_CAR (proc
);
2078 proc
= SCM_CDR (proc
);
2079 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2081 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2084 case SCM_BIT8(SCM_IM_OR
):
2087 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2089 x
= EVALCAR (x
, env
);
2090 if (SCM_NFALSEP (x
))
2096 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2100 case SCM_BIT8(SCM_IM_LAMBDA
):
2101 RETURN (scm_closure (SCM_CDR (x
), env
));
2104 case SCM_BIT8(SCM_IM_QUOTE
):
2105 RETURN (SCM_CAR (SCM_CDR (x
)));
2108 case SCM_BIT8(SCM_IM_SET_X
):
2111 switch (SCM_ITAG3 (proc
))
2114 t
.lloc
= scm_lookupcar (x
, env
, 1);
2116 case scm_tc3_cons_gloc
:
2117 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2119 #ifdef MEMOIZE_LOCALS
2121 t
.lloc
= scm_ilookup (proc
, env
);
2126 *t
.lloc
= EVALCAR (x
, env
);
2130 RETURN (SCM_UNSPECIFIED
);
2134 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2135 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2137 /* new syntactic forms go here. */
2138 case SCM_BIT8(SCM_MAKISYM (0)):
2140 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2141 switch SCM_ISYMNUM (proc
)
2143 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2145 proc
= EVALCAR (proc
, env
);
2146 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2147 if (SCM_CLOSUREP (proc
))
2150 PREP_APPLY (proc
, SCM_EOL
);
2151 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2152 t
.arg1
= EVALCAR (t
.arg1
, env
);
2154 debug
.info
->a
.args
= t
.arg1
;
2156 #ifndef SCM_RECKLESS
2157 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2161 /* Copy argument list */
2162 if (SCM_IMP (t
.arg1
))
2166 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2167 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2168 && SCM_CONSP (t
.arg1
))
2170 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2174 SCM_SETCDR (tl
, t
.arg1
);
2177 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2178 x
= SCM_CODE (proc
);
2184 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2187 SCM val
= scm_make_continuation (&first
);
2195 proc
= evalcar (proc
, env
);
2196 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2197 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2201 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2202 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2204 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2205 proc
= SCM_CADR (x
); /* unevaluated operands */
2206 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2208 arg2
= *scm_ilookup (proc
, env
);
2209 else if (SCM_NCONSP (proc
))
2211 if (SCM_NCELLP (proc
))
2212 arg2
= SCM_GLOC_VAL (proc
);
2214 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2218 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2219 t
.lloc
= SCM_CDRLOC (arg2
);
2220 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2222 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2223 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2228 /* The type dispatch code is duplicated here
2229 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2230 * cuts down execution time for type dispatch to 50%.
2233 int i
, n
, end
, mask
;
2234 SCM z
= SCM_CDDR (x
);
2235 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2236 proc
= SCM_CADR (z
);
2238 if (SCM_NIMP (proc
))
2240 /* Prepare for linear search */
2243 end
= SCM_VECTOR_LENGTH (proc
);
2247 /* Compute a hash value */
2248 int hashset
= SCM_INUM (proc
);
2250 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2251 proc
= SCM_CADR (z
);
2254 if (SCM_NIMP (t
.arg1
))
2257 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2258 [scm_si_hashsets
+ hashset
];
2259 t
.arg1
= SCM_CDR (t
.arg1
);
2261 while (j
-- && SCM_NIMP (t
.arg1
));
2266 /* Search for match */
2270 z
= SCM_VELTS (proc
)[i
];
2271 t
.arg1
= arg2
; /* list of arguments */
2272 if (SCM_NIMP (t
.arg1
))
2275 /* More arguments than specifiers => CLASS != ENV */
2276 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2278 t
.arg1
= SCM_CDR (t
.arg1
);
2281 while (j
-- && SCM_NIMP (t
.arg1
));
2282 /* Fewer arguments than specifiers => CAR != ENV */
2283 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2286 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2288 SCM_CMETHOD_ENV (z
));
2289 x
= SCM_CMETHOD_CODE (z
);
2295 z
= scm_memoize_method (x
, arg2
);
2299 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2301 t
.arg1
= EVALCAR (x
, env
);
2302 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2304 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2306 t
.arg1
= EVALCAR (x
, env
);
2309 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2310 = SCM_UNPACK (EVALCAR (proc
, env
));
2311 RETURN (SCM_UNSPECIFIED
)
2313 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2315 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2317 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2318 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2320 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2322 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2328 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2331 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2333 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2337 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2339 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2341 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2343 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2345 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2346 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2348 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2350 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2356 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2359 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2361 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2365 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2367 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2371 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2374 t
.arg1
= SCM_CAR (x
);
2375 arg2
= SCM_CDAR (env
);
2376 while (SCM_NIMP (arg2
))
2378 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2379 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2381 SCM_SETCAR (arg2
, proc
);
2382 t
.arg1
= SCM_CDR (t
.arg1
);
2383 arg2
= SCM_CDR (arg2
);
2385 t
.arg1
= SCM_CAR (x
);
2386 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2388 arg2
= x
= SCM_CDR (x
);
2389 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2391 SIDEVAL (SCM_CAR (x
), env
);
2394 proc
= EVALCAR (x
, env
);
2396 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2397 arg2
= SCM_CDAR (env
);
2398 while (SCM_NIMP (arg2
))
2400 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2402 t
.arg1
= SCM_CDR (t
.arg1
);
2403 arg2
= SCM_CDR (arg2
);
2415 /* scm_everr (x, env,...) */
2416 scm_misc_error (NULL
,
2417 "Wrong type to apply: ~S",
2418 scm_listify (proc
, SCM_UNDEFINED
));
2419 case scm_tc7_vector
:
2423 case scm_tc7_byvect
:
2430 #ifdef HAVE_LONG_LONGS
2431 case scm_tc7_llvect
:
2434 case scm_tc7_string
:
2435 case scm_tc7_substring
:
2437 case scm_tcs_closures
:
2443 #ifdef MEMOIZE_LOCALS
2444 case SCM_BIT8(SCM_ILOC00
):
2445 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2446 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2447 #ifndef SCM_RECKLESS
2453 #endif /* ifdef MEMOIZE_LOCALS */
2456 case scm_tcs_cons_gloc
: {
2457 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2459 /* This is a struct implanted in the code, not a gloc. */
2462 proc
= SCM_PACK (vcell
);
2463 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2464 #ifndef SCM_RECKLESS
2473 case scm_tcs_cons_nimcar
:
2474 if (SCM_SYMBOLP (SCM_CAR (x
)))
2477 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2480 /* we have lost the race, start again. */
2485 proc
= *scm_lookupcar (x
, env
, 1);
2493 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2499 /* Set a flag during macro expansion so that macro
2500 application frames can be deleted from the backtrace. */
2501 SCM_SET_MACROEXP (debug
);
2503 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2504 scm_cons (env
, scm_listofnull
));
2507 SCM_CLEAR_MACROEXP (debug
);
2509 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2512 if (scm_ilength (t
.arg1
) <= 0)
2513 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2515 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2518 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2519 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2523 /* Prevent memoizing of debug info expression. */
2524 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2529 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2530 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2534 if (SCM_NIMP (x
= t
.arg1
))
2542 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2543 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2544 #ifndef SCM_RECKLESS
2548 if (SCM_CLOSUREP (proc
))
2550 arg2
= SCM_CAR (SCM_CODE (proc
));
2551 t
.arg1
= SCM_CDR (x
);
2552 while (SCM_NIMP (arg2
))
2554 if (SCM_NCONSP (arg2
))
2556 if (SCM_IMP (t
.arg1
))
2557 goto umwrongnumargs
;
2558 arg2
= SCM_CDR (arg2
);
2559 t
.arg1
= SCM_CDR (t
.arg1
);
2561 if (SCM_NNULLP (t
.arg1
))
2562 goto umwrongnumargs
;
2564 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2565 goto handle_a_macro
;
2571 PREP_APPLY (proc
, SCM_EOL
);
2572 if (SCM_NULLP (SCM_CDR (x
))) {
2575 switch (SCM_TYP7 (proc
))
2576 { /* no arguments given */
2577 case scm_tc7_subr_0
:
2578 RETURN (SCM_SUBRF (proc
) ());
2579 case scm_tc7_subr_1o
:
2580 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2582 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2583 case scm_tc7_rpsubr
:
2584 RETURN (SCM_BOOL_T
);
2586 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2588 if (!SCM_SMOB_APPLICABLE_P (proc
))
2590 RETURN (SCM_SMOB_APPLY_0 (proc
));
2593 proc
= SCM_CCLO_SUBR (proc
);
2595 debug
.info
->a
.proc
= proc
;
2596 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2600 proc
= SCM_PROCEDURE (proc
);
2602 debug
.info
->a
.proc
= proc
;
2604 if (!SCM_CLOSUREP (proc
))
2606 if (scm_badformalsp (proc
, 0))
2607 goto umwrongnumargs
;
2608 case scm_tcs_closures
:
2609 x
= SCM_CODE (proc
);
2610 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2612 case scm_tcs_cons_gloc
:
2613 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2615 x
= SCM_ENTITY_PROCEDURE (proc
);
2619 else if (!SCM_I_OPERATORP (proc
))
2624 proc
= (SCM_I_ENTITYP (proc
)
2625 ? SCM_ENTITY_PROCEDURE (proc
)
2626 : SCM_OPERATOR_PROCEDURE (proc
));
2628 debug
.info
->a
.proc
= proc
;
2629 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2631 if (SCM_NIMP (proc
))
2636 case scm_tc7_subr_1
:
2637 case scm_tc7_subr_2
:
2638 case scm_tc7_subr_2o
:
2640 case scm_tc7_subr_3
:
2641 case scm_tc7_lsubr_2
:
2645 /* scm_everr (x, env,...) */
2646 scm_wrong_num_args (proc
);
2648 /* handle macros here */
2653 /* must handle macros by here */
2658 else if (SCM_CONSP (x
))
2660 if (SCM_IMP (SCM_CAR (x
)))
2661 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2663 t
.arg1
= EVALCELLCAR (x
, env
);
2665 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2667 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2669 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2671 t
.arg1
= SCM_PACK (vcell
);
2676 t
.arg1
= EVALCAR (x
, env
);
2679 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2686 switch (SCM_TYP7 (proc
))
2687 { /* have one argument in t.arg1 */
2688 case scm_tc7_subr_2o
:
2689 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2690 case scm_tc7_subr_1
:
2691 case scm_tc7_subr_1o
:
2692 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2694 if (SCM_SUBRF (proc
))
2696 if (SCM_INUMP (t
.arg1
))
2698 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2700 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2701 if (SCM_REALP (t
.arg1
))
2703 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2706 if (SCM_BIGP (t
.arg1
))
2708 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2712 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2713 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2715 proc
= SCM_SNAME (proc
);
2717 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2718 while ('c' != *--chrs
)
2720 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2721 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2722 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2726 case scm_tc7_rpsubr
:
2727 RETURN (SCM_BOOL_T
);
2729 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2732 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2734 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2737 if (!SCM_SMOB_APPLICABLE_P (proc
))
2739 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2743 proc
= SCM_CCLO_SUBR (proc
);
2745 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2746 debug
.info
->a
.proc
= proc
;
2750 proc
= SCM_PROCEDURE (proc
);
2752 debug
.info
->a
.proc
= proc
;
2754 if (!SCM_CLOSUREP (proc
))
2756 if (scm_badformalsp (proc
, 1))
2757 goto umwrongnumargs
;
2758 case scm_tcs_closures
:
2760 x
= SCM_CODE (proc
);
2762 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2764 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2767 case scm_tcs_cons_gloc
:
2768 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2770 x
= SCM_ENTITY_PROCEDURE (proc
);
2772 arg2
= debug
.info
->a
.args
;
2774 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2778 else if (!SCM_I_OPERATORP (proc
))
2784 proc
= (SCM_I_ENTITYP (proc
)
2785 ? SCM_ENTITY_PROCEDURE (proc
)
2786 : SCM_OPERATOR_PROCEDURE (proc
));
2788 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2789 debug
.info
->a
.proc
= proc
;
2791 if (SCM_NIMP (proc
))
2796 case scm_tc7_subr_2
:
2797 case scm_tc7_subr_0
:
2798 case scm_tc7_subr_3
:
2799 case scm_tc7_lsubr_2
:
2808 else if (SCM_CONSP (x
))
2810 if (SCM_IMP (SCM_CAR (x
)))
2811 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2813 arg2
= EVALCELLCAR (x
, env
);
2815 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2817 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2819 arg2
= SCM_CAR (x
); /* struct planted in code */
2821 arg2
= SCM_PACK (vcell
);
2826 arg2
= EVALCAR (x
, env
);
2828 { /* have two or more arguments */
2830 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2833 if (SCM_NULLP (x
)) {
2836 switch (SCM_TYP7 (proc
))
2837 { /* have two arguments */
2838 case scm_tc7_subr_2
:
2839 case scm_tc7_subr_2o
:
2840 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2843 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2845 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2847 case scm_tc7_lsubr_2
:
2848 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2849 case scm_tc7_rpsubr
:
2851 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2853 if (!SCM_SMOB_APPLICABLE_P (proc
))
2855 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2859 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2860 scm_cons (proc
, debug
.info
->a
.args
),
2863 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2864 scm_cons2 (proc
, t
.arg1
,
2871 case scm_tcs_cons_gloc
:
2872 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2874 x
= SCM_ENTITY_PROCEDURE (proc
);
2876 arg2
= debug
.info
->a
.args
;
2878 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2882 else if (!SCM_I_OPERATORP (proc
))
2888 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2889 ? SCM_ENTITY_PROCEDURE (proc
)
2890 : SCM_OPERATOR_PROCEDURE (proc
),
2891 scm_cons (proc
, debug
.info
->a
.args
),
2894 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2895 ? SCM_ENTITY_PROCEDURE (proc
)
2896 : SCM_OPERATOR_PROCEDURE (proc
),
2897 scm_cons2 (proc
, t
.arg1
,
2905 case scm_tc7_subr_0
:
2907 case scm_tc7_subr_1o
:
2908 case scm_tc7_subr_1
:
2909 case scm_tc7_subr_3
:
2914 proc
= SCM_PROCEDURE (proc
);
2916 debug
.info
->a
.proc
= proc
;
2918 if (!SCM_CLOSUREP (proc
))
2920 if (scm_badformalsp (proc
, 2))
2921 goto umwrongnumargs
;
2922 case scm_tcs_closures
:
2925 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2929 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2930 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2932 x
= SCM_CODE (proc
);
2937 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2941 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2942 scm_deval_args (x
, env
, proc
,
2943 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2947 switch (SCM_TYP7 (proc
))
2948 { /* have 3 or more arguments */
2950 case scm_tc7_subr_3
:
2951 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2952 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2953 SCM_CADDR (debug
.info
->a
.args
)));
2955 #ifdef BUILTIN_RPASUBR
2956 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2957 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2960 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2961 arg2
= SCM_CDR (arg2
);
2963 while (SCM_NIMP (arg2
));
2965 #endif /* BUILTIN_RPASUBR */
2966 case scm_tc7_rpsubr
:
2967 #ifdef BUILTIN_RPASUBR
2968 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2970 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2973 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2975 arg2
= SCM_CAR (t
.arg1
);
2976 t
.arg1
= SCM_CDR (t
.arg1
);
2978 while (SCM_NIMP (t
.arg1
));
2980 #else /* BUILTIN_RPASUBR */
2981 RETURN (SCM_APPLY (proc
, t
.arg1
,
2983 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
2985 #endif /* BUILTIN_RPASUBR */
2986 case scm_tc7_lsubr_2
:
2987 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2988 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2990 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2992 if (!SCM_SMOB_APPLICABLE_P (proc
))
2994 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
2995 SCM_CDDR (debug
.info
->a
.args
)));
2999 proc
= SCM_PROCEDURE (proc
);
3000 debug
.info
->a
.proc
= proc
;
3001 if (!SCM_CLOSUREP (proc
))
3003 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3004 goto umwrongnumargs
;
3005 case scm_tcs_closures
:
3006 SCM_SET_ARGSREADY (debug
);
3007 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3010 x
= SCM_CODE (proc
);
3013 case scm_tc7_subr_3
:
3014 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3015 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3017 #ifdef BUILTIN_RPASUBR
3018 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3021 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3024 while (SCM_NIMP (x
));
3026 #endif /* BUILTIN_RPASUBR */
3027 case scm_tc7_rpsubr
:
3028 #ifdef BUILTIN_RPASUBR
3029 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3033 t
.arg1
= EVALCAR (x
, env
);
3034 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3039 while (SCM_NIMP (x
));
3041 #else /* BUILTIN_RPASUBR */
3042 RETURN (SCM_APPLY (proc
, t
.arg1
,
3044 scm_eval_args (x
, env
, proc
),
3046 #endif /* BUILTIN_RPASUBR */
3047 case scm_tc7_lsubr_2
:
3048 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3050 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3052 scm_eval_args (x
, env
, proc
))));
3054 if (!SCM_SMOB_APPLICABLE_P (proc
))
3056 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3057 scm_eval_args (x
, env
, proc
)));
3061 proc
= SCM_PROCEDURE (proc
);
3062 if (!SCM_CLOSUREP (proc
))
3065 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3066 if (SCM_NULLP (formals
)
3067 || (SCM_CONSP (formals
)
3068 && (SCM_NULLP (SCM_CDR (formals
))
3069 || (SCM_CONSP (SCM_CDR (formals
))
3070 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3071 goto umwrongnumargs
;
3073 case scm_tcs_closures
:
3075 SCM_SET_ARGSREADY (debug
);
3077 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3080 scm_eval_args (x
, env
, proc
)),
3082 x
= SCM_CODE (proc
);
3085 case scm_tcs_cons_gloc
:
3086 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3089 arg2
= debug
.info
->a
.args
;
3091 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3093 x
= SCM_ENTITY_PROCEDURE (proc
);
3096 else if (!SCM_I_OPERATORP (proc
))
3100 case scm_tc7_subr_2
:
3101 case scm_tc7_subr_1o
:
3102 case scm_tc7_subr_2o
:
3103 case scm_tc7_subr_0
:
3105 case scm_tc7_subr_1
:
3113 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3114 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3116 SCM_CLEAR_TRACED_FRAME (debug
);
3117 if (SCM_CHEAPTRAPS_P
)
3118 t
.arg1
= scm_make_debugobj (&debug
);
3122 SCM val
= scm_make_continuation (&first
);
3132 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3135 scm_last_debug_frame
= debug
.prev
;
3141 /* SECTION: This code is compiled once.
3146 /* This code processes the arguments to apply:
3148 (apply PROC ARG1 ... ARGS)
3150 Given a list (ARG1 ... ARGS), this function conses the ARG1
3151 ... arguments onto the front of ARGS, and returns the resulting
3152 list. Note that ARGS is a list; thus, the argument to this
3153 function is a list whose last element is a list.
3155 Apply calls this function, and applies PROC to the elements of the
3156 result. apply:nconc2last takes care of building the list of
3157 arguments, given (ARG1 ... ARGS).
3159 Rather than do new consing, apply:nconc2last destroys its argument.
3160 On that topic, this code came into my care with the following
3161 beautifully cryptic comment on that topic: "This will only screw
3162 you if you do (scm_apply scm_apply '( ... ))" If you know what
3163 they're referring to, send me a patch to this comment. */
3165 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3168 #define FUNC_NAME s_scm_nconc2last
3171 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3173 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3174 lloc
= SCM_CDRLOC (*lloc
);
3175 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3176 *lloc
= SCM_CAR (*lloc
);
3184 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3185 * It is compiled twice.
3191 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3198 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3203 /* Apply a function to a list of arguments.
3205 This function is exported to the Scheme level as taking two
3206 required arguments and a tail argument, as if it were:
3207 (lambda (proc arg1 . args) ...)
3208 Thus, if you just have a list of arguments to pass to a procedure,
3209 pass the list as ARG1, and '() for ARGS. If you have some fixed
3210 args, pass the first as ARG1, then cons any remaining fixed args
3211 onto the front of your argument list, and pass that as ARGS. */
3214 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3216 #ifdef DEBUG_EXTENSIONS
3218 scm_debug_frame debug
;
3219 scm_debug_info debug_vect_body
;
3220 debug
.prev
= scm_last_debug_frame
;
3221 debug
.status
= SCM_APPLYFRAME
;
3222 debug
.vect
= &debug_vect_body
;
3223 debug
.vect
[0].a
.proc
= proc
;
3224 debug
.vect
[0].a
.args
= SCM_EOL
;
3225 scm_last_debug_frame
= &debug
;
3228 return scm_dapply (proc
, arg1
, args
);
3232 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3234 /* If ARGS is the empty list, then we're calling apply with only two
3235 arguments --- ARG1 is the list of arguments for PROC. Whatever
3236 the case, futz with things so that ARG1 is the first argument to
3237 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3240 Setting the debug apply frame args this way is pretty messy.
3241 Perhaps we should store arg1 and args directly in the frame as
3242 received, and let scm_frame_arguments unpack them, because that's
3243 a relatively rare operation. This works for now; if the Guile
3244 developer archives are still around, see Mikael's post of
3246 if (SCM_NULLP (args
))
3248 if (SCM_NULLP (arg1
))
3250 arg1
= SCM_UNDEFINED
;
3252 debug
.vect
[0].a
.args
= SCM_EOL
;
3258 debug
.vect
[0].a
.args
= arg1
;
3260 args
= SCM_CDR (arg1
);
3261 arg1
= SCM_CAR (arg1
);
3266 args
= scm_nconc2last (args
);
3268 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3272 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3275 if (SCM_CHEAPTRAPS_P
)
3276 tmp
= scm_make_debugobj (&debug
);
3281 tmp
= scm_make_continuation (&first
);
3285 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3291 switch (SCM_TYP7 (proc
))
3293 case scm_tc7_subr_2o
:
3294 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3295 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3296 case scm_tc7_subr_2
:
3297 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3299 args
= SCM_CAR (args
);
3300 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3301 case scm_tc7_subr_0
:
3302 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3303 RETURN (SCM_SUBRF (proc
) ())
3304 case scm_tc7_subr_1
:
3305 case scm_tc7_subr_1o
:
3306 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3307 RETURN (SCM_SUBRF (proc
) (arg1
))
3309 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3310 if (SCM_SUBRF (proc
))
3312 if (SCM_INUMP (arg1
))
3314 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3316 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3317 if (SCM_REALP (arg1
))
3319 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3322 if (SCM_BIGP (arg1
))
3323 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3326 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3327 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3329 proc
= SCM_SNAME (proc
);
3331 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3332 while ('c' != *--chrs
)
3334 SCM_ASSERT (SCM_CONSP (arg1
),
3335 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3336 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3340 case scm_tc7_subr_3
:
3341 SCM_ASRTGO (SCM_NNULLP (args
)
3342 && SCM_NNULLP (SCM_CDR (args
))
3343 && SCM_NULLP (SCM_CDDR (args
)),
3345 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3348 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3350 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3352 case scm_tc7_lsubr_2
:
3353 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3354 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3356 if (SCM_NULLP (args
))
3357 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3358 while (SCM_NIMP (args
))
3360 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3361 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3362 args
= SCM_CDR (args
);
3365 case scm_tc7_rpsubr
:
3366 if (SCM_NULLP (args
))
3367 RETURN (SCM_BOOL_T
);
3368 while (SCM_NIMP (args
))
3370 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3371 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3372 RETURN (SCM_BOOL_F
);
3373 arg1
= SCM_CAR (args
);
3374 args
= SCM_CDR (args
);
3376 RETURN (SCM_BOOL_T
);
3377 case scm_tcs_closures
:
3379 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3381 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3383 #ifndef SCM_RECKLESS
3384 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3388 /* Copy argument list */
3393 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3394 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3396 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3400 SCM_SETCDR (tl
, arg1
);
3403 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3404 proc
= SCM_CDR (SCM_CODE (proc
));
3407 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3409 if (SCM_IMP (SCM_CAR (proc
)))
3411 if (SCM_ISYMP (SCM_CAR (proc
)))
3413 proc
= scm_m_expand_body (proc
, args
);
3418 SCM_CEVAL (SCM_CAR (proc
), args
);
3421 RETURN (EVALCAR (proc
, args
));
3423 if (!SCM_SMOB_APPLICABLE_P (proc
))
3425 if (SCM_UNBNDP (arg1
))
3426 RETURN (SCM_SMOB_APPLY_0 (proc
))
3427 else if (SCM_NULLP (args
))
3428 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3429 else if (SCM_NULLP (SCM_CDR (args
)))
3430 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3432 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3435 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3437 proc
= SCM_CCLO_SUBR (proc
);
3438 debug
.vect
[0].a
.proc
= proc
;
3439 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3441 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3443 proc
= SCM_CCLO_SUBR (proc
);
3447 proc
= SCM_PROCEDURE (proc
);
3449 debug
.vect
[0].a
.proc
= proc
;
3452 case scm_tcs_cons_gloc
:
3453 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3456 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3458 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3460 RETURN (scm_apply_generic (proc
, args
));
3462 else if (!SCM_I_OPERATORP (proc
))
3467 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3469 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3472 proc
= (SCM_I_ENTITYP (proc
)
3473 ? SCM_ENTITY_PROCEDURE (proc
)
3474 : SCM_OPERATOR_PROCEDURE (proc
));
3476 debug
.vect
[0].a
.proc
= proc
;
3477 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3479 if (SCM_NIMP (proc
))
3485 scm_wrong_num_args (proc
);
3488 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3493 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3494 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3496 SCM_CLEAR_TRACED_FRAME (debug
);
3497 if (SCM_CHEAPTRAPS_P
)
3498 arg1
= scm_make_debugobj (&debug
);
3502 SCM val
= scm_make_continuation (&first
);
3512 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3515 scm_last_debug_frame
= debug
.prev
;
3521 /* SECTION: The rest of this file is only read once.
3526 /* Typechecking for multi-argument MAP and FOR-EACH.
3528 Verify that each element of the vector ARGV, except for the first,
3529 is a proper list whose length is LEN. Attribute errors to WHO,
3530 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3532 check_map_args (SCM argv
,
3539 SCM
*ve
= SCM_VELTS (argv
);
3542 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3544 int elt_len
= scm_ilength (ve
[i
]);
3549 scm_apply_generic (gf
, scm_cons (proc
, args
));
3551 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3555 scm_out_of_range (who
, ve
[i
]);
3558 scm_remember_upto_here_1 (argv
);
3562 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3564 /* Note: Currently, scm_map applies PROC to the argument list(s)
3565 sequentially, starting with the first element(s). This is used in
3566 evalext.c where the Scheme procedure `map-in-order', which guarantees
3567 sequential behaviour, is implemented using scm_map. If the
3568 behaviour changes, we need to update `map-in-order'.
3572 scm_map (SCM proc
, SCM arg1
, SCM args
)
3573 #define FUNC_NAME s_map
3578 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3580 len
= scm_ilength (arg1
);
3581 SCM_GASSERTn (len
>= 0,
3582 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3583 SCM_VALIDATE_REST_ARGUMENT (args
);
3584 if (SCM_NULLP (args
))
3586 while (SCM_NIMP (arg1
))
3588 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3590 pres
= SCM_CDRLOC (*pres
);
3591 arg1
= SCM_CDR (arg1
);
3595 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3596 ve
= SCM_VELTS (args
);
3597 #ifndef SCM_RECKLESS
3598 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3603 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3605 if (SCM_IMP (ve
[i
]))
3607 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3608 ve
[i
] = SCM_CDR (ve
[i
]);
3610 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3611 pres
= SCM_CDRLOC (*pres
);
3617 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3620 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3621 #define FUNC_NAME s_for_each
3623 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3625 len
= scm_ilength (arg1
);
3626 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3627 SCM_ARG2
, s_for_each
);
3628 SCM_VALIDATE_REST_ARGUMENT (args
);
3631 while SCM_NIMP (arg1
)
3633 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3634 arg1
= SCM_CDR (arg1
);
3636 return SCM_UNSPECIFIED
;
3638 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3639 ve
= SCM_VELTS (args
);
3640 #ifndef SCM_RECKLESS
3641 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3646 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3649 (ve
[i
]) return SCM_UNSPECIFIED
;
3650 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3651 ve
[i
] = SCM_CDR (ve
[i
]);
3653 scm_apply (proc
, arg1
, SCM_EOL
);
3660 scm_closure (SCM code
, SCM env
)
3664 SCM_SETCODE (z
, code
);
3665 SCM_SETENV (z
, env
);
3670 scm_bits_t scm_tc16_promise
;
3673 scm_makprom (SCM code
)
3675 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3681 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3683 int writingp
= SCM_WRITINGP (pstate
);
3684 scm_puts ("#<promise ", port
);
3685 SCM_SET_WRITINGP (pstate
, 1);
3686 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3687 SCM_SET_WRITINGP (pstate
, writingp
);
3688 scm_putc ('>', port
);
3693 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3695 "If the promise X has not been computed yet, compute and return\n"
3696 "X, otherwise just return the previously computed value.")
3697 #define FUNC_NAME s_scm_force
3699 SCM_VALIDATE_SMOB (1, x
, promise
);
3700 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3702 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3703 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3706 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3707 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3711 return SCM_CELL_OBJECT_1 (x
);
3716 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3718 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3719 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3720 #define FUNC_NAME s_scm_promise_p
3722 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, x
));
3727 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3728 (SCM xorig
, SCM x
, SCM y
),
3729 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3730 "Any source properties associated with @var{xorig} are also associated\n"
3731 "with the new pair.")
3732 #define FUNC_NAME s_scm_cons_source
3736 SCM_SET_CELL_OBJECT_0 (z
, x
);
3737 SCM_SET_CELL_OBJECT_1 (z
, y
);
3738 /* Copy source properties possibly associated with xorig. */
3739 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3741 scm_whash_insert (scm_source_whash
, z
, p
);
3747 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3749 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3750 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3751 "contents of both pairs and vectors (since both cons cells and vector\n"
3752 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3753 "any other object.")
3754 #define FUNC_NAME s_scm_copy_tree
3759 if (SCM_VECTORP (obj
))
3761 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3762 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3764 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3767 if (SCM_NCONSP (obj
))
3769 ans
= tl
= scm_cons_source (obj
,
3770 scm_copy_tree (SCM_CAR (obj
)),
3772 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3774 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3778 SCM_SETCDR (tl
, obj
);
3784 SCM scm_system_transformer
;
3787 scm_i_eval_x (SCM exp
, SCM env
)
3789 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3790 if (SCM_NIMP (transformer
))
3791 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3792 return SCM_XEVAL (exp
, env
);
3796 scm_i_eval (SCM exp
, SCM env
)
3798 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3799 if (SCM_NIMP (transformer
))
3800 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3801 return SCM_XEVAL (scm_copy_tree (exp
), env
);
3805 scm_eval_x (SCM exp
, SCM module
)
3807 return scm_i_eval_x (exp
,
3808 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module
)));
3811 /* Eval does not take the second arg optionally. This is intentional
3812 * in order to be R5RS compatible, and to prepare for the new module
3813 * system, where we would like to make the choice of evaluation
3814 * environment explicit.
3818 change_environment (void *data
)
3820 SCM pair
= SCM_PACK (data
);
3821 SCM new_module
= SCM_CAR (pair
);
3822 SCM old_module
= scm_selected_module ();
3823 SCM_SETCDR (pair
, old_module
);
3824 scm_select_module (new_module
);
3829 inner_eval (void *data
)
3831 SCM pair
= SCM_PACK (data
);
3832 SCM exp
= SCM_CAR (pair
);
3833 SCM env
= SCM_CDR (pair
);
3834 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3836 exp
= scm_copy_tree (exp
);
3837 if (SCM_NIMP (transformer
))
3838 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3840 return SCM_XEVAL (exp
, env
);
3845 restore_environment (void *data
)
3847 SCM pair
= SCM_PACK (data
);
3848 SCM old_module
= SCM_CDR (pair
);
3849 SCM new_module
= scm_selected_module ();
3850 SCM_SETCAR (pair
, new_module
);
3851 scm_select_module (old_module
);
3855 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3856 (SCM exp
, SCM environment
),
3857 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3858 "environment given by @var{environment specifier}.")
3859 #define FUNC_NAME s_scm_eval
3863 SCM_VALIDATE_MODULE (2, environment
);
3865 env_closure
= scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment
));
3867 return scm_internal_dynamic_wind
3868 (change_environment
, inner_eval
, restore_environment
,
3869 (void *) SCM_UNPACK (scm_cons (exp
, env_closure
)),
3870 (void *) SCM_UNPACK (scm_cons (environment
, SCM_BOOL_F
)));
3874 #if (SCM_DEBUG_DEPRECATED == 0)
3876 /* Use scm_selected_module () or scm_interaction_environment ()
3877 * instead. The former is the module selected during loading of code.
3878 * The latter is the module in which the user of this thread currently
3879 * types expressions.
3882 SCM scm_top_level_lookup_closure_var
;
3884 /* Avoid using this functionality altogether (except for implementing
3885 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3887 * Applications should use either C level scm_eval_x or Scheme scm_eval. */
3890 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3893 return scm_i_eval (obj
, env
);
3895 return scm_i_eval_x (obj
, env
);
3898 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3899 (SCM obj
, SCM env_thunk
),
3900 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3901 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3902 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3903 #define FUNC_NAME s_scm_eval2
3905 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3909 #endif /* DEPRECATED */
3912 /* At this point, scm_deval and scm_dapply are generated.
3915 #ifdef DEBUG_EXTENSIONS
3925 scm_init_opts (scm_evaluator_traps
,
3926 scm_evaluator_trap_table
,
3927 SCM_N_EVALUATOR_TRAPS
);
3928 scm_init_opts (scm_eval_options_interface
,
3930 SCM_N_EVAL_OPTIONS
);
3932 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3933 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3934 scm_set_smob_print (scm_tc16_promise
, promise_print
);
3936 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3937 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
3940 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3941 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3942 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3943 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3944 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3945 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3950 #if SCM_DEBUG_DEPRECATED == 0
3951 scm_top_level_lookup_closure_var
=
3952 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
3955 #ifndef SCM_MAGIC_SNARFER
3956 #include "libguile/eval.x"
3959 scm_add_feature ("delay");