1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000 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/alist.h"
85 #include "libguile/eq.h"
86 #include "libguile/continuations.h"
87 #include "libguile/throw.h"
88 #include "libguile/smob.h"
89 #include "libguile/macros.h"
90 #include "libguile/procprop.h"
91 #include "libguile/hashtab.h"
92 #include "libguile/hash.h"
93 #include "libguile/srcprop.h"
94 #include "libguile/stackchk.h"
95 #include "libguile/objects.h"
96 #include "libguile/async.h"
97 #include "libguile/feature.h"
98 #include "libguile/modules.h"
99 #include "libguile/ports.h"
100 #include "libguile/root.h"
101 #include "libguile/vectors.h"
102 #include "libguile/fluids.h"
104 #include "libguile/validate.h"
105 #include "libguile/eval.h"
109 /* The evaluator contains a plethora of EVAL symbols.
110 * This is an attempt at explanation.
112 * The following macros should be used in code which is read twice
113 * (where the choice of evaluator is hard soldered):
115 * SCM_CEVAL is the symbol used within one evaluator to call itself.
116 * Originally, it is defined to scm_ceval, but is redefined to
117 * scm_deval during the second pass.
119 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
120 * only side effects of expressions matter. All immediates are
123 * SCM_EVALIM is used when it is known that the expression is an
124 * immediate. (This macro never calls an evaluator.)
126 * EVALCAR evaluates the car of an expression.
128 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
129 * car is a lisp cell.
131 * The following macros should be used in code which is read once
132 * (where the choice of evaluator is dynamic):
134 * SCM_XEVAL takes care of immediates without calling an evaluator. It
135 * then calls scm_ceval *or* scm_deval, depending on the debugging
138 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
139 * depending on the debugging mode.
141 * The main motivation for keeping this plethora is efficiency
142 * together with maintainability (=> locality of code).
145 #define SCM_CEVAL scm_ceval
146 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
148 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
149 ? *scm_lookupcar (x, env, 1) \
150 : SCM_CEVAL (SCM_CAR (x), env))
152 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
153 ? (SCM_IMP (SCM_CAR (x)) \
154 ? SCM_EVALIM (SCM_CAR (x), env) \
155 : SCM_GLOC_VAL (SCM_CAR (x))) \
156 : EVALCELLCAR (x, env))
158 #define EXTEND_ENV SCM_EXTEND_ENV
160 #ifdef MEMOIZE_LOCALS
163 scm_ilookup (SCM iloc
, SCM env
)
165 register int ir
= SCM_IFRAME (iloc
);
166 register SCM er
= env
;
167 for (; 0 != ir
; --ir
)
170 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
172 if (SCM_ICDRP (iloc
))
173 return SCM_CDRLOC (er
);
174 return SCM_CARLOC (SCM_CDR (er
));
180 /* The Lookup Car Race
183 Memoization of variables and special forms is done while executing
184 the code for the first time. As long as there is only one thread
185 everything is fine, but as soon as two threads execute the same
186 code concurrently `for the first time' they can come into conflict.
188 This memoization includes rewriting variable references into more
189 efficient forms and expanding macros. Furthermore, macro expansion
190 includes `compiling' special forms like `let', `cond', etc. into
191 tree-code instructions.
193 There shouldn't normally be a problem with memoizing local and
194 global variable references (into ilocs and glocs), because all
195 threads will mutate the code in *exactly* the same way and (if I
196 read the C code correctly) it is not possible to observe a half-way
197 mutated cons cell. The lookup procedure can handle this
198 transparently without any critical sections.
200 It is different with macro expansion, because macro expansion
201 happens outside of the lookup procedure and can't be
202 undone. Therefore it can't cope with it. It has to indicate
203 failure when it detects a lost race and hope that the caller can
204 handle it. Luckily, it turns out that this is the case.
206 An example to illustrate this: Suppose that the follwing form will
207 be memoized concurrently by two threads
211 Let's first examine the lookup of X in the body. The first thread
212 decides that it has to find the symbol "x" in the environment and
213 starts to scan it. Then the other thread takes over and actually
214 overtakes the first. It looks up "x" and substitutes an
215 appropriate iloc for it. Now the first thread continues and
216 completes its lookup. It comes to exactly the same conclusions as
217 the second one and could - without much ado - just overwrite the
218 iloc with the same iloc.
220 But let's see what will happen when the race occurs while looking
221 up the symbol "let" at the start of the form. It could happen that
222 the second thread interrupts the lookup of the first thread and not
223 only substitutes a gloc for it but goes right ahead and replaces it
224 with the compiled form (#@let* (x 12) x). Now, when the first
225 thread completes its lookup, it would replace the #@let* with a
226 gloc pointing to the "let" binding, effectively reverting the form
227 to (let (x 12) x). This is wrong. It has to detect that it has
228 lost the race and the evaluator has to reconsider the changed form
231 This race condition could be resolved with some kind of traffic
232 light (like mutexes) around scm_lookupcar, but I think that it is
233 best to avoid them in this case. They would serialize memoization
234 completely and because lookup involves calling arbitrary Scheme
235 code (via the lookup-thunk), threads could be blocked for an
236 arbitrary amount of time or even deadlock. But with the current
237 solution a lot of unnecessary work is potentially done. */
239 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
240 return NULL to indicate a failed lookup due to some race conditions
241 between threads. This only happens when VLOC is the first cell of
242 a special form that will eventually be memoized (like `let', etc.)
243 In that case the whole lookup is bogus and the caller has to
244 reconsider the complete special form.
246 SCM_LOOKUPCAR is still there, of course. It just calls
247 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
248 should only be called when it is known that VLOC is not the first
249 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
250 for NULL. I think I've found the only places where this
253 #endif /* USE_THREADS */
255 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
259 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
262 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
266 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
268 register SCM var2
= var
;
270 #ifdef MEMOIZE_LOCALS
271 register SCM iloc
= SCM_ILOC00
;
273 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
275 if (!SCM_CONSP (SCM_CAR (env
)))
277 al
= SCM_CARLOC (env
);
278 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
282 if (SCM_EQ_P (fl
, var
))
284 #ifdef MEMOIZE_LOCALS
286 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
289 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
291 return SCM_CDRLOC (*al
);
296 al
= SCM_CDRLOC (*al
);
297 if (SCM_EQ_P (SCM_CAR (fl
), var
))
299 #ifdef MEMOIZE_LOCALS
300 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
301 if (SCM_UNBNDP (SCM_CAR (*al
)))
308 if (SCM_CAR (vloc
) != var
)
311 SCM_SETCAR (vloc
, iloc
);
313 return SCM_CARLOC (*al
);
315 #ifdef MEMOIZE_LOCALS
316 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
319 #ifdef MEMOIZE_LOCALS
320 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
324 SCM top_thunk
, vcell
;
327 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
331 top_thunk
= SCM_BOOL_F
;
332 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
333 if (SCM_FALSEP (vcell
))
339 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
343 /* scm_everr (vloc, genv,...) */
347 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
348 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
350 scm_misc_error (NULL
, "Damaged environment: ~S",
351 scm_cons (var
, SCM_EOL
));
354 /* A variable could not be found, but we shall not throw an error. */
355 static SCM undef_object
= SCM_UNDEFINED
;
356 return &undef_object
;
361 if (SCM_CAR (vloc
) != var2
)
363 /* Some other thread has changed the very cell we are working
364 on. In effect, it must have done our job or messed it up
367 var
= SCM_CAR (vloc
);
368 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
369 return SCM_GLOC_VAL_LOC (var
);
370 #ifdef MEMOIZE_LOCALS
371 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
372 return scm_ilookup (var
, genv
);
374 /* We can't cope with anything else than glocs and ilocs. When
375 a special form has been memoized (i.e. `let' into `#@let') we
376 return NULL and expect the calling function to do the right
377 thing. For the evaluator, this means going back and redoing
378 the dispatch on the car of the form. */
381 #endif /* USE_THREADS */
383 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
384 /* Except wait...what if the var is not a vcell,
385 * but syntax or something.... */
386 return SCM_CDRLOC (var
);
391 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
393 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
400 #define unmemocar scm_unmemocar
403 scm_unmemocar (SCM form
, SCM env
)
410 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
411 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
412 #ifdef MEMOIZE_LOCALS
413 #ifdef DEBUG_EXTENSIONS
414 else if (SCM_ILOCP (c
))
418 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
420 env
= SCM_CAR (SCM_CAR (env
));
421 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
423 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
432 scm_eval_car (SCM pair
, SCM env
)
434 return SCM_XEVALCAR (pair
, env
);
439 * The following rewrite expressions and
440 * some memoized forms have different syntax
443 const char scm_s_expression
[] = "missing or extra expression";
444 const char scm_s_test
[] = "bad test";
445 const char scm_s_body
[] = "bad body";
446 const char scm_s_bindings
[] = "bad bindings";
447 const char scm_s_variable
[] = "bad variable";
448 const char scm_s_clauses
[] = "bad or missing clauses";
449 const char scm_s_formals
[] = "bad formals";
451 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
452 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
456 #ifdef DEBUG_EXTENSIONS
457 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
462 /* Check that the body denoted by XORIG is valid and rewrite it into
463 its internal form. The internal form of a body is just the body
464 itself, but prefixed with an ISYM that denotes to what kind of
465 outer construct this body belongs. A lambda body starts with
466 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
467 etc. The one exception is a body that belongs to a letrec that has
468 been formed by rewriting internal defines: it starts with
471 /* XXX - Besides controlling the rewriting of internal defines, the
472 additional ISYM could be used for improved error messages.
473 This is not done yet. */
476 scm_m_body (SCM op
, SCM xorig
, const char *what
)
478 SCM_ASSYNT (scm_ilength (xorig
) >= 1, xorig
, scm_s_expression
, what
);
480 /* Don't add another ISYM if one is present already. */
481 if (SCM_ISYMP (SCM_CAR (xorig
)))
484 /* Retain possible doc string. */
485 if (!SCM_CONSP (SCM_CAR (xorig
)))
487 if (SCM_NNULLP (SCM_CDR(xorig
)))
488 return scm_cons (SCM_CAR (xorig
),
489 scm_m_body (op
, SCM_CDR(xorig
), what
));
493 return scm_cons (op
, xorig
);
496 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
497 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
500 scm_m_quote (SCM xorig
, SCM env
)
502 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
504 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
505 xorig
, scm_s_expression
, s_quote
);
506 return scm_cons (SCM_IM_QUOTE
, x
);
511 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
512 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
515 scm_m_begin (SCM xorig
, SCM env
)
517 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
518 xorig
, scm_s_expression
, s_begin
);
519 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
522 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
523 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
526 scm_m_if (SCM xorig
, SCM env
)
528 int len
= scm_ilength (SCM_CDR (xorig
));
529 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
530 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
534 /* Will go into the RnRS module when Guile is factorized.
535 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
536 const char scm_s_set_x
[] = "set!";
537 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
540 scm_m_set_x (SCM xorig
, SCM env
)
542 SCM x
= SCM_CDR (xorig
);
543 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
544 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
545 xorig
, scm_s_variable
, scm_s_set_x
);
546 return scm_cons (SCM_IM_SET_X
, x
);
553 scm_m_vref (SCM xorig
, SCM env
)
555 SCM x
= SCM_CDR (xorig
);
556 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
557 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
559 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
560 scm_misc_error (NULL
,
562 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
564 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
565 xorig
, scm_s_variable
, s_vref
);
566 return scm_cons (IM_VREF
, x
);
572 scm_m_vset (SCM xorig
, SCM env
)
574 SCM x
= SCM_CDR (xorig
);
575 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
576 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
577 || UDSCM_VARIABLEP (SCM_CAR (x
))),
578 xorig
, scm_s_variable
, s_vset
);
579 return scm_cons (IM_VSET
, x
);
584 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
585 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
588 scm_m_and (SCM xorig
, SCM env
)
590 int len
= scm_ilength (SCM_CDR (xorig
));
591 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
593 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
598 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
599 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
602 scm_m_or (SCM xorig
, SCM env
)
604 int len
= scm_ilength (SCM_CDR (xorig
));
605 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
607 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
613 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
614 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
617 scm_m_case (SCM xorig
, SCM env
)
619 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
620 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
621 while (SCM_NIMP (x
= SCM_CDR (x
)))
624 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
625 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
626 || SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)),
627 xorig
, scm_s_clauses
, s_case
);
629 return scm_cons (SCM_IM_CASE
, cdrx
);
633 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
634 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
638 scm_m_cond (SCM xorig
, SCM env
)
640 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
641 int len
= scm_ilength (x
);
642 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
646 len
= scm_ilength (arg1
);
647 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
648 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
650 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
651 xorig
, "bad ELSE clause", s_cond
);
652 SCM_SETCAR (arg1
, SCM_BOOL_T
);
654 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
655 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
656 xorig
, "bad recipient", s_cond
);
659 return scm_cons (SCM_IM_COND
, cdrx
);
662 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
663 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
666 scm_m_lambda (SCM xorig
, SCM env
)
668 SCM proc
, x
= SCM_CDR (xorig
);
669 if (scm_ilength (x
) < 2)
672 if (SCM_NULLP (proc
))
674 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
678 if (SCM_SYMBOLP (proc
))
680 if (SCM_NCONSP (proc
))
682 while (SCM_NIMP (proc
))
684 if (SCM_NCONSP (proc
))
686 if (!SCM_SYMBOLP (proc
))
691 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
693 proc
= SCM_CDR (proc
);
695 if (SCM_NNULLP (proc
))
698 scm_wta (xorig
, scm_s_formals
, s_lambda
);
702 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
703 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
706 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
707 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
711 scm_m_letstar (SCM xorig
, SCM env
)
713 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
714 int len
= scm_ilength (x
);
715 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
717 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
718 while (SCM_NIMP (proc
))
720 arg1
= SCM_CAR (proc
);
721 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
722 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
723 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
724 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
725 proc
= SCM_CDR (proc
);
727 x
= scm_cons (vars
, SCM_CDR (x
));
729 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
730 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
733 /* DO gets the most radically altered syntax
734 (do ((<var1> <init1> <step1>)
740 (do_mem (varn ... var2 var1)
741 (<init1> <init2> ... <initn>)
744 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
747 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
748 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
751 scm_m_do (SCM xorig
, SCM env
)
753 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
754 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
755 SCM
*initloc
= &inits
, *steploc
= &steps
;
756 int len
= scm_ilength (x
);
757 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
759 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
760 while (SCM_NIMP(proc
))
762 arg1
= SCM_CAR (proc
);
763 len
= scm_ilength (arg1
);
764 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
765 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
766 /* vars reversed here, inits and steps reversed at evaluation */
767 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
768 arg1
= SCM_CDR (arg1
);
769 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
770 initloc
= SCM_CDRLOC (*initloc
);
771 arg1
= SCM_CDR (arg1
);
772 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
773 steploc
= SCM_CDRLOC (*steploc
);
774 proc
= SCM_CDR (proc
);
777 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
778 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
779 x
= scm_cons2 (vars
, inits
, x
);
780 return scm_cons (SCM_IM_DO
, x
);
783 /* evalcar is small version of inline EVALCAR when we don't care about
786 #define evalcar scm_eval_car
789 static SCM
iqq (SCM form
, SCM env
, int depth
);
791 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
792 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
795 scm_m_quasiquote (SCM xorig
, SCM env
)
797 SCM x
= SCM_CDR (xorig
);
798 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
799 return iqq (SCM_CAR (x
), env
, 1);
804 iqq (SCM form
,SCM env
,int depth
)
810 if (SCM_VECTORP (form
))
812 long i
= SCM_VECTOR_LENGTH (form
);
813 SCM
*data
= SCM_VELTS (form
);
816 tmp
= scm_cons (data
[i
], tmp
);
817 return scm_vector (iqq (tmp
, env
, depth
));
819 if (SCM_NCONSP(form
))
821 tmp
= SCM_CAR (form
);
822 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
827 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
831 form
= SCM_CDR (form
);
832 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
833 form
, SCM_ARG1
, s_quasiquote
);
835 return evalcar (form
, env
);
836 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
838 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
842 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
844 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
847 /* Here are acros which return values rather than code. */
849 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
850 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
853 scm_m_delay (SCM xorig
, SCM env
)
855 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
856 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
860 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
861 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
864 scm_m_define (SCM x
, SCM env
)
868 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
869 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
872 while (SCM_CONSP (proc
))
873 { /* nested define syntax */
874 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
875 proc
= SCM_CAR (proc
);
877 SCM_ASSYNT (SCM_SYMBOLP (proc
),
878 arg1
, scm_s_variable
, s_define
);
879 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
880 if (SCM_TOP_LEVEL (env
))
882 x
= evalcar (x
, env
);
883 #ifdef DEBUG_EXTENSIONS
884 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
888 if (SCM_CLOSUREP (arg1
)
889 /* Only the first definition determines the name. */
890 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
891 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
892 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
893 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
895 arg1
= SCM_CDR (arg1
);
900 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
901 SCM_SETCDR (arg1
, x
);
903 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
905 return SCM_UNSPECIFIED
;
908 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
914 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
916 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
917 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
918 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
919 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
922 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
925 /* vars scm_list reversed here, inits reversed at evaluation */
926 arg1
= SCM_CAR (proc
);
927 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
928 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
929 vars
= scm_cons (SCM_CAR (arg1
), vars
);
930 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
931 initloc
= SCM_CDRLOC (*initloc
);
933 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
935 return scm_cons2 (op
, vars
,
936 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
939 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
940 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
943 scm_m_letrec (SCM xorig
, SCM env
)
945 SCM x
= SCM_CDR (xorig
);
946 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
948 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
949 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
950 scm_m_body (SCM_IM_LETREC
,
955 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
958 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
959 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
962 scm_m_let (SCM xorig
, SCM env
)
964 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
965 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
966 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
968 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
972 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
974 /* null or single binding, let* is faster */
975 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
976 scm_m_body (SCM_IM_LET
,
982 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
983 if (SCM_CONSP (proc
))
985 /* plain let, proc is <bindings> */
986 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
989 if (!SCM_SYMBOLP (proc
))
990 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
991 name
= proc
; /* named let, build equiv letrec */
993 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
994 proc
= SCM_CAR (x
); /* bindings list */
995 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
996 while (SCM_NIMP (proc
))
997 { /* vars and inits both in order */
998 arg1
= SCM_CAR (proc
);
999 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1000 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1001 xorig
, scm_s_variable
, s_let
);
1002 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1003 varloc
= SCM_CDRLOC (*varloc
);
1004 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1005 initloc
= SCM_CDRLOC (*initloc
);
1006 proc
= SCM_CDR (proc
);
1009 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1010 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1011 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1013 scm_acons (name
, inits
, SCM_EOL
));
1014 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1018 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1019 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1020 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1023 scm_m_apply (SCM xorig
, SCM env
)
1025 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1026 xorig
, scm_s_expression
, s_atapply
);
1027 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1031 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1032 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1036 scm_m_cont (SCM xorig
, SCM env
)
1038 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1039 xorig
, scm_s_expression
, s_atcall_cc
);
1040 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1043 /* Multi-language support */
1048 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1051 scm_m_nil_cond (SCM xorig
, SCM env
)
1053 int len
= scm_ilength (SCM_CDR (xorig
));
1054 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1055 scm_s_expression
, "nil-cond");
1056 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1059 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1062 scm_m_nil_ify (SCM xorig
, SCM env
)
1064 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1065 xorig
, scm_s_expression
, "nil-ify");
1066 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1069 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1072 scm_m_t_ify (SCM xorig
, SCM env
)
1074 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1075 xorig
, scm_s_expression
, "t-ify");
1076 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1079 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1082 scm_m_0_cond (SCM xorig
, SCM env
)
1084 int len
= scm_ilength (SCM_CDR (xorig
));
1085 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1086 scm_s_expression
, "0-cond");
1087 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1090 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1093 scm_m_0_ify (SCM xorig
, SCM env
)
1095 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1096 xorig
, scm_s_expression
, "0-ify");
1097 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1100 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1103 scm_m_1_ify (SCM xorig
, SCM env
)
1105 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1106 xorig
, scm_s_expression
, "1-ify");
1107 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1110 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1113 scm_m_atfop (SCM xorig
, SCM env
)
1115 SCM x
= SCM_CDR (xorig
), vcell
;
1116 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1117 vcell
= scm_symbol_fref (SCM_CAR (x
));
1118 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1119 "Symbol's function definition is void", NULL
);
1120 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1124 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1127 scm_m_atbind (SCM xorig
, SCM env
)
1129 SCM x
= SCM_CDR (xorig
);
1130 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1136 while (SCM_NIMP (SCM_CDR (env
)))
1137 env
= SCM_CDR (env
);
1138 env
= SCM_CAR (env
);
1139 if (SCM_CONSP (env
))
1144 while (SCM_NIMP (x
))
1146 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1149 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1153 scm_m_expand_body (SCM xorig
, SCM env
)
1155 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1156 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1158 while (SCM_NIMP (x
))
1161 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1163 if (SCM_IMP (SCM_CAR (form
)))
1165 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1168 form
= scm_macroexp (scm_cons_source (form
,
1173 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1175 defs
= scm_cons (SCM_CDR (form
), defs
);
1178 else if (SCM_NIMP(defs
))
1182 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1184 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1188 x
= scm_cons (form
, SCM_CDR(x
));
1193 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1194 if (SCM_NIMP (defs
))
1196 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1198 scm_cons2 (scm_sym_define
, defs
, x
),
1204 SCM_SETCAR (xorig
, SCM_CAR (x
));
1205 SCM_SETCDR (xorig
, SCM_CDR (x
));
1212 scm_macroexp (SCM x
, SCM env
)
1216 /* Don't bother to produce error messages here. We get them when we
1217 eventually execute the code for real. */
1220 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1225 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1226 if (proc_ptr
== NULL
)
1228 /* We have lost the race. */
1234 proc
= *scm_lookupcar (x
, env
, 0);
1237 /* Only handle memoizing macros. `Acros' and `macros' are really
1238 special forms and should not be evaluated here. */
1241 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1242 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1246 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1248 if (scm_ilength (res
) <= 0)
1249 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1252 SCM_SETCAR (x
, SCM_CAR (res
));
1253 SCM_SETCDR (x
, SCM_CDR (res
));
1259 /* scm_unmemocopy takes a memoized expression together with its
1260 * environment and rewrites it to its original form. Thus, it is the
1261 * inversion of the rewrite rules above. The procedure is not
1262 * optimized for speed. It's used in scm_iprin1 when printing the
1263 * code of a closure, in scm_procedure_source, in display_frame when
1264 * generating the source for a stackframe in a backtrace, and in
1265 * display_expression.
1268 /* We should introduce an anti-macro interface so that it is possible
1269 * to plug in transformers in both directions from other compilation
1270 * units. unmemocopy could then dispatch to anti-macro transformers.
1271 * (Those transformers could perhaps be written in slightly more
1272 * readable style... :)
1275 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1278 unmemocopy (SCM x
, SCM env
)
1281 #ifdef DEBUG_EXTENSIONS
1284 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1286 #ifdef DEBUG_EXTENSIONS
1287 p
= scm_whash_lookup (scm_source_whash
, x
);
1289 switch (SCM_TYP7 (x
))
1291 case SCM_BIT8(SCM_IM_AND
):
1292 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1294 case SCM_BIT8(SCM_IM_BEGIN
):
1295 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1297 case SCM_BIT8(SCM_IM_CASE
):
1298 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1300 case SCM_BIT8(SCM_IM_COND
):
1301 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1303 case SCM_BIT8(SCM_IM_DO
):
1304 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1306 case SCM_BIT8(SCM_IM_IF
):
1307 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1309 case SCM_BIT8(SCM_IM_LET
):
1310 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1312 case SCM_BIT8(SCM_IM_LETREC
):
1315 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1319 f
= v
= SCM_CAR (x
);
1321 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1323 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1324 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1327 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1328 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1330 /* build transformed binding list */
1332 while (SCM_NIMP (v
))
1334 z
= scm_acons (SCM_CAR (v
),
1335 scm_cons (SCM_CAR (e
),
1336 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1338 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1344 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1346 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1350 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1353 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1354 /* body forms are now to be found in SCM_CDR (x)
1355 (this is how *real* code look like! :) */
1359 case SCM_BIT8(SCM_IM_LETSTAR
):
1367 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1370 y
= z
= scm_acons (SCM_CAR (b
),
1372 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1374 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1375 b
= SCM_CDR (SCM_CDR (b
));
1378 SCM_SETCDR (y
, SCM_EOL
);
1379 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1384 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1386 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1389 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1390 b
= SCM_CDR (SCM_CDR (b
));
1392 while (SCM_NIMP (b
));
1393 SCM_SETCDR (z
, SCM_EOL
);
1395 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1398 case SCM_BIT8(SCM_IM_OR
):
1399 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1401 case SCM_BIT8(SCM_IM_LAMBDA
):
1403 ls
= scm_cons (scm_sym_lambda
,
1404 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1405 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1407 case SCM_BIT8(SCM_IM_QUOTE
):
1408 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1410 case SCM_BIT8(SCM_IM_SET_X
):
1411 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1413 case SCM_BIT8(SCM_IM_DEFINE
):
1417 ls
= scm_cons (scm_sym_define
,
1418 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1419 if (SCM_NNULLP (env
))
1420 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1423 case SCM_BIT8(SCM_MAKISYM (0)):
1427 switch (SCM_ISYMNUM (z
))
1429 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1430 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1432 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1433 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1435 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1436 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1440 /* appease the Sun compiler god: */ ;
1444 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1449 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1451 if (SCM_ISYMP (SCM_CAR (x
)))
1452 /* skip body markers */
1454 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1460 #ifdef DEBUG_EXTENSIONS
1461 if (SCM_NFALSEP (p
))
1462 scm_whash_insert (scm_source_whash
, ls
, p
);
1469 scm_unmemocopy (SCM x
, SCM env
)
1471 if (SCM_NNULLP (env
))
1472 /* Make a copy of the lowest frame to protect it from
1473 modifications by SCM_IM_DEFINE */
1474 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1476 return unmemocopy (x
, env
);
1479 #ifndef SCM_RECKLESS
1482 scm_badargsp (SCM formals
, SCM args
)
1484 while (SCM_NIMP (formals
))
1486 if (SCM_NCONSP (formals
))
1490 formals
= SCM_CDR (formals
);
1491 args
= SCM_CDR (args
);
1493 return SCM_NNULLP (args
) ? 1 : 0;
1498 scm_badformalsp (SCM closure
, int n
)
1500 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1501 while (SCM_NIMP (formals
))
1503 if (SCM_NCONSP (formals
))
1508 formals
= SCM_CDR (formals
);
1515 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1517 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1518 while (SCM_NIMP (l
))
1523 if (SCM_IMP (SCM_CAR (l
)))
1524 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1526 res
= EVALCELLCAR (l
, env
);
1528 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1530 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1532 res
= SCM_CAR (l
); /* struct planted in code */
1534 res
= SCM_PACK (vcell
);
1539 res
= EVALCAR (l
, env
);
1541 *lloc
= scm_cons (res
, SCM_EOL
);
1542 lloc
= SCM_CDRLOC (*lloc
);
1549 scm_wrong_num_args (proc
);
1556 scm_eval_body (SCM code
, SCM env
)
1561 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1563 if (SCM_IMP (SCM_CAR (code
)))
1565 if (SCM_ISYMP (SCM_CAR (code
)))
1567 code
= scm_m_expand_body (code
, env
);
1572 SCM_XEVAL (SCM_CAR (code
), env
);
1575 return SCM_XEVALCAR (code
, env
);
1582 /* SECTION: This code is specific for the debugging support. One
1583 * branch is read when DEVAL isn't defined, the other when DEVAL is
1589 #define SCM_APPLY scm_apply
1590 #define PREP_APPLY(proc, args)
1592 #define RETURN(x) return x;
1593 #ifdef STACK_CHECKING
1594 #ifndef NO_CEVAL_STACK_CHECKING
1595 #define EVAL_STACK_CHECKING
1602 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1604 #define SCM_APPLY scm_dapply
1606 #define PREP_APPLY(p, l) \
1607 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1609 #define ENTER_APPLY \
1611 SCM_SET_ARGSREADY (debug);\
1612 if (CHECK_APPLY && SCM_TRAPS_P)\
1613 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1615 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1616 SCM_SET_TRACED_FRAME (debug); \
1617 if (SCM_CHEAPTRAPS_P)\
1619 tmp = scm_make_debugobj (&debug);\
1620 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1625 tmp = scm_make_continuation (&first);\
1627 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1632 #define RETURN(e) {proc = (e); goto exit;}
1633 #ifdef STACK_CHECKING
1634 #ifndef EVAL_STACK_CHECKING
1635 #define EVAL_STACK_CHECKING
1639 /* scm_ceval_ptr points to the currently selected evaluator.
1640 * *fixme*: Although efficiency is important here, this state variable
1641 * should probably not be a global. It should be related to the
1646 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1648 /* scm_last_debug_frame contains a pointer to the last debugging
1649 * information stack frame. It is accessed very often from the
1650 * debugging evaluator, so it should probably not be indirectly
1651 * addressed. Better to save and restore it from the current root at
1656 scm_debug_frame
*scm_last_debug_frame
;
1659 /* scm_debug_eframe_size is the number of slots available for pseudo
1660 * stack frames at each real stack frame.
1663 int scm_debug_eframe_size
;
1665 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1669 scm_option scm_eval_opts
[] = {
1670 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1673 scm_option scm_debug_opts
[] = {
1674 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1675 "*Flyweight representation of the stack at traps." },
1676 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1677 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1678 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1679 "Record procedure names at definition." },
1680 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1681 "Display backtrace in anti-chronological order." },
1682 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1683 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1684 { SCM_OPTION_INTEGER
, "frames", 3,
1685 "Maximum number of tail-recursive frames in backtrace." },
1686 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1687 "Maximal number of stored backtrace frames." },
1688 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1689 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1690 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1691 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1694 scm_option scm_evaluator_trap_table
[] = {
1695 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1696 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1697 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1698 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1701 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1704 #define FUNC_NAME s_scm_eval_options_interface
1708 ans
= scm_options (setting
,
1712 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1718 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1721 #define FUNC_NAME s_scm_evaluator_traps
1725 ans
= scm_options (setting
,
1726 scm_evaluator_trap_table
,
1727 SCM_N_EVALUATOR_TRAPS
,
1729 SCM_RESET_DEBUG_MODE
;
1736 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1738 SCM
*results
= lloc
, res
;
1739 while (SCM_NIMP (l
))
1744 if (SCM_IMP (SCM_CAR (l
)))
1745 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1747 res
= EVALCELLCAR (l
, env
);
1749 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1751 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1753 res
= SCM_CAR (l
); /* struct planted in code */
1755 res
= SCM_PACK (vcell
);
1760 res
= EVALCAR (l
, env
);
1762 *lloc
= scm_cons (res
, SCM_EOL
);
1763 lloc
= SCM_CDRLOC (*lloc
);
1770 scm_wrong_num_args (proc
);
1779 /* SECTION: Some local definitions for the evaluator.
1783 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1786 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1788 /* SECTION: This is the evaluator. Like any real monster, it has
1789 * three heads. This code is compiled twice.
1795 scm_ceval (SCM x
, SCM env
)
1801 scm_deval (SCM x
, SCM env
)
1806 SCM_CEVAL (SCM x
, SCM env
)
1815 scm_debug_frame debug
;
1816 scm_debug_info
*debug_info_end
;
1817 debug
.prev
= scm_last_debug_frame
;
1818 debug
.status
= scm_debug_eframe_size
;
1820 * The debug.vect contains twice as much scm_debug_info frames as the
1821 * user has specified with (debug-set! frames <n>).
1823 * Even frames are eval frames, odd frames are apply frames.
1825 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1826 * sizeof (debug
.vect
[0]));
1827 debug
.info
= debug
.vect
;
1828 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1829 scm_last_debug_frame
= &debug
;
1831 #ifdef EVAL_STACK_CHECKING
1832 if (scm_stack_checking_enabled_p
1833 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1836 debug
.info
->e
.exp
= x
;
1837 debug
.info
->e
.env
= env
;
1839 scm_report_stack_overflow ();
1846 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1849 SCM_CLEAR_ARGSREADY (debug
);
1850 if (SCM_OVERFLOWP (debug
))
1853 * In theory, this should be the only place where it is necessary to
1854 * check for space in debug.vect since both eval frames and
1855 * available space are even.
1857 * For this to be the case, however, it is necessary that primitive
1858 * special forms which jump back to `loop', `begin' or some similar
1859 * label call PREP_APPLY. A convenient way to do this is to jump to
1860 * `loopnoap' or `cdrxnoap'.
1862 else if (++debug
.info
>= debug_info_end
)
1864 SCM_SET_OVERFLOW (debug
);
1868 debug
.info
->e
.exp
= x
;
1869 debug
.info
->e
.env
= env
;
1870 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1871 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1873 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1874 SCM_SET_TAILREC (debug
);
1875 if (SCM_CHEAPTRAPS_P
)
1876 t
.arg1
= scm_make_debugobj (&debug
);
1880 SCM val
= scm_make_continuation (&first
);
1892 /* This gives the possibility for the debugger to
1893 modify the source expression before evaluation. */
1897 scm_ithrow (scm_sym_enter_frame
,
1898 scm_cons2 (t
.arg1
, tail
,
1899 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1903 #if defined (USE_THREADS) || defined (DEVAL)
1907 switch (SCM_TYP7 (x
))
1909 case scm_tc7_symbol
:
1910 /* Only happens when called at top level.
1912 x
= scm_cons (x
, SCM_UNDEFINED
);
1915 case SCM_BIT8(SCM_IM_AND
):
1918 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1919 if (SCM_FALSEP (EVALCAR (x
, env
)))
1921 RETURN (SCM_BOOL_F
);
1925 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1928 case SCM_BIT8(SCM_IM_BEGIN
):
1930 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1936 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1938 if (SCM_IMP (SCM_CAR (x
)))
1940 if (SCM_ISYMP (SCM_CAR (x
)))
1942 x
= scm_m_expand_body (x
, env
);
1947 SCM_CEVAL (SCM_CAR (x
), env
);
1951 carloop
: /* scm_eval car of last form in list */
1952 if (SCM_NCELLP (SCM_CAR (x
)))
1955 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1958 if (SCM_SYMBOLP (SCM_CAR (x
)))
1961 RETURN (*scm_lookupcar (x
, env
, 1))
1965 goto loop
; /* tail recurse */
1968 case SCM_BIT8(SCM_IM_CASE
):
1970 t
.arg1
= EVALCAR (x
, env
);
1971 while (SCM_NIMP (x
= SCM_CDR (x
)))
1974 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1977 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1980 proc
= SCM_CAR (proc
);
1981 while (SCM_NIMP (proc
))
1983 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1985 x
= SCM_CDR (SCM_CAR (x
));
1986 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1989 proc
= SCM_CDR (proc
);
1992 RETURN (SCM_UNSPECIFIED
)
1995 case SCM_BIT8(SCM_IM_COND
):
1996 while (SCM_NIMP (x
= SCM_CDR (x
)))
1999 t
.arg1
= EVALCAR (proc
, env
);
2000 if (SCM_NFALSEP (t
.arg1
))
2007 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2009 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2013 proc
= EVALCAR (proc
, env
);
2014 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2015 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2020 RETURN (SCM_UNSPECIFIED
)
2023 case SCM_BIT8(SCM_IM_DO
):
2025 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2026 t
.arg1
= SCM_EOL
; /* values */
2027 while (SCM_NIMP (proc
))
2029 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2030 proc
= SCM_CDR (proc
);
2032 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2033 x
= SCM_CDR (SCM_CDR (x
));
2034 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2036 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2038 t
.arg1
= SCM_CAR (proc
); /* body */
2039 SIDEVAL (t
.arg1
, env
);
2041 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2043 proc
= SCM_CDR (proc
))
2044 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2045 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2049 RETURN (SCM_UNSPECIFIED
);
2050 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2054 case SCM_BIT8(SCM_IM_IF
):
2056 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2058 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2060 RETURN (SCM_UNSPECIFIED
);
2062 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2066 case SCM_BIT8(SCM_IM_LET
):
2068 proc
= SCM_CAR (SCM_CDR (x
));
2072 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2074 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2075 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2080 case SCM_BIT8(SCM_IM_LETREC
):
2082 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2088 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2090 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2091 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2095 case SCM_BIT8(SCM_IM_LETSTAR
):
2100 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2105 t
.arg1
= SCM_CAR (proc
);
2106 proc
= SCM_CDR (proc
);
2107 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2109 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2112 case SCM_BIT8(SCM_IM_OR
):
2115 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2117 x
= EVALCAR (x
, env
);
2118 if (SCM_NFALSEP (x
))
2124 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2128 case SCM_BIT8(SCM_IM_LAMBDA
):
2129 RETURN (scm_closure (SCM_CDR (x
), env
));
2132 case SCM_BIT8(SCM_IM_QUOTE
):
2133 RETURN (SCM_CAR (SCM_CDR (x
)));
2136 case SCM_BIT8(SCM_IM_SET_X
):
2139 switch (SCM_ITAG3 (proc
))
2142 t
.lloc
= scm_lookupcar (x
, env
, 1);
2144 case scm_tc3_cons_gloc
:
2145 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2147 #ifdef MEMOIZE_LOCALS
2149 t
.lloc
= scm_ilookup (proc
, env
);
2154 *t
.lloc
= EVALCAR (x
, env
);
2158 RETURN (SCM_UNSPECIFIED
);
2162 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2163 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2165 /* new syntactic forms go here. */
2166 case SCM_BIT8(SCM_MAKISYM (0)):
2168 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2169 switch SCM_ISYMNUM (proc
)
2172 case (SCM_ISYMNUM (IM_VREF
)):
2175 var
= SCM_CAR (SCM_CDR (x
));
2176 RETURN (SCM_CDR(var
));
2178 case (SCM_ISYMNUM (IM_VSET
)):
2179 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2180 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2181 RETURN (SCM_UNSPECIFIED
)
2184 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2186 proc
= EVALCAR (proc
, env
);
2187 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2188 if (SCM_CLOSUREP (proc
))
2191 PREP_APPLY (proc
, SCM_EOL
);
2192 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2193 t
.arg1
= EVALCAR (t
.arg1
, env
);
2195 debug
.info
->a
.args
= t
.arg1
;
2197 #ifndef SCM_RECKLESS
2198 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2202 /* Copy argument list */
2203 if (SCM_IMP (t
.arg1
))
2207 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2208 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2209 && SCM_CONSP (t
.arg1
))
2211 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2215 SCM_SETCDR (tl
, t
.arg1
);
2218 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2219 x
= SCM_CODE (proc
);
2225 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2228 SCM val
= scm_make_continuation (&first
);
2236 proc
= evalcar (proc
, env
);
2237 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2238 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2242 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2243 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2245 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2246 proc
= SCM_CADR (x
); /* unevaluated operands */
2247 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2249 arg2
= *scm_ilookup (proc
, env
);
2250 else if (SCM_NCONSP (proc
))
2252 if (SCM_NCELLP (proc
))
2253 arg2
= SCM_GLOC_VAL (proc
);
2255 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2259 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2260 t
.lloc
= SCM_CDRLOC (arg2
);
2261 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2263 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2264 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2269 /* The type dispatch code is duplicated here
2270 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2271 * cuts down execution time for type dispatch to 50%.
2274 int i
, n
, end
, mask
;
2275 SCM z
= SCM_CDDR (x
);
2276 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2277 proc
= SCM_CADR (z
);
2279 if (SCM_NIMP (proc
))
2281 /* Prepare for linear search */
2284 end
= SCM_VECTOR_LENGTH (proc
);
2288 /* Compute a hash value */
2289 int hashset
= SCM_INUM (proc
);
2291 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2292 proc
= SCM_CADR (z
);
2295 if (SCM_NIMP (t
.arg1
))
2298 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2299 [scm_si_hashsets
+ hashset
];
2300 t
.arg1
= SCM_CDR (t
.arg1
);
2302 while (j
-- && SCM_NIMP (t
.arg1
));
2307 /* Search for match */
2311 z
= SCM_VELTS (proc
)[i
];
2312 t
.arg1
= arg2
; /* list of arguments */
2313 if (SCM_NIMP (t
.arg1
))
2316 /* More arguments than specifiers => CLASS != ENV */
2317 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2319 t
.arg1
= SCM_CDR (t
.arg1
);
2322 while (j
-- && SCM_NIMP (t
.arg1
));
2323 /* Fewer arguments than specifiers => CAR != ENV */
2324 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2327 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2329 SCM_CMETHOD_ENV (z
));
2330 x
= SCM_CMETHOD_CODE (z
);
2336 z
= scm_memoize_method (x
, arg2
);
2340 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2342 t
.arg1
= EVALCAR (x
, env
);
2343 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2345 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2347 t
.arg1
= EVALCAR (x
, env
);
2350 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2351 = SCM_UNPACK (EVALCAR (proc
, env
));
2352 RETURN (SCM_UNSPECIFIED
)
2354 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2356 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2358 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2359 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2361 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2363 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2369 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2372 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2374 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2378 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2380 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2382 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2384 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2386 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2387 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2389 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2391 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2397 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2400 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2402 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2406 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2408 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2412 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2415 t
.arg1
= SCM_CAR (x
);
2416 arg2
= SCM_CDAR (env
);
2417 while (SCM_NIMP (arg2
))
2419 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2420 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2422 SCM_SETCAR (arg2
, proc
);
2423 t
.arg1
= SCM_CDR (t
.arg1
);
2424 arg2
= SCM_CDR (arg2
);
2426 t
.arg1
= SCM_CAR (x
);
2427 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2429 arg2
= x
= SCM_CDR (x
);
2430 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2432 SIDEVAL (SCM_CAR (x
), env
);
2435 proc
= EVALCAR (x
, env
);
2437 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2438 arg2
= SCM_CDAR (env
);
2439 while (SCM_NIMP (arg2
))
2441 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2443 t
.arg1
= SCM_CDR (t
.arg1
);
2444 arg2
= SCM_CDR (arg2
);
2456 /* scm_everr (x, env,...) */
2457 scm_misc_error (NULL
,
2458 "Wrong type to apply: ~S",
2459 scm_listify (proc
, SCM_UNDEFINED
));
2460 case scm_tc7_vector
:
2464 case scm_tc7_byvect
:
2471 #ifdef HAVE_LONG_LONGS
2472 case scm_tc7_llvect
:
2475 case scm_tc7_string
:
2476 case scm_tc7_substring
:
2478 case scm_tcs_closures
:
2486 #ifdef MEMOIZE_LOCALS
2487 case SCM_BIT8(SCM_ILOC00
):
2488 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2489 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2490 #ifndef SCM_RECKLESS
2496 #endif /* ifdef MEMOIZE_LOCALS */
2499 case scm_tcs_cons_gloc
: {
2500 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2502 /* This is a struct implanted in the code, not a gloc. */
2505 proc
= SCM_PACK (vcell
);
2506 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2507 #ifndef SCM_RECKLESS
2516 case scm_tcs_cons_nimcar
:
2517 if (SCM_SYMBOLP (SCM_CAR (x
)))
2520 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2523 /* we have lost the race, start again. */
2528 proc
= *scm_lookupcar (x
, env
, 1);
2536 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2542 /* Set a flag during macro expansion so that macro
2543 application frames can be deleted from the backtrace. */
2544 SCM_SET_MACROEXP (debug
);
2546 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2547 scm_cons (env
, scm_listofnull
));
2550 SCM_CLEAR_MACROEXP (debug
);
2552 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2555 if (scm_ilength (t
.arg1
) <= 0)
2556 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2558 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2561 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2562 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2563 /* Prevent memoizing result of define macro */
2565 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2566 scm_set_source_properties_x (debug
.info
->e
.exp
,
2567 scm_source_properties (x
));
2571 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2572 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2576 /* Prevent memoizing of debug info expression. */
2577 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2582 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2583 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2587 if (SCM_NIMP (x
= t
.arg1
))
2595 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2596 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2597 #ifndef SCM_RECKLESS
2601 if (SCM_CLOSUREP (proc
))
2603 arg2
= SCM_CAR (SCM_CODE (proc
));
2604 t
.arg1
= SCM_CDR (x
);
2605 while (SCM_NIMP (arg2
))
2607 if (SCM_NCONSP (arg2
))
2609 if (SCM_IMP (t
.arg1
))
2610 goto umwrongnumargs
;
2611 arg2
= SCM_CDR (arg2
);
2612 t
.arg1
= SCM_CDR (t
.arg1
);
2614 if (SCM_NNULLP (t
.arg1
))
2615 goto umwrongnumargs
;
2617 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2618 goto handle_a_macro
;
2624 PREP_APPLY (proc
, SCM_EOL
);
2625 if (SCM_NULLP (SCM_CDR (x
))) {
2628 switch (SCM_TYP7 (proc
))
2629 { /* no arguments given */
2630 case scm_tc7_subr_0
:
2631 RETURN (SCM_SUBRF (proc
) ());
2632 case scm_tc7_subr_1o
:
2633 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2635 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2636 case scm_tc7_rpsubr
:
2637 RETURN (SCM_BOOL_T
);
2639 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2641 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2643 RETURN (scm_smob_apply_0 (proc
));
2647 proc
= SCM_CCLO_SUBR (proc
);
2649 debug
.info
->a
.proc
= proc
;
2650 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2655 proc
= SCM_PROCEDURE (proc
);
2657 debug
.info
->a
.proc
= proc
;
2659 if (!SCM_CLOSUREP (proc
))
2661 if (scm_badformalsp (proc
, 0))
2662 goto umwrongnumargs
;
2663 case scm_tcs_closures
:
2664 x
= SCM_CODE (proc
);
2665 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2667 case scm_tcs_cons_gloc
:
2668 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2670 x
= SCM_ENTITY_PROCEDURE (proc
);
2674 else if (!SCM_I_OPERATORP (proc
))
2679 proc
= (SCM_I_ENTITYP (proc
)
2680 ? SCM_ENTITY_PROCEDURE (proc
)
2681 : SCM_OPERATOR_PROCEDURE (proc
));
2683 debug
.info
->a
.proc
= proc
;
2684 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2686 if (SCM_NIMP (proc
))
2691 case scm_tc7_subr_1
:
2692 case scm_tc7_subr_2
:
2693 case scm_tc7_subr_2o
:
2695 case scm_tc7_subr_3
:
2696 case scm_tc7_lsubr_2
:
2700 /* scm_everr (x, env,...) */
2701 scm_wrong_num_args (proc
);
2703 /* handle macros here */
2708 /* must handle macros by here */
2713 else if (SCM_CONSP (x
))
2715 if (SCM_IMP (SCM_CAR (x
)))
2716 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2718 t
.arg1
= EVALCELLCAR (x
, env
);
2720 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2722 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2724 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2726 t
.arg1
= SCM_PACK (vcell
);
2731 t
.arg1
= EVALCAR (x
, env
);
2734 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2741 switch (SCM_TYP7 (proc
))
2742 { /* have one argument in t.arg1 */
2743 case scm_tc7_subr_2o
:
2744 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2745 case scm_tc7_subr_1
:
2746 case scm_tc7_subr_1o
:
2747 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2749 if (SCM_SUBRF (proc
))
2751 if (SCM_INUMP (t
.arg1
))
2753 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2755 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2756 if (SCM_REALP (t
.arg1
))
2758 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2761 if (SCM_BIGP (t
.arg1
))
2763 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2767 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2768 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2770 proc
= SCM_SNAME (proc
);
2772 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2773 while ('c' != *--chrs
)
2775 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2776 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2777 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2781 case scm_tc7_rpsubr
:
2782 RETURN (SCM_BOOL_T
);
2784 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2787 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2789 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2792 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2794 RETURN (scm_smob_apply_1 (proc
, t
.arg1
));
2799 proc
= SCM_CCLO_SUBR (proc
);
2801 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2802 debug
.info
->a
.proc
= proc
;
2807 proc
= SCM_PROCEDURE (proc
);
2809 debug
.info
->a
.proc
= proc
;
2811 if (!SCM_CLOSUREP (proc
))
2813 if (scm_badformalsp (proc
, 1))
2814 goto umwrongnumargs
;
2815 case scm_tcs_closures
:
2817 x
= SCM_CODE (proc
);
2819 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2821 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2824 case scm_tcs_cons_gloc
:
2825 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2827 x
= SCM_ENTITY_PROCEDURE (proc
);
2829 arg2
= debug
.info
->a
.args
;
2831 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2835 else if (!SCM_I_OPERATORP (proc
))
2841 proc
= (SCM_I_ENTITYP (proc
)
2842 ? SCM_ENTITY_PROCEDURE (proc
)
2843 : SCM_OPERATOR_PROCEDURE (proc
));
2845 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2846 debug
.info
->a
.proc
= proc
;
2848 if (SCM_NIMP (proc
))
2853 case scm_tc7_subr_2
:
2854 case scm_tc7_subr_0
:
2855 case scm_tc7_subr_3
:
2856 case scm_tc7_lsubr_2
:
2865 else if (SCM_CONSP (x
))
2867 if (SCM_IMP (SCM_CAR (x
)))
2868 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2870 arg2
= EVALCELLCAR (x
, env
);
2872 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2874 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2876 arg2
= SCM_CAR (x
); /* struct planted in code */
2878 arg2
= SCM_PACK (vcell
);
2883 arg2
= EVALCAR (x
, env
);
2885 { /* have two or more arguments */
2887 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2890 if (SCM_NULLP (x
)) {
2895 switch (SCM_TYP7 (proc
))
2896 { /* have two arguments */
2897 case scm_tc7_subr_2
:
2898 case scm_tc7_subr_2o
:
2899 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2902 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2904 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2906 case scm_tc7_lsubr_2
:
2907 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2908 case scm_tc7_rpsubr
:
2910 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2912 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2914 RETURN (scm_smob_apply_2 (proc
, t
.arg1
, arg2
));
2919 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2920 scm_cons (proc
, debug
.info
->a
.args
),
2923 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2924 scm_cons2 (proc
, t
.arg1
,
2931 /* case scm_tc7_cclo:
2932 x = scm_cons(arg2, scm_eval_args(x, env));
2935 proc = SCM_CCLO_SUBR(proc);
2938 case scm_tcs_cons_gloc
:
2939 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2941 x
= SCM_ENTITY_PROCEDURE (proc
);
2943 arg2
= debug
.info
->a
.args
;
2945 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2949 else if (!SCM_I_OPERATORP (proc
))
2955 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2956 ? SCM_ENTITY_PROCEDURE (proc
)
2957 : SCM_OPERATOR_PROCEDURE (proc
),
2958 scm_cons (proc
, debug
.info
->a
.args
),
2961 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2962 ? SCM_ENTITY_PROCEDURE (proc
)
2963 : SCM_OPERATOR_PROCEDURE (proc
),
2964 scm_cons2 (proc
, t
.arg1
,
2972 case scm_tc7_subr_0
:
2974 case scm_tc7_subr_1o
:
2975 case scm_tc7_subr_1
:
2976 case scm_tc7_subr_3
:
2981 proc
= SCM_PROCEDURE (proc
);
2983 debug
.info
->a
.proc
= proc
;
2985 if (!SCM_CLOSUREP (proc
))
2987 if (scm_badformalsp (proc
, 2))
2988 goto umwrongnumargs
;
2989 case scm_tcs_closures
:
2992 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2996 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2997 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2999 x
= SCM_CODE (proc
);
3004 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3008 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3009 scm_deval_args (x
, env
, proc
,
3010 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3014 switch (SCM_TYP7 (proc
))
3015 { /* have 3 or more arguments */
3017 case scm_tc7_subr_3
:
3018 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3019 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3020 SCM_CADDR (debug
.info
->a
.args
)));
3022 #ifdef BUILTIN_RPASUBR
3023 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3024 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3027 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3028 arg2
= SCM_CDR (arg2
);
3030 while (SCM_NIMP (arg2
));
3032 #endif /* BUILTIN_RPASUBR */
3033 case scm_tc7_rpsubr
:
3034 #ifdef BUILTIN_RPASUBR
3035 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3037 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3040 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3042 arg2
= SCM_CAR (t
.arg1
);
3043 t
.arg1
= SCM_CDR (t
.arg1
);
3045 while (SCM_NIMP (t
.arg1
));
3047 #else /* BUILTIN_RPASUBR */
3048 RETURN (SCM_APPLY (proc
, t
.arg1
,
3050 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3052 #endif /* BUILTIN_RPASUBR */
3053 case scm_tc7_lsubr_2
:
3054 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3055 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3057 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3059 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3061 RETURN (scm_smob_apply_3 (proc
, t
.arg1
, arg2
,
3062 SCM_CDDR (debug
.info
->a
.args
)));
3068 proc
= SCM_PROCEDURE (proc
);
3069 debug
.info
->a
.proc
= proc
;
3070 if (!SCM_CLOSUREP (proc
))
3072 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3073 goto umwrongnumargs
;
3074 case scm_tcs_closures
:
3075 SCM_SET_ARGSREADY (debug
);
3076 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3079 x
= SCM_CODE (proc
);
3082 case scm_tc7_subr_3
:
3083 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3084 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3086 #ifdef BUILTIN_RPASUBR
3087 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3090 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3093 while (SCM_NIMP (x
));
3095 #endif /* BUILTIN_RPASUBR */
3096 case scm_tc7_rpsubr
:
3097 #ifdef BUILTIN_RPASUBR
3098 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3102 t
.arg1
= EVALCAR (x
, env
);
3103 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3108 while (SCM_NIMP (x
));
3110 #else /* BUILTIN_RPASUBR */
3111 RETURN (SCM_APPLY (proc
, t
.arg1
,
3113 scm_eval_args (x
, env
, proc
),
3115 #endif /* BUILTIN_RPASUBR */
3116 case scm_tc7_lsubr_2
:
3117 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3119 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3121 scm_eval_args (x
, env
, proc
))));
3123 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3125 RETURN (scm_smob_apply_3 (proc
, t
.arg1
, arg2
,
3126 scm_eval_args (x
, env
, proc
)));
3132 proc
= SCM_PROCEDURE (proc
);
3133 if (!SCM_CLOSUREP (proc
))
3136 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3137 if (SCM_NULLP (formals
)
3138 || (SCM_CONSP (formals
)
3139 && (SCM_NULLP (SCM_CDR (formals
))
3140 || (SCM_CONSP (SCM_CDR (formals
))
3141 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3142 goto umwrongnumargs
;
3144 case scm_tcs_closures
:
3146 SCM_SET_ARGSREADY (debug
);
3148 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3151 scm_eval_args (x
, env
, proc
)),
3153 x
= SCM_CODE (proc
);
3156 case scm_tcs_cons_gloc
:
3157 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3160 arg2
= debug
.info
->a
.args
;
3162 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3164 x
= SCM_ENTITY_PROCEDURE (proc
);
3167 else if (!SCM_I_OPERATORP (proc
))
3171 case scm_tc7_subr_2
:
3172 case scm_tc7_subr_1o
:
3173 case scm_tc7_subr_2o
:
3174 case scm_tc7_subr_0
:
3176 case scm_tc7_subr_1
:
3184 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3185 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3187 SCM_CLEAR_TRACED_FRAME (debug
);
3188 if (SCM_CHEAPTRAPS_P
)
3189 t
.arg1
= scm_make_debugobj (&debug
);
3193 SCM val
= scm_make_continuation (&first
);
3203 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3206 scm_last_debug_frame
= debug
.prev
;
3212 /* SECTION: This code is compiled once.
3217 /* This code processes the arguments to apply:
3219 (apply PROC ARG1 ... ARGS)
3221 Given a list (ARG1 ... ARGS), this function conses the ARG1
3222 ... arguments onto the front of ARGS, and returns the resulting
3223 list. Note that ARGS is a list; thus, the argument to this
3224 function is a list whose last element is a list.
3226 Apply calls this function, and applies PROC to the elements of the
3227 result. apply:nconc2last takes care of building the list of
3228 arguments, given (ARG1 ... ARGS).
3230 Rather than do new consing, apply:nconc2last destroys its argument.
3231 On that topic, this code came into my care with the following
3232 beautifully cryptic comment on that topic: "This will only screw
3233 you if you do (scm_apply scm_apply '( ... ))" If you know what
3234 they're referring to, send me a patch to this comment. */
3236 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3239 #define FUNC_NAME s_scm_nconc2last
3242 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3244 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3245 lloc
= SCM_CDRLOC (*lloc
);
3246 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3247 *lloc
= SCM_CAR (*lloc
);
3255 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3256 * It is compiled twice.
3262 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3269 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3274 /* Apply a function to a list of arguments.
3276 This function is exported to the Scheme level as taking two
3277 required arguments and a tail argument, as if it were:
3278 (lambda (proc arg1 . args) ...)
3279 Thus, if you just have a list of arguments to pass to a procedure,
3280 pass the list as ARG1, and '() for ARGS. If you have some fixed
3281 args, pass the first as ARG1, then cons any remaining fixed args
3282 onto the front of your argument list, and pass that as ARGS. */
3285 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3287 #ifdef DEBUG_EXTENSIONS
3289 scm_debug_frame debug
;
3290 scm_debug_info debug_vect_body
;
3291 debug
.prev
= scm_last_debug_frame
;
3292 debug
.status
= SCM_APPLYFRAME
;
3293 debug
.vect
= &debug_vect_body
;
3294 debug
.vect
[0].a
.proc
= proc
;
3295 debug
.vect
[0].a
.args
= SCM_EOL
;
3296 scm_last_debug_frame
= &debug
;
3299 return scm_dapply (proc
, arg1
, args
);
3303 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3305 /* If ARGS is the empty list, then we're calling apply with only two
3306 arguments --- ARG1 is the list of arguments for PROC. Whatever
3307 the case, futz with things so that ARG1 is the first argument to
3308 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3311 Setting the debug apply frame args this way is pretty messy.
3312 Perhaps we should store arg1 and args directly in the frame as
3313 received, and let scm_frame_arguments unpack them, because that's
3314 a relatively rare operation. This works for now; if the Guile
3315 developer archives are still around, see Mikael's post of
3317 if (SCM_NULLP (args
))
3319 if (SCM_NULLP (arg1
))
3321 arg1
= SCM_UNDEFINED
;
3323 debug
.vect
[0].a
.args
= SCM_EOL
;
3329 debug
.vect
[0].a
.args
= arg1
;
3331 args
= SCM_CDR (arg1
);
3332 arg1
= SCM_CAR (arg1
);
3337 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3338 args
= scm_nconc2last (args
);
3340 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3344 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3347 if (SCM_CHEAPTRAPS_P
)
3348 tmp
= scm_make_debugobj (&debug
);
3353 tmp
= scm_make_continuation (&first
);
3357 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3365 switch (SCM_TYP7 (proc
))
3367 case scm_tc7_subr_2o
:
3368 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3369 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3370 case scm_tc7_subr_2
:
3371 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3373 args
= SCM_CAR (args
);
3374 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3375 case scm_tc7_subr_0
:
3376 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3377 RETURN (SCM_SUBRF (proc
) ())
3378 case scm_tc7_subr_1
:
3379 case scm_tc7_subr_1o
:
3380 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3381 RETURN (SCM_SUBRF (proc
) (arg1
))
3383 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3384 if (SCM_SUBRF (proc
))
3386 if (SCM_INUMP (arg1
))
3388 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3390 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3391 if (SCM_REALP (arg1
))
3393 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3396 if (SCM_BIGP (arg1
))
3397 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3400 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3401 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3403 proc
= SCM_SNAME (proc
);
3405 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3406 while ('c' != *--chrs
)
3408 SCM_ASSERT (SCM_CONSP (arg1
),
3409 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3410 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3414 case scm_tc7_subr_3
:
3415 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3418 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3420 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3422 case scm_tc7_lsubr_2
:
3423 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3424 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3426 if (SCM_NULLP (args
))
3427 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3428 while (SCM_NIMP (args
))
3430 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3431 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3432 args
= SCM_CDR (args
);
3435 case scm_tc7_rpsubr
:
3436 if (SCM_NULLP (args
))
3437 RETURN (SCM_BOOL_T
);
3438 while (SCM_NIMP (args
))
3440 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3441 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3442 RETURN (SCM_BOOL_F
);
3443 arg1
= SCM_CAR (args
);
3444 args
= SCM_CDR (args
);
3446 RETURN (SCM_BOOL_T
);
3447 case scm_tcs_closures
:
3449 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3451 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3453 #ifndef SCM_RECKLESS
3454 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3458 /* Copy argument list */
3463 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3464 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3466 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3470 SCM_SETCDR (tl
, arg1
);
3473 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3474 proc
= SCM_CDR (SCM_CODE (proc
));
3477 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3479 if (SCM_IMP (SCM_CAR (proc
)))
3481 if (SCM_ISYMP (SCM_CAR (proc
)))
3483 proc
= scm_m_expand_body (proc
, args
);
3488 SCM_CEVAL (SCM_CAR (proc
), args
);
3491 RETURN (EVALCAR (proc
, args
));
3493 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3495 if (SCM_UNBNDP (arg1
))
3496 RETURN (scm_smob_apply_0 (proc
))
3497 else if (SCM_NULLP (args
))
3498 RETURN (scm_smob_apply_1 (proc
, arg1
))
3499 else if (SCM_NULLP (SCM_CDR (args
)))
3500 RETURN (scm_smob_apply_2 (proc
, arg1
, SCM_CAR (args
)))
3502 RETURN (scm_smob_apply_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3506 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3508 proc
= SCM_CCLO_SUBR (proc
);
3509 debug
.vect
[0].a
.proc
= proc
;
3510 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3512 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3514 proc
= SCM_CCLO_SUBR (proc
);
3519 proc
= SCM_PROCEDURE (proc
);
3521 debug
.vect
[0].a
.proc
= proc
;
3524 case scm_tcs_cons_gloc
:
3525 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3528 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3530 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3532 RETURN (scm_apply_generic (proc
, args
));
3534 else if (!SCM_I_OPERATORP (proc
))
3539 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3541 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3544 proc
= (SCM_I_ENTITYP (proc
)
3545 ? SCM_ENTITY_PROCEDURE (proc
)
3546 : SCM_OPERATOR_PROCEDURE (proc
));
3548 debug
.vect
[0].a
.proc
= proc
;
3549 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3551 if (SCM_NIMP (proc
))
3557 scm_wrong_num_args (proc
);
3560 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3565 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3566 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3568 SCM_CLEAR_TRACED_FRAME (debug
);
3569 if (SCM_CHEAPTRAPS_P
)
3570 arg1
= scm_make_debugobj (&debug
);
3574 SCM val
= scm_make_continuation (&first
);
3584 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3587 scm_last_debug_frame
= debug
.prev
;
3593 /* SECTION: The rest of this file is only read once.
3598 /* Typechecking for multi-argument MAP and FOR-EACH.
3600 Verify that each element of the vector ARGV, except for the first,
3601 is a proper list whose length is LEN. Attribute errors to WHO,
3602 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3604 check_map_args (SCM argv
,
3611 SCM
*ve
= SCM_VELTS (argv
);
3614 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3616 int elt_len
= scm_ilength (ve
[i
]);
3621 scm_apply_generic (gf
, scm_cons (proc
, args
));
3623 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3627 scm_out_of_range (who
, ve
[i
]);
3630 scm_remember (&argv
);
3634 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3636 /* Note: Currently, scm_map applies PROC to the argument list(s)
3637 sequentially, starting with the first element(s). This is used in
3638 evalext.c where the Scheme procedure `map-in-order', which guarantees
3639 sequential behaviour, is implemented using scm_map. If the
3640 behaviour changes, we need to update `map-in-order'.
3644 scm_map (SCM proc
, SCM arg1
, SCM args
)
3645 #define FUNC_NAME s_map
3650 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3652 len
= scm_ilength (arg1
);
3653 SCM_GASSERTn (len
>= 0,
3654 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3655 SCM_VALIDATE_REST_ARGUMENT (args
);
3656 if (SCM_NULLP (args
))
3658 while (SCM_NIMP (arg1
))
3660 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3662 pres
= SCM_CDRLOC (*pres
);
3663 arg1
= SCM_CDR (arg1
);
3667 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3668 ve
= SCM_VELTS (args
);
3669 #ifndef SCM_RECKLESS
3670 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3675 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3677 if (SCM_IMP (ve
[i
]))
3679 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3680 ve
[i
] = SCM_CDR (ve
[i
]);
3682 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3683 pres
= SCM_CDRLOC (*pres
);
3689 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3692 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3693 #define FUNC_NAME s_for_each
3695 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3697 len
= scm_ilength (arg1
);
3698 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3699 SCM_ARG2
, s_for_each
);
3700 SCM_VALIDATE_REST_ARGUMENT (args
);
3703 while SCM_NIMP (arg1
)
3705 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3706 arg1
= SCM_CDR (arg1
);
3708 return SCM_UNSPECIFIED
;
3710 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3711 ve
= SCM_VELTS (args
);
3712 #ifndef SCM_RECKLESS
3713 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3718 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3721 (ve
[i
]) return SCM_UNSPECIFIED
;
3722 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3723 ve
[i
] = SCM_CDR (ve
[i
]);
3725 scm_apply (proc
, arg1
, SCM_EOL
);
3732 scm_closure (SCM code
, SCM env
)
3736 SCM_SETCODE (z
, code
);
3737 SCM_SETENV (z
, env
);
3742 long scm_tc16_promise
;
3745 scm_makprom (SCM code
)
3747 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3753 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3755 int writingp
= SCM_WRITINGP (pstate
);
3756 scm_puts ("#<promise ", port
);
3757 SCM_SET_WRITINGP (pstate
, 1);
3758 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3759 SCM_SET_WRITINGP (pstate
, writingp
);
3760 scm_putc ('>', port
);
3765 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3767 "If the promise X has not been computed yet, compute and return\n"
3768 "X, otherwise just return the previously computed value.")
3769 #define FUNC_NAME s_scm_force
3771 SCM_VALIDATE_SMOB (1, x
, promise
);
3772 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3774 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3775 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3778 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3779 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3783 return SCM_CELL_OBJECT_1 (x
);
3788 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3790 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3791 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3792 #define FUNC_NAME s_scm_promise_p
3794 return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise
, x
));
3799 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3800 (SCM xorig
, SCM x
, SCM y
),
3801 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3802 "Any source properties associated with @var{xorig} are also associated\n"
3803 "with the new pair.")
3804 #define FUNC_NAME s_scm_cons_source
3808 SCM_SET_CELL_OBJECT_0 (z
, x
);
3809 SCM_SET_CELL_OBJECT_1 (z
, y
);
3810 /* Copy source properties possibly associated with xorig. */
3811 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3813 scm_whash_insert (scm_source_whash
, z
, p
);
3819 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3821 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3822 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3823 "contents of both pairs and vectors (since both cons cells and vector\n"
3824 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3825 "any other object.")
3826 #define FUNC_NAME s_scm_copy_tree
3831 if (SCM_VECTORP (obj
))
3833 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3834 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3836 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3839 if (SCM_NCONSP (obj
))
3841 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3842 ans
= tl
= scm_cons_source (obj
,
3843 scm_copy_tree (SCM_CAR (obj
)),
3845 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3847 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3851 SCM_SETCDR (tl
, obj
);
3857 SCM scm_system_transformer
;
3860 scm_i_eval_x (SCM exp
, SCM env
)
3862 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3863 if (SCM_NIMP (transformer
))
3864 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3865 return SCM_XEVAL (exp
, env
);
3869 scm_i_eval (SCM exp
, SCM env
)
3871 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3872 if (SCM_NIMP (transformer
))
3873 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3874 return SCM_XEVAL (scm_copy_tree (exp
), env
);
3878 scm_eval_x (SCM exp
, SCM module
)
3880 return scm_i_eval_x (exp
,
3881 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module
)));
3884 /* Eval does not take the second arg optionally. This is intentional
3885 * in order to be R5RS compatible, and to prepare for the new module
3886 * system, where we would like to make the choice of evaluation
3887 * environment explicit.
3890 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3891 (SCM exp
, SCM environment
),
3892 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3893 "environment given by @var{environment specifier}.")
3894 #define FUNC_NAME s_scm_eval
3896 SCM_VALIDATE_MODULE (2, environment
);
3897 return scm_i_eval (scm_copy_tree (exp
),
3898 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment
)));
3902 #if (SCM_DEBUG_DEPRECATED == 0)
3904 /* Use scm_selected_module () or scm_interaction_environment ()
3905 * instead. The former is the module selected during loading of code.
3906 * The latter is the module in which the user of this thread currently
3907 * types expressions.
3910 SCM scm_top_level_lookup_closure_var
;
3912 /* Avoid using this functionality altogether (except for implementing
3913 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3915 * Applications should use either C level scm_eval_x or Scheme scm_eval. */
3918 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3921 return scm_i_eval (obj
, env
);
3923 return scm_i_eval_x (obj
, env
);
3926 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3927 (SCM obj
, SCM env_thunk
),
3928 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3929 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3930 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3931 #define FUNC_NAME s_scm_eval2
3933 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3937 #endif /* DEPRECATED */
3940 /* At this point, scm_deval and scm_dapply are generated.
3943 #ifdef DEBUG_EXTENSIONS
3953 scm_init_opts (scm_evaluator_traps
,
3954 scm_evaluator_trap_table
,
3955 SCM_N_EVALUATOR_TRAPS
);
3956 scm_init_opts (scm_eval_options_interface
,
3958 SCM_N_EVAL_OPTIONS
);
3960 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3961 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3962 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3964 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3965 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
3967 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3968 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3969 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3970 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3971 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3973 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3974 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3975 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3976 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3977 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3978 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3983 #if SCM_DEBUG_DEPRECATED == 0
3984 scm_top_level_lookup_closure_var
=
3985 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
3988 #ifdef DEBUG_EXTENSIONS
3989 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3990 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3991 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3992 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3995 #ifndef SCM_MAGIC_SNARFER
3996 #include "libguile/eval.x"
3999 scm_add_feature ("delay");