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
);
550 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
551 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
554 scm_m_and (SCM xorig
, SCM env
)
556 int len
= scm_ilength (SCM_CDR (xorig
));
557 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
559 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
564 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
565 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
568 scm_m_or (SCM xorig
, SCM env
)
570 int len
= scm_ilength (SCM_CDR (xorig
));
571 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
573 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
579 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
580 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
583 scm_m_case (SCM xorig
, SCM env
)
585 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
586 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
587 while (SCM_NIMP (x
= SCM_CDR (x
)))
590 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
591 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
592 || SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)),
593 xorig
, scm_s_clauses
, s_case
);
595 return scm_cons (SCM_IM_CASE
, cdrx
);
599 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
600 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
604 scm_m_cond (SCM xorig
, SCM env
)
606 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
607 int len
= scm_ilength (x
);
608 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
612 len
= scm_ilength (arg1
);
613 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
614 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
616 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
617 xorig
, "bad ELSE clause", s_cond
);
618 SCM_SETCAR (arg1
, SCM_BOOL_T
);
620 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
621 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
622 xorig
, "bad recipient", s_cond
);
625 return scm_cons (SCM_IM_COND
, cdrx
);
628 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
629 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
632 scm_m_lambda (SCM xorig
, SCM env
)
634 SCM proc
, x
= SCM_CDR (xorig
);
635 if (scm_ilength (x
) < 2)
638 if (SCM_NULLP (proc
))
640 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
644 if (SCM_SYMBOLP (proc
))
646 if (SCM_NCONSP (proc
))
648 while (SCM_NIMP (proc
))
650 if (SCM_NCONSP (proc
))
652 if (!SCM_SYMBOLP (proc
))
657 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
659 proc
= SCM_CDR (proc
);
661 if (SCM_NNULLP (proc
))
664 scm_wta (xorig
, scm_s_formals
, s_lambda
);
668 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
669 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
672 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
673 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
677 scm_m_letstar (SCM xorig
, SCM env
)
679 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
680 int len
= scm_ilength (x
);
681 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
683 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
684 while (SCM_NIMP (proc
))
686 arg1
= SCM_CAR (proc
);
687 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
688 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
689 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
690 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
691 proc
= SCM_CDR (proc
);
693 x
= scm_cons (vars
, SCM_CDR (x
));
695 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
696 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
699 /* DO gets the most radically altered syntax
700 (do ((<var1> <init1> <step1>)
706 (do_mem (varn ... var2 var1)
707 (<init1> <init2> ... <initn>)
710 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
713 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
714 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
717 scm_m_do (SCM xorig
, SCM env
)
719 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
720 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
721 SCM
*initloc
= &inits
, *steploc
= &steps
;
722 int len
= scm_ilength (x
);
723 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
725 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
726 while (SCM_NIMP(proc
))
728 arg1
= SCM_CAR (proc
);
729 len
= scm_ilength (arg1
);
730 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
731 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
732 /* vars reversed here, inits and steps reversed at evaluation */
733 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
734 arg1
= SCM_CDR (arg1
);
735 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
736 initloc
= SCM_CDRLOC (*initloc
);
737 arg1
= SCM_CDR (arg1
);
738 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
739 steploc
= SCM_CDRLOC (*steploc
);
740 proc
= SCM_CDR (proc
);
743 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
744 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
745 x
= scm_cons2 (vars
, inits
, x
);
746 return scm_cons (SCM_IM_DO
, x
);
749 /* evalcar is small version of inline EVALCAR when we don't care about
752 #define evalcar scm_eval_car
755 static SCM
iqq (SCM form
, SCM env
, int depth
);
757 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
758 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
761 scm_m_quasiquote (SCM xorig
, SCM env
)
763 SCM x
= SCM_CDR (xorig
);
764 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
765 return iqq (SCM_CAR (x
), env
, 1);
770 iqq (SCM form
,SCM env
,int depth
)
776 if (SCM_VECTORP (form
))
778 long i
= SCM_VECTOR_LENGTH (form
);
779 SCM
*data
= SCM_VELTS (form
);
782 tmp
= scm_cons (data
[i
], tmp
);
783 return scm_vector (iqq (tmp
, env
, depth
));
785 if (SCM_NCONSP(form
))
787 tmp
= SCM_CAR (form
);
788 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
793 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
797 form
= SCM_CDR (form
);
798 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
799 form
, SCM_ARG1
, s_quasiquote
);
801 return evalcar (form
, env
);
802 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
804 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
808 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
810 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
813 /* Here are acros which return values rather than code. */
815 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
816 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
819 scm_m_delay (SCM xorig
, SCM env
)
821 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
822 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
826 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
827 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
830 scm_m_define (SCM x
, SCM env
)
834 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
837 while (SCM_CONSP (proc
))
838 { /* nested define syntax */
839 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
840 proc
= SCM_CAR (proc
);
842 SCM_ASSYNT (SCM_SYMBOLP (proc
),
843 arg1
, scm_s_variable
, s_define
);
844 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
845 if (SCM_TOP_LEVEL (env
))
847 x
= evalcar (x
, env
);
848 #ifdef DEBUG_EXTENSIONS
849 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
853 if (SCM_CLOSUREP (arg1
)
854 /* Only the first definition determines the name. */
855 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
856 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
857 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
858 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
860 arg1
= SCM_CDR (arg1
);
865 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
866 SCM_SETCDR (arg1
, x
);
868 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
870 return SCM_UNSPECIFIED
;
873 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
879 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
881 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
882 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
883 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
884 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
887 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
890 /* vars scm_list reversed here, inits reversed at evaluation */
891 arg1
= SCM_CAR (proc
);
892 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
893 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
894 vars
= scm_cons (SCM_CAR (arg1
), vars
);
895 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
896 initloc
= SCM_CDRLOC (*initloc
);
898 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
900 return scm_cons2 (op
, vars
,
901 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
904 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
905 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
908 scm_m_letrec (SCM xorig
, SCM env
)
910 SCM x
= SCM_CDR (xorig
);
911 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
913 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
914 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
915 scm_m_body (SCM_IM_LETREC
,
920 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
923 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
924 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
927 scm_m_let (SCM xorig
, SCM env
)
929 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
930 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
931 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
933 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
937 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
939 /* null or single binding, let* is faster */
940 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
941 scm_m_body (SCM_IM_LET
,
947 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
948 if (SCM_CONSP (proc
))
950 /* plain let, proc is <bindings> */
951 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
954 if (!SCM_SYMBOLP (proc
))
955 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
956 name
= proc
; /* named let, build equiv letrec */
958 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
959 proc
= SCM_CAR (x
); /* bindings list */
960 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
961 while (SCM_NIMP (proc
))
962 { /* vars and inits both in order */
963 arg1
= SCM_CAR (proc
);
964 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
965 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
966 xorig
, scm_s_variable
, s_let
);
967 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
968 varloc
= SCM_CDRLOC (*varloc
);
969 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
970 initloc
= SCM_CDRLOC (*initloc
);
971 proc
= SCM_CDR (proc
);
974 proc
= scm_cons2 (scm_sym_lambda
, vars
,
975 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
976 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
978 scm_acons (name
, inits
, SCM_EOL
));
979 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
983 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
984 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
985 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
988 scm_m_apply (SCM xorig
, SCM env
)
990 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
991 xorig
, scm_s_expression
, s_atapply
);
992 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
996 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
997 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1001 scm_m_cont (SCM xorig
, SCM env
)
1003 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1004 xorig
, scm_s_expression
, s_atcall_cc
);
1005 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1008 /* Multi-language support */
1013 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1016 scm_m_nil_cond (SCM xorig
, SCM env
)
1018 int len
= scm_ilength (SCM_CDR (xorig
));
1019 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1020 scm_s_expression
, "nil-cond");
1021 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1024 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1027 scm_m_nil_ify (SCM xorig
, SCM env
)
1029 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1030 xorig
, scm_s_expression
, "nil-ify");
1031 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1034 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1037 scm_m_t_ify (SCM xorig
, SCM env
)
1039 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1040 xorig
, scm_s_expression
, "t-ify");
1041 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1044 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1047 scm_m_0_cond (SCM xorig
, SCM env
)
1049 int len
= scm_ilength (SCM_CDR (xorig
));
1050 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1051 scm_s_expression
, "0-cond");
1052 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1055 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1058 scm_m_0_ify (SCM xorig
, SCM env
)
1060 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1061 xorig
, scm_s_expression
, "0-ify");
1062 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1065 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1068 scm_m_1_ify (SCM xorig
, SCM env
)
1070 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1071 xorig
, scm_s_expression
, "1-ify");
1072 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1075 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1078 scm_m_atfop (SCM xorig
, SCM env
)
1080 SCM x
= SCM_CDR (xorig
), vcell
;
1081 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1082 vcell
= scm_symbol_fref (SCM_CAR (x
));
1083 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1084 "Symbol's function definition is void", NULL
);
1085 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1089 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1092 scm_m_atbind (SCM xorig
, SCM env
)
1094 SCM x
= SCM_CDR (xorig
);
1095 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1101 while (SCM_NIMP (SCM_CDR (env
)))
1102 env
= SCM_CDR (env
);
1103 env
= SCM_CAR (env
);
1104 if (SCM_CONSP (env
))
1109 while (SCM_NIMP (x
))
1111 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1114 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1118 scm_m_expand_body (SCM xorig
, SCM env
)
1120 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1121 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1123 while (SCM_NIMP (x
))
1126 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1128 if (SCM_IMP (SCM_CAR (form
)))
1130 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1133 form
= scm_macroexp (scm_cons_source (form
,
1138 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1140 defs
= scm_cons (SCM_CDR (form
), defs
);
1143 else if (SCM_NIMP(defs
))
1147 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1149 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1153 x
= scm_cons (form
, SCM_CDR(x
));
1158 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1159 if (SCM_NIMP (defs
))
1161 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1163 scm_cons2 (scm_sym_define
, defs
, x
),
1169 SCM_SETCAR (xorig
, SCM_CAR (x
));
1170 SCM_SETCDR (xorig
, SCM_CDR (x
));
1177 scm_macroexp (SCM x
, SCM env
)
1181 /* Don't bother to produce error messages here. We get them when we
1182 eventually execute the code for real. */
1185 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1190 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1191 if (proc_ptr
== NULL
)
1193 /* We have lost the race. */
1199 proc
= *scm_lookupcar (x
, env
, 0);
1202 /* Only handle memoizing macros. `Acros' and `macros' are really
1203 special forms and should not be evaluated here. */
1206 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1207 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1211 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1213 if (scm_ilength (res
) <= 0)
1214 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1217 SCM_SETCAR (x
, SCM_CAR (res
));
1218 SCM_SETCDR (x
, SCM_CDR (res
));
1224 /* scm_unmemocopy takes a memoized expression together with its
1225 * environment and rewrites it to its original form. Thus, it is the
1226 * inversion of the rewrite rules above. The procedure is not
1227 * optimized for speed. It's used in scm_iprin1 when printing the
1228 * code of a closure, in scm_procedure_source, in display_frame when
1229 * generating the source for a stackframe in a backtrace, and in
1230 * display_expression.
1233 /* We should introduce an anti-macro interface so that it is possible
1234 * to plug in transformers in both directions from other compilation
1235 * units. unmemocopy could then dispatch to anti-macro transformers.
1236 * (Those transformers could perhaps be written in slightly more
1237 * readable style... :)
1240 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1243 unmemocopy (SCM x
, SCM env
)
1246 #ifdef DEBUG_EXTENSIONS
1249 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1251 #ifdef DEBUG_EXTENSIONS
1252 p
= scm_whash_lookup (scm_source_whash
, x
);
1254 switch (SCM_TYP7 (x
))
1256 case SCM_BIT8(SCM_IM_AND
):
1257 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1259 case SCM_BIT8(SCM_IM_BEGIN
):
1260 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1262 case SCM_BIT8(SCM_IM_CASE
):
1263 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1265 case SCM_BIT8(SCM_IM_COND
):
1266 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1268 case SCM_BIT8(SCM_IM_DO
):
1269 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1271 case SCM_BIT8(SCM_IM_IF
):
1272 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1274 case SCM_BIT8(SCM_IM_LET
):
1275 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1277 case SCM_BIT8(SCM_IM_LETREC
):
1280 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1284 f
= v
= SCM_CAR (x
);
1286 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1288 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1289 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1292 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1293 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1295 /* build transformed binding list */
1297 while (SCM_NIMP (v
))
1299 z
= scm_acons (SCM_CAR (v
),
1300 scm_cons (SCM_CAR (e
),
1301 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1303 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1309 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1311 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1315 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1318 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1319 /* body forms are now to be found in SCM_CDR (x)
1320 (this is how *real* code look like! :) */
1324 case SCM_BIT8(SCM_IM_LETSTAR
):
1332 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1335 y
= z
= scm_acons (SCM_CAR (b
),
1337 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1339 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1340 b
= SCM_CDR (SCM_CDR (b
));
1343 SCM_SETCDR (y
, SCM_EOL
);
1344 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1349 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1351 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1354 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1355 b
= SCM_CDR (SCM_CDR (b
));
1357 while (SCM_NIMP (b
));
1358 SCM_SETCDR (z
, SCM_EOL
);
1360 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1363 case SCM_BIT8(SCM_IM_OR
):
1364 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1366 case SCM_BIT8(SCM_IM_LAMBDA
):
1368 ls
= scm_cons (scm_sym_lambda
,
1369 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1370 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1372 case SCM_BIT8(SCM_IM_QUOTE
):
1373 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1375 case SCM_BIT8(SCM_IM_SET_X
):
1376 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1378 case SCM_BIT8(SCM_IM_DEFINE
):
1382 ls
= scm_cons (scm_sym_define
,
1383 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1384 if (SCM_NNULLP (env
))
1385 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1388 case SCM_BIT8(SCM_MAKISYM (0)):
1392 switch (SCM_ISYMNUM (z
))
1394 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1395 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1397 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1398 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1400 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1401 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1405 /* appease the Sun compiler god: */ ;
1409 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1414 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1416 if (SCM_ISYMP (SCM_CAR (x
)))
1417 /* skip body markers */
1419 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1425 #ifdef DEBUG_EXTENSIONS
1426 if (SCM_NFALSEP (p
))
1427 scm_whash_insert (scm_source_whash
, ls
, p
);
1434 scm_unmemocopy (SCM x
, SCM env
)
1436 if (SCM_NNULLP (env
))
1437 /* Make a copy of the lowest frame to protect it from
1438 modifications by SCM_IM_DEFINE */
1439 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1441 return unmemocopy (x
, env
);
1444 #ifndef SCM_RECKLESS
1447 scm_badargsp (SCM formals
, SCM args
)
1449 while (SCM_NIMP (formals
))
1451 if (SCM_NCONSP (formals
))
1455 formals
= SCM_CDR (formals
);
1456 args
= SCM_CDR (args
);
1458 return SCM_NNULLP (args
) ? 1 : 0;
1463 scm_badformalsp (SCM closure
, int n
)
1465 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1466 while (SCM_NIMP (formals
))
1468 if (SCM_NCONSP (formals
))
1473 formals
= SCM_CDR (formals
);
1480 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1482 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1483 while (SCM_NIMP (l
))
1488 if (SCM_IMP (SCM_CAR (l
)))
1489 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1491 res
= EVALCELLCAR (l
, env
);
1493 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1495 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1497 res
= SCM_CAR (l
); /* struct planted in code */
1499 res
= SCM_PACK (vcell
);
1504 res
= EVALCAR (l
, env
);
1506 *lloc
= scm_cons (res
, SCM_EOL
);
1507 lloc
= SCM_CDRLOC (*lloc
);
1514 scm_wrong_num_args (proc
);
1521 scm_eval_body (SCM code
, SCM env
)
1526 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1528 if (SCM_IMP (SCM_CAR (code
)))
1530 if (SCM_ISYMP (SCM_CAR (code
)))
1532 code
= scm_m_expand_body (code
, env
);
1537 SCM_XEVAL (SCM_CAR (code
), env
);
1540 return SCM_XEVALCAR (code
, env
);
1547 /* SECTION: This code is specific for the debugging support. One
1548 * branch is read when DEVAL isn't defined, the other when DEVAL is
1554 #define SCM_APPLY scm_apply
1555 #define PREP_APPLY(proc, args)
1557 #define RETURN(x) return x;
1558 #ifdef STACK_CHECKING
1559 #ifndef NO_CEVAL_STACK_CHECKING
1560 #define EVAL_STACK_CHECKING
1567 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1569 #define SCM_APPLY scm_dapply
1571 #define PREP_APPLY(p, l) \
1572 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1574 #define ENTER_APPLY \
1576 SCM_SET_ARGSREADY (debug);\
1577 if (CHECK_APPLY && SCM_TRAPS_P)\
1578 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1580 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1581 SCM_SET_TRACED_FRAME (debug); \
1582 if (SCM_CHEAPTRAPS_P)\
1584 tmp = scm_make_debugobj (&debug);\
1585 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1590 tmp = scm_make_continuation (&first);\
1592 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1597 #define RETURN(e) {proc = (e); goto exit;}
1598 #ifdef STACK_CHECKING
1599 #ifndef EVAL_STACK_CHECKING
1600 #define EVAL_STACK_CHECKING
1604 /* scm_ceval_ptr points to the currently selected evaluator.
1605 * *fixme*: Although efficiency is important here, this state variable
1606 * should probably not be a global. It should be related to the
1611 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1613 /* scm_last_debug_frame contains a pointer to the last debugging
1614 * information stack frame. It is accessed very often from the
1615 * debugging evaluator, so it should probably not be indirectly
1616 * addressed. Better to save and restore it from the current root at
1621 scm_debug_frame
*scm_last_debug_frame
;
1624 /* scm_debug_eframe_size is the number of slots available for pseudo
1625 * stack frames at each real stack frame.
1628 int scm_debug_eframe_size
;
1630 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1634 scm_option scm_eval_opts
[] = {
1635 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1638 scm_option scm_debug_opts
[] = {
1639 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1640 "*Flyweight representation of the stack at traps." },
1641 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1642 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1643 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1644 "Record procedure names at definition." },
1645 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1646 "Display backtrace in anti-chronological order." },
1647 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1648 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1649 { SCM_OPTION_INTEGER
, "frames", 3,
1650 "Maximum number of tail-recursive frames in backtrace." },
1651 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1652 "Maximal number of stored backtrace frames." },
1653 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1654 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1655 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1656 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1659 scm_option scm_evaluator_trap_table
[] = {
1660 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1661 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1662 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1663 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1666 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1669 #define FUNC_NAME s_scm_eval_options_interface
1673 ans
= scm_options (setting
,
1677 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1683 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1686 #define FUNC_NAME s_scm_evaluator_traps
1690 ans
= scm_options (setting
,
1691 scm_evaluator_trap_table
,
1692 SCM_N_EVALUATOR_TRAPS
,
1694 SCM_RESET_DEBUG_MODE
;
1701 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1703 SCM
*results
= lloc
, res
;
1704 while (SCM_NIMP (l
))
1709 if (SCM_IMP (SCM_CAR (l
)))
1710 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1712 res
= EVALCELLCAR (l
, env
);
1714 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1716 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1718 res
= SCM_CAR (l
); /* struct planted in code */
1720 res
= SCM_PACK (vcell
);
1725 res
= EVALCAR (l
, env
);
1727 *lloc
= scm_cons (res
, SCM_EOL
);
1728 lloc
= SCM_CDRLOC (*lloc
);
1735 scm_wrong_num_args (proc
);
1744 /* SECTION: Some local definitions for the evaluator.
1748 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1751 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1753 /* SECTION: This is the evaluator. Like any real monster, it has
1754 * three heads. This code is compiled twice.
1760 scm_ceval (SCM x
, SCM env
)
1766 scm_deval (SCM x
, SCM env
)
1771 SCM_CEVAL (SCM x
, SCM env
)
1780 scm_debug_frame debug
;
1781 scm_debug_info
*debug_info_end
;
1782 debug
.prev
= scm_last_debug_frame
;
1783 debug
.status
= scm_debug_eframe_size
;
1785 * The debug.vect contains twice as much scm_debug_info frames as the
1786 * user has specified with (debug-set! frames <n>).
1788 * Even frames are eval frames, odd frames are apply frames.
1790 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1791 * sizeof (debug
.vect
[0]));
1792 debug
.info
= debug
.vect
;
1793 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1794 scm_last_debug_frame
= &debug
;
1796 #ifdef EVAL_STACK_CHECKING
1797 if (scm_stack_checking_enabled_p
1798 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1801 debug
.info
->e
.exp
= x
;
1802 debug
.info
->e
.env
= env
;
1804 scm_report_stack_overflow ();
1811 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1814 SCM_CLEAR_ARGSREADY (debug
);
1815 if (SCM_OVERFLOWP (debug
))
1818 * In theory, this should be the only place where it is necessary to
1819 * check for space in debug.vect since both eval frames and
1820 * available space are even.
1822 * For this to be the case, however, it is necessary that primitive
1823 * special forms which jump back to `loop', `begin' or some similar
1824 * label call PREP_APPLY. A convenient way to do this is to jump to
1825 * `loopnoap' or `cdrxnoap'.
1827 else if (++debug
.info
>= debug_info_end
)
1829 SCM_SET_OVERFLOW (debug
);
1833 debug
.info
->e
.exp
= x
;
1834 debug
.info
->e
.env
= env
;
1835 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1836 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1838 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1839 SCM_SET_TAILREC (debug
);
1840 if (SCM_CHEAPTRAPS_P
)
1841 t
.arg1
= scm_make_debugobj (&debug
);
1845 SCM val
= scm_make_continuation (&first
);
1857 /* This gives the possibility for the debugger to
1858 modify the source expression before evaluation. */
1862 scm_ithrow (scm_sym_enter_frame
,
1863 scm_cons2 (t
.arg1
, tail
,
1864 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1868 #if defined (USE_THREADS) || defined (DEVAL)
1872 switch (SCM_TYP7 (x
))
1874 case scm_tc7_symbol
:
1875 /* Only happens when called at top level.
1877 x
= scm_cons (x
, SCM_UNDEFINED
);
1880 case SCM_BIT8(SCM_IM_AND
):
1883 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1884 if (SCM_FALSEP (EVALCAR (x
, env
)))
1886 RETURN (SCM_BOOL_F
);
1890 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1893 case SCM_BIT8(SCM_IM_BEGIN
):
1895 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1901 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1903 if (SCM_IMP (SCM_CAR (x
)))
1905 if (SCM_ISYMP (SCM_CAR (x
)))
1907 x
= scm_m_expand_body (x
, env
);
1912 SCM_CEVAL (SCM_CAR (x
), env
);
1916 carloop
: /* scm_eval car of last form in list */
1917 if (SCM_NCELLP (SCM_CAR (x
)))
1920 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1923 if (SCM_SYMBOLP (SCM_CAR (x
)))
1926 RETURN (*scm_lookupcar (x
, env
, 1))
1930 goto loop
; /* tail recurse */
1933 case SCM_BIT8(SCM_IM_CASE
):
1935 t
.arg1
= EVALCAR (x
, env
);
1936 while (SCM_NIMP (x
= SCM_CDR (x
)))
1939 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1942 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1945 proc
= SCM_CAR (proc
);
1946 while (SCM_NIMP (proc
))
1948 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1950 x
= SCM_CDR (SCM_CAR (x
));
1951 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1954 proc
= SCM_CDR (proc
);
1957 RETURN (SCM_UNSPECIFIED
)
1960 case SCM_BIT8(SCM_IM_COND
):
1961 while (SCM_NIMP (x
= SCM_CDR (x
)))
1964 t
.arg1
= EVALCAR (proc
, env
);
1965 if (SCM_NFALSEP (t
.arg1
))
1972 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
1974 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1978 proc
= EVALCAR (proc
, env
);
1979 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1980 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1985 RETURN (SCM_UNSPECIFIED
)
1988 case SCM_BIT8(SCM_IM_DO
):
1990 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1991 t
.arg1
= SCM_EOL
; /* values */
1992 while (SCM_NIMP (proc
))
1994 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1995 proc
= SCM_CDR (proc
);
1997 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1998 x
= SCM_CDR (SCM_CDR (x
));
1999 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2001 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2003 t
.arg1
= SCM_CAR (proc
); /* body */
2004 SIDEVAL (t
.arg1
, env
);
2006 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2008 proc
= SCM_CDR (proc
))
2009 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2010 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2014 RETURN (SCM_UNSPECIFIED
);
2015 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2019 case SCM_BIT8(SCM_IM_IF
):
2021 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2023 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2025 RETURN (SCM_UNSPECIFIED
);
2027 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2031 case SCM_BIT8(SCM_IM_LET
):
2033 proc
= SCM_CAR (SCM_CDR (x
));
2037 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2039 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2040 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2045 case SCM_BIT8(SCM_IM_LETREC
):
2047 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2053 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2055 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2056 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2060 case SCM_BIT8(SCM_IM_LETSTAR
):
2065 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2070 t
.arg1
= SCM_CAR (proc
);
2071 proc
= SCM_CDR (proc
);
2072 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2074 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2077 case SCM_BIT8(SCM_IM_OR
):
2080 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2082 x
= EVALCAR (x
, env
);
2083 if (SCM_NFALSEP (x
))
2089 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2093 case SCM_BIT8(SCM_IM_LAMBDA
):
2094 RETURN (scm_closure (SCM_CDR (x
), env
));
2097 case SCM_BIT8(SCM_IM_QUOTE
):
2098 RETURN (SCM_CAR (SCM_CDR (x
)));
2101 case SCM_BIT8(SCM_IM_SET_X
):
2104 switch (SCM_ITAG3 (proc
))
2107 t
.lloc
= scm_lookupcar (x
, env
, 1);
2109 case scm_tc3_cons_gloc
:
2110 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2112 #ifdef MEMOIZE_LOCALS
2114 t
.lloc
= scm_ilookup (proc
, env
);
2119 *t
.lloc
= EVALCAR (x
, env
);
2123 RETURN (SCM_UNSPECIFIED
);
2127 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2128 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2130 /* new syntactic forms go here. */
2131 case SCM_BIT8(SCM_MAKISYM (0)):
2133 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2134 switch SCM_ISYMNUM (proc
)
2136 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2138 proc
= EVALCAR (proc
, env
);
2139 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2140 if (SCM_CLOSUREP (proc
))
2143 PREP_APPLY (proc
, SCM_EOL
);
2144 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2145 t
.arg1
= EVALCAR (t
.arg1
, env
);
2147 debug
.info
->a
.args
= t
.arg1
;
2149 #ifndef SCM_RECKLESS
2150 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2154 /* Copy argument list */
2155 if (SCM_IMP (t
.arg1
))
2159 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2160 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2161 && SCM_CONSP (t
.arg1
))
2163 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2167 SCM_SETCDR (tl
, t
.arg1
);
2170 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2171 x
= SCM_CODE (proc
);
2177 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2180 SCM val
= scm_make_continuation (&first
);
2188 proc
= evalcar (proc
, env
);
2189 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2190 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2194 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2195 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2197 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2198 proc
= SCM_CADR (x
); /* unevaluated operands */
2199 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2201 arg2
= *scm_ilookup (proc
, env
);
2202 else if (SCM_NCONSP (proc
))
2204 if (SCM_NCELLP (proc
))
2205 arg2
= SCM_GLOC_VAL (proc
);
2207 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2211 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2212 t
.lloc
= SCM_CDRLOC (arg2
);
2213 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2215 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2216 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2221 /* The type dispatch code is duplicated here
2222 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2223 * cuts down execution time for type dispatch to 50%.
2226 int i
, n
, end
, mask
;
2227 SCM z
= SCM_CDDR (x
);
2228 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2229 proc
= SCM_CADR (z
);
2231 if (SCM_NIMP (proc
))
2233 /* Prepare for linear search */
2236 end
= SCM_VECTOR_LENGTH (proc
);
2240 /* Compute a hash value */
2241 int hashset
= SCM_INUM (proc
);
2243 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2244 proc
= SCM_CADR (z
);
2247 if (SCM_NIMP (t
.arg1
))
2250 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2251 [scm_si_hashsets
+ hashset
];
2252 t
.arg1
= SCM_CDR (t
.arg1
);
2254 while (j
-- && SCM_NIMP (t
.arg1
));
2259 /* Search for match */
2263 z
= SCM_VELTS (proc
)[i
];
2264 t
.arg1
= arg2
; /* list of arguments */
2265 if (SCM_NIMP (t
.arg1
))
2268 /* More arguments than specifiers => CLASS != ENV */
2269 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2271 t
.arg1
= SCM_CDR (t
.arg1
);
2274 while (j
-- && SCM_NIMP (t
.arg1
));
2275 /* Fewer arguments than specifiers => CAR != ENV */
2276 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2279 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2281 SCM_CMETHOD_ENV (z
));
2282 x
= SCM_CMETHOD_CODE (z
);
2288 z
= scm_memoize_method (x
, arg2
);
2292 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2294 t
.arg1
= EVALCAR (x
, env
);
2295 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2297 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2299 t
.arg1
= EVALCAR (x
, env
);
2302 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2303 = SCM_UNPACK (EVALCAR (proc
, env
));
2304 RETURN (SCM_UNSPECIFIED
)
2306 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2308 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2310 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2311 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2313 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2315 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2321 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2324 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2326 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2330 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2332 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2334 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2336 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2338 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2339 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2341 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2343 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2349 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2352 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2354 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2358 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2360 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2364 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2367 t
.arg1
= SCM_CAR (x
);
2368 arg2
= SCM_CDAR (env
);
2369 while (SCM_NIMP (arg2
))
2371 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2372 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2374 SCM_SETCAR (arg2
, proc
);
2375 t
.arg1
= SCM_CDR (t
.arg1
);
2376 arg2
= SCM_CDR (arg2
);
2378 t
.arg1
= SCM_CAR (x
);
2379 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2381 arg2
= x
= SCM_CDR (x
);
2382 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2384 SIDEVAL (SCM_CAR (x
), env
);
2387 proc
= EVALCAR (x
, env
);
2389 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2390 arg2
= SCM_CDAR (env
);
2391 while (SCM_NIMP (arg2
))
2393 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2395 t
.arg1
= SCM_CDR (t
.arg1
);
2396 arg2
= SCM_CDR (arg2
);
2408 /* scm_everr (x, env,...) */
2409 scm_misc_error (NULL
,
2410 "Wrong type to apply: ~S",
2411 scm_listify (proc
, SCM_UNDEFINED
));
2412 case scm_tc7_vector
:
2416 case scm_tc7_byvect
:
2423 #ifdef HAVE_LONG_LONGS
2424 case scm_tc7_llvect
:
2427 case scm_tc7_string
:
2428 case scm_tc7_substring
:
2430 case scm_tcs_closures
:
2436 #ifdef MEMOIZE_LOCALS
2437 case SCM_BIT8(SCM_ILOC00
):
2438 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2439 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2440 #ifndef SCM_RECKLESS
2446 #endif /* ifdef MEMOIZE_LOCALS */
2449 case scm_tcs_cons_gloc
: {
2450 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2452 /* This is a struct implanted in the code, not a gloc. */
2455 proc
= SCM_PACK (vcell
);
2456 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2457 #ifndef SCM_RECKLESS
2466 case scm_tcs_cons_nimcar
:
2467 if (SCM_SYMBOLP (SCM_CAR (x
)))
2470 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2473 /* we have lost the race, start again. */
2478 proc
= *scm_lookupcar (x
, env
, 1);
2486 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2492 /* Set a flag during macro expansion so that macro
2493 application frames can be deleted from the backtrace. */
2494 SCM_SET_MACROEXP (debug
);
2496 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2497 scm_cons (env
, scm_listofnull
));
2500 SCM_CLEAR_MACROEXP (debug
);
2502 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2505 if (scm_ilength (t
.arg1
) <= 0)
2506 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2508 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2511 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2512 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2516 /* Prevent memoizing of debug info expression. */
2517 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2522 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2523 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2527 if (SCM_NIMP (x
= t
.arg1
))
2535 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2536 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2537 #ifndef SCM_RECKLESS
2541 if (SCM_CLOSUREP (proc
))
2543 arg2
= SCM_CAR (SCM_CODE (proc
));
2544 t
.arg1
= SCM_CDR (x
);
2545 while (SCM_NIMP (arg2
))
2547 if (SCM_NCONSP (arg2
))
2549 if (SCM_IMP (t
.arg1
))
2550 goto umwrongnumargs
;
2551 arg2
= SCM_CDR (arg2
);
2552 t
.arg1
= SCM_CDR (t
.arg1
);
2554 if (SCM_NNULLP (t
.arg1
))
2555 goto umwrongnumargs
;
2557 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2558 goto handle_a_macro
;
2564 PREP_APPLY (proc
, SCM_EOL
);
2565 if (SCM_NULLP (SCM_CDR (x
))) {
2568 switch (SCM_TYP7 (proc
))
2569 { /* no arguments given */
2570 case scm_tc7_subr_0
:
2571 RETURN (SCM_SUBRF (proc
) ());
2572 case scm_tc7_subr_1o
:
2573 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2575 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2576 case scm_tc7_rpsubr
:
2577 RETURN (SCM_BOOL_T
);
2579 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2581 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2583 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_0 (proc
));
2586 proc
= SCM_CCLO_SUBR (proc
);
2588 debug
.info
->a
.proc
= proc
;
2589 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2593 proc
= SCM_PROCEDURE (proc
);
2595 debug
.info
->a
.proc
= proc
;
2597 if (!SCM_CLOSUREP (proc
))
2599 if (scm_badformalsp (proc
, 0))
2600 goto umwrongnumargs
;
2601 case scm_tcs_closures
:
2602 x
= SCM_CODE (proc
);
2603 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2605 case scm_tcs_cons_gloc
:
2606 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2608 x
= SCM_ENTITY_PROCEDURE (proc
);
2612 else if (!SCM_I_OPERATORP (proc
))
2617 proc
= (SCM_I_ENTITYP (proc
)
2618 ? SCM_ENTITY_PROCEDURE (proc
)
2619 : SCM_OPERATOR_PROCEDURE (proc
));
2621 debug
.info
->a
.proc
= proc
;
2622 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2624 if (SCM_NIMP (proc
))
2629 case scm_tc7_subr_1
:
2630 case scm_tc7_subr_2
:
2631 case scm_tc7_subr_2o
:
2633 case scm_tc7_subr_3
:
2634 case scm_tc7_lsubr_2
:
2638 /* scm_everr (x, env,...) */
2639 scm_wrong_num_args (proc
);
2641 /* handle macros here */
2646 /* must handle macros by here */
2651 else if (SCM_CONSP (x
))
2653 if (SCM_IMP (SCM_CAR (x
)))
2654 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2656 t
.arg1
= EVALCELLCAR (x
, env
);
2658 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2660 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2662 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2664 t
.arg1
= SCM_PACK (vcell
);
2669 t
.arg1
= EVALCAR (x
, env
);
2672 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2679 switch (SCM_TYP7 (proc
))
2680 { /* have one argument in t.arg1 */
2681 case scm_tc7_subr_2o
:
2682 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2683 case scm_tc7_subr_1
:
2684 case scm_tc7_subr_1o
:
2685 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2687 if (SCM_SUBRF (proc
))
2689 if (SCM_INUMP (t
.arg1
))
2691 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2693 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2694 if (SCM_REALP (t
.arg1
))
2696 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2699 if (SCM_BIGP (t
.arg1
))
2701 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2705 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2706 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2708 proc
= SCM_SNAME (proc
);
2710 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2711 while ('c' != *--chrs
)
2713 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2714 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2715 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2719 case scm_tc7_rpsubr
:
2720 RETURN (SCM_BOOL_T
);
2722 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2725 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2727 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2730 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2732 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_1 (proc
, t
.arg1
));
2736 proc
= SCM_CCLO_SUBR (proc
);
2738 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2739 debug
.info
->a
.proc
= proc
;
2743 proc
= SCM_PROCEDURE (proc
);
2745 debug
.info
->a
.proc
= proc
;
2747 if (!SCM_CLOSUREP (proc
))
2749 if (scm_badformalsp (proc
, 1))
2750 goto umwrongnumargs
;
2751 case scm_tcs_closures
:
2753 x
= SCM_CODE (proc
);
2755 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2757 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2760 case scm_tcs_cons_gloc
:
2761 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2763 x
= SCM_ENTITY_PROCEDURE (proc
);
2765 arg2
= debug
.info
->a
.args
;
2767 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2771 else if (!SCM_I_OPERATORP (proc
))
2777 proc
= (SCM_I_ENTITYP (proc
)
2778 ? SCM_ENTITY_PROCEDURE (proc
)
2779 : SCM_OPERATOR_PROCEDURE (proc
));
2781 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2782 debug
.info
->a
.proc
= proc
;
2784 if (SCM_NIMP (proc
))
2789 case scm_tc7_subr_2
:
2790 case scm_tc7_subr_0
:
2791 case scm_tc7_subr_3
:
2792 case scm_tc7_lsubr_2
:
2801 else if (SCM_CONSP (x
))
2803 if (SCM_IMP (SCM_CAR (x
)))
2804 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2806 arg2
= EVALCELLCAR (x
, env
);
2808 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2810 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2812 arg2
= SCM_CAR (x
); /* struct planted in code */
2814 arg2
= SCM_PACK (vcell
);
2819 arg2
= EVALCAR (x
, env
);
2821 { /* have two or more arguments */
2823 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2826 if (SCM_NULLP (x
)) {
2829 switch (SCM_TYP7 (proc
))
2830 { /* have two arguments */
2831 case scm_tc7_subr_2
:
2832 case scm_tc7_subr_2o
:
2833 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2836 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2838 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2840 case scm_tc7_lsubr_2
:
2841 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2842 case scm_tc7_rpsubr
:
2844 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2846 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2848 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_2 (proc
, t
.arg1
, arg2
));
2852 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2853 scm_cons (proc
, debug
.info
->a
.args
),
2856 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2857 scm_cons2 (proc
, t
.arg1
,
2864 case scm_tcs_cons_gloc
:
2865 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2867 x
= SCM_ENTITY_PROCEDURE (proc
);
2869 arg2
= debug
.info
->a
.args
;
2871 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2875 else if (!SCM_I_OPERATORP (proc
))
2881 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2882 ? SCM_ENTITY_PROCEDURE (proc
)
2883 : SCM_OPERATOR_PROCEDURE (proc
),
2884 scm_cons (proc
, debug
.info
->a
.args
),
2887 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2888 ? SCM_ENTITY_PROCEDURE (proc
)
2889 : SCM_OPERATOR_PROCEDURE (proc
),
2890 scm_cons2 (proc
, t
.arg1
,
2898 case scm_tc7_subr_0
:
2900 case scm_tc7_subr_1o
:
2901 case scm_tc7_subr_1
:
2902 case scm_tc7_subr_3
:
2907 proc
= SCM_PROCEDURE (proc
);
2909 debug
.info
->a
.proc
= proc
;
2911 if (!SCM_CLOSUREP (proc
))
2913 if (scm_badformalsp (proc
, 2))
2914 goto umwrongnumargs
;
2915 case scm_tcs_closures
:
2918 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2922 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2923 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2925 x
= SCM_CODE (proc
);
2930 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2934 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2935 scm_deval_args (x
, env
, proc
,
2936 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2940 switch (SCM_TYP7 (proc
))
2941 { /* have 3 or more arguments */
2943 case scm_tc7_subr_3
:
2944 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2945 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2946 SCM_CADDR (debug
.info
->a
.args
)));
2948 #ifdef BUILTIN_RPASUBR
2949 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2950 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2953 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2954 arg2
= SCM_CDR (arg2
);
2956 while (SCM_NIMP (arg2
));
2958 #endif /* BUILTIN_RPASUBR */
2959 case scm_tc7_rpsubr
:
2960 #ifdef BUILTIN_RPASUBR
2961 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2963 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2966 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2968 arg2
= SCM_CAR (t
.arg1
);
2969 t
.arg1
= SCM_CDR (t
.arg1
);
2971 while (SCM_NIMP (t
.arg1
));
2973 #else /* BUILTIN_RPASUBR */
2974 RETURN (SCM_APPLY (proc
, t
.arg1
,
2976 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
2978 #endif /* BUILTIN_RPASUBR */
2979 case scm_tc7_lsubr_2
:
2980 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2981 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2983 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2985 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2987 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_3
2988 (proc
, t
.arg1
, arg2
, SCM_CDDR (debug
.info
->a
.args
)));
2992 proc
= SCM_PROCEDURE (proc
);
2993 debug
.info
->a
.proc
= proc
;
2994 if (!SCM_CLOSUREP (proc
))
2996 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
2997 goto umwrongnumargs
;
2998 case scm_tcs_closures
:
2999 SCM_SET_ARGSREADY (debug
);
3000 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3003 x
= SCM_CODE (proc
);
3006 case scm_tc7_subr_3
:
3007 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3008 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3010 #ifdef BUILTIN_RPASUBR
3011 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3014 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3017 while (SCM_NIMP (x
));
3019 #endif /* BUILTIN_RPASUBR */
3020 case scm_tc7_rpsubr
:
3021 #ifdef BUILTIN_RPASUBR
3022 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3026 t
.arg1
= EVALCAR (x
, env
);
3027 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3032 while (SCM_NIMP (x
));
3034 #else /* BUILTIN_RPASUBR */
3035 RETURN (SCM_APPLY (proc
, t
.arg1
,
3037 scm_eval_args (x
, env
, proc
),
3039 #endif /* BUILTIN_RPASUBR */
3040 case scm_tc7_lsubr_2
:
3041 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3043 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3045 scm_eval_args (x
, env
, proc
))));
3047 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3049 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_3
3050 (proc
, t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3054 proc
= SCM_PROCEDURE (proc
);
3055 if (!SCM_CLOSUREP (proc
))
3058 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3059 if (SCM_NULLP (formals
)
3060 || (SCM_CONSP (formals
)
3061 && (SCM_NULLP (SCM_CDR (formals
))
3062 || (SCM_CONSP (SCM_CDR (formals
))
3063 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3064 goto umwrongnumargs
;
3066 case scm_tcs_closures
:
3068 SCM_SET_ARGSREADY (debug
);
3070 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3073 scm_eval_args (x
, env
, proc
)),
3075 x
= SCM_CODE (proc
);
3078 case scm_tcs_cons_gloc
:
3079 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3082 arg2
= debug
.info
->a
.args
;
3084 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3086 x
= SCM_ENTITY_PROCEDURE (proc
);
3089 else if (!SCM_I_OPERATORP (proc
))
3093 case scm_tc7_subr_2
:
3094 case scm_tc7_subr_1o
:
3095 case scm_tc7_subr_2o
:
3096 case scm_tc7_subr_0
:
3098 case scm_tc7_subr_1
:
3106 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3107 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3109 SCM_CLEAR_TRACED_FRAME (debug
);
3110 if (SCM_CHEAPTRAPS_P
)
3111 t
.arg1
= scm_make_debugobj (&debug
);
3115 SCM val
= scm_make_continuation (&first
);
3125 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3128 scm_last_debug_frame
= debug
.prev
;
3134 /* SECTION: This code is compiled once.
3139 /* This code processes the arguments to apply:
3141 (apply PROC ARG1 ... ARGS)
3143 Given a list (ARG1 ... ARGS), this function conses the ARG1
3144 ... arguments onto the front of ARGS, and returns the resulting
3145 list. Note that ARGS is a list; thus, the argument to this
3146 function is a list whose last element is a list.
3148 Apply calls this function, and applies PROC to the elements of the
3149 result. apply:nconc2last takes care of building the list of
3150 arguments, given (ARG1 ... ARGS).
3152 Rather than do new consing, apply:nconc2last destroys its argument.
3153 On that topic, this code came into my care with the following
3154 beautifully cryptic comment on that topic: "This will only screw
3155 you if you do (scm_apply scm_apply '( ... ))" If you know what
3156 they're referring to, send me a patch to this comment. */
3158 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3161 #define FUNC_NAME s_scm_nconc2last
3164 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3166 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3167 lloc
= SCM_CDRLOC (*lloc
);
3168 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3169 *lloc
= SCM_CAR (*lloc
);
3177 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3178 * It is compiled twice.
3184 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3191 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3196 /* Apply a function to a list of arguments.
3198 This function is exported to the Scheme level as taking two
3199 required arguments and a tail argument, as if it were:
3200 (lambda (proc arg1 . args) ...)
3201 Thus, if you just have a list of arguments to pass to a procedure,
3202 pass the list as ARG1, and '() for ARGS. If you have some fixed
3203 args, pass the first as ARG1, then cons any remaining fixed args
3204 onto the front of your argument list, and pass that as ARGS. */
3207 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3209 #ifdef DEBUG_EXTENSIONS
3211 scm_debug_frame debug
;
3212 scm_debug_info debug_vect_body
;
3213 debug
.prev
= scm_last_debug_frame
;
3214 debug
.status
= SCM_APPLYFRAME
;
3215 debug
.vect
= &debug_vect_body
;
3216 debug
.vect
[0].a
.proc
= proc
;
3217 debug
.vect
[0].a
.args
= SCM_EOL
;
3218 scm_last_debug_frame
= &debug
;
3221 return scm_dapply (proc
, arg1
, args
);
3225 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3227 /* If ARGS is the empty list, then we're calling apply with only two
3228 arguments --- ARG1 is the list of arguments for PROC. Whatever
3229 the case, futz with things so that ARG1 is the first argument to
3230 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3233 Setting the debug apply frame args this way is pretty messy.
3234 Perhaps we should store arg1 and args directly in the frame as
3235 received, and let scm_frame_arguments unpack them, because that's
3236 a relatively rare operation. This works for now; if the Guile
3237 developer archives are still around, see Mikael's post of
3239 if (SCM_NULLP (args
))
3241 if (SCM_NULLP (arg1
))
3243 arg1
= SCM_UNDEFINED
;
3245 debug
.vect
[0].a
.args
= SCM_EOL
;
3251 debug
.vect
[0].a
.args
= arg1
;
3253 args
= SCM_CDR (arg1
);
3254 arg1
= SCM_CAR (arg1
);
3259 args
= scm_nconc2last (args
);
3261 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3265 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3268 if (SCM_CHEAPTRAPS_P
)
3269 tmp
= scm_make_debugobj (&debug
);
3274 tmp
= scm_make_continuation (&first
);
3278 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3284 switch (SCM_TYP7 (proc
))
3286 case scm_tc7_subr_2o
:
3287 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3288 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3289 case scm_tc7_subr_2
:
3290 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3292 args
= SCM_CAR (args
);
3293 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3294 case scm_tc7_subr_0
:
3295 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3296 RETURN (SCM_SUBRF (proc
) ())
3297 case scm_tc7_subr_1
:
3298 case scm_tc7_subr_1o
:
3299 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3300 RETURN (SCM_SUBRF (proc
) (arg1
))
3302 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3303 if (SCM_SUBRF (proc
))
3305 if (SCM_INUMP (arg1
))
3307 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3309 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3310 if (SCM_REALP (arg1
))
3312 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3315 if (SCM_BIGP (arg1
))
3316 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3319 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3320 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3322 proc
= SCM_SNAME (proc
);
3324 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3325 while ('c' != *--chrs
)
3327 SCM_ASSERT (SCM_CONSP (arg1
),
3328 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3329 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3333 case scm_tc7_subr_3
:
3334 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3337 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3339 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3341 case scm_tc7_lsubr_2
:
3342 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3343 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3345 if (SCM_NULLP (args
))
3346 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3347 while (SCM_NIMP (args
))
3349 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3350 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3351 args
= SCM_CDR (args
);
3354 case scm_tc7_rpsubr
:
3355 if (SCM_NULLP (args
))
3356 RETURN (SCM_BOOL_T
);
3357 while (SCM_NIMP (args
))
3359 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3360 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3361 RETURN (SCM_BOOL_F
);
3362 arg1
= SCM_CAR (args
);
3363 args
= SCM_CDR (args
);
3365 RETURN (SCM_BOOL_T
);
3366 case scm_tcs_closures
:
3368 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3370 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3372 #ifndef SCM_RECKLESS
3373 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3377 /* Copy argument list */
3382 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3383 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3385 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3389 SCM_SETCDR (tl
, arg1
);
3392 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3393 proc
= SCM_CDR (SCM_CODE (proc
));
3396 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3398 if (SCM_IMP (SCM_CAR (proc
)))
3400 if (SCM_ISYMP (SCM_CAR (proc
)))
3402 proc
= scm_m_expand_body (proc
, args
);
3407 SCM_CEVAL (SCM_CAR (proc
), args
);
3410 RETURN (EVALCAR (proc
, args
));
3412 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3414 if (SCM_UNBNDP (arg1
))
3415 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_0 (proc
))
3416 else if (SCM_NULLP (args
))
3417 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_1 (proc
, arg1
))
3418 else if (SCM_NULLP (SCM_CDR (args
)))
3419 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_2
3420 (proc
, arg1
, SCM_CAR (args
)))
3422 RETURN (SCM_SMOB_DESCRIPTOR (proc
).apply_3
3423 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3426 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3428 proc
= SCM_CCLO_SUBR (proc
);
3429 debug
.vect
[0].a
.proc
= proc
;
3430 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3432 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3434 proc
= SCM_CCLO_SUBR (proc
);
3438 proc
= SCM_PROCEDURE (proc
);
3440 debug
.vect
[0].a
.proc
= proc
;
3443 case scm_tcs_cons_gloc
:
3444 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3447 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3449 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3451 RETURN (scm_apply_generic (proc
, args
));
3453 else if (!SCM_I_OPERATORP (proc
))
3458 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3460 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3463 proc
= (SCM_I_ENTITYP (proc
)
3464 ? SCM_ENTITY_PROCEDURE (proc
)
3465 : SCM_OPERATOR_PROCEDURE (proc
));
3467 debug
.vect
[0].a
.proc
= proc
;
3468 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3470 if (SCM_NIMP (proc
))
3476 scm_wrong_num_args (proc
);
3479 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3484 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3485 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3487 SCM_CLEAR_TRACED_FRAME (debug
);
3488 if (SCM_CHEAPTRAPS_P
)
3489 arg1
= scm_make_debugobj (&debug
);
3493 SCM val
= scm_make_continuation (&first
);
3503 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3506 scm_last_debug_frame
= debug
.prev
;
3512 /* SECTION: The rest of this file is only read once.
3517 /* Typechecking for multi-argument MAP and FOR-EACH.
3519 Verify that each element of the vector ARGV, except for the first,
3520 is a proper list whose length is LEN. Attribute errors to WHO,
3521 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3523 check_map_args (SCM argv
,
3530 SCM
*ve
= SCM_VELTS (argv
);
3533 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3535 int elt_len
= scm_ilength (ve
[i
]);
3540 scm_apply_generic (gf
, scm_cons (proc
, args
));
3542 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3546 scm_out_of_range (who
, ve
[i
]);
3549 scm_remember (&argv
);
3553 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3555 /* Note: Currently, scm_map applies PROC to the argument list(s)
3556 sequentially, starting with the first element(s). This is used in
3557 evalext.c where the Scheme procedure `map-in-order', which guarantees
3558 sequential behaviour, is implemented using scm_map. If the
3559 behaviour changes, we need to update `map-in-order'.
3563 scm_map (SCM proc
, SCM arg1
, SCM args
)
3564 #define FUNC_NAME s_map
3569 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3571 len
= scm_ilength (arg1
);
3572 SCM_GASSERTn (len
>= 0,
3573 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3574 SCM_VALIDATE_REST_ARGUMENT (args
);
3575 if (SCM_NULLP (args
))
3577 while (SCM_NIMP (arg1
))
3579 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3581 pres
= SCM_CDRLOC (*pres
);
3582 arg1
= SCM_CDR (arg1
);
3586 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3587 ve
= SCM_VELTS (args
);
3588 #ifndef SCM_RECKLESS
3589 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3594 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3596 if (SCM_IMP (ve
[i
]))
3598 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3599 ve
[i
] = SCM_CDR (ve
[i
]);
3601 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3602 pres
= SCM_CDRLOC (*pres
);
3608 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3611 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3612 #define FUNC_NAME s_for_each
3614 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3616 len
= scm_ilength (arg1
);
3617 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3618 SCM_ARG2
, s_for_each
);
3619 SCM_VALIDATE_REST_ARGUMENT (args
);
3622 while SCM_NIMP (arg1
)
3624 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3625 arg1
= SCM_CDR (arg1
);
3627 return SCM_UNSPECIFIED
;
3629 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3630 ve
= SCM_VELTS (args
);
3631 #ifndef SCM_RECKLESS
3632 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3637 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3640 (ve
[i
]) return SCM_UNSPECIFIED
;
3641 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3642 ve
[i
] = SCM_CDR (ve
[i
]);
3644 scm_apply (proc
, arg1
, SCM_EOL
);
3651 scm_closure (SCM code
, SCM env
)
3655 SCM_SETCODE (z
, code
);
3656 SCM_SETENV (z
, env
);
3661 long scm_tc16_promise
;
3664 scm_makprom (SCM code
)
3666 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3672 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3674 int writingp
= SCM_WRITINGP (pstate
);
3675 scm_puts ("#<promise ", port
);
3676 SCM_SET_WRITINGP (pstate
, 1);
3677 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3678 SCM_SET_WRITINGP (pstate
, writingp
);
3679 scm_putc ('>', port
);
3684 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3686 "If the promise X has not been computed yet, compute and return\n"
3687 "X, otherwise just return the previously computed value.")
3688 #define FUNC_NAME s_scm_force
3690 SCM_VALIDATE_SMOB (1, x
, promise
);
3691 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3693 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3694 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3697 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3698 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3702 return SCM_CELL_OBJECT_1 (x
);
3707 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3709 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3710 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3711 #define FUNC_NAME s_scm_promise_p
3713 return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise
, x
));
3718 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3719 (SCM xorig
, SCM x
, SCM y
),
3720 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3721 "Any source properties associated with @var{xorig} are also associated\n"
3722 "with the new pair.")
3723 #define FUNC_NAME s_scm_cons_source
3727 SCM_SET_CELL_OBJECT_0 (z
, x
);
3728 SCM_SET_CELL_OBJECT_1 (z
, y
);
3729 /* Copy source properties possibly associated with xorig. */
3730 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3732 scm_whash_insert (scm_source_whash
, z
, p
);
3738 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3740 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3741 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3742 "contents of both pairs and vectors (since both cons cells and vector\n"
3743 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3744 "any other object.")
3745 #define FUNC_NAME s_scm_copy_tree
3750 if (SCM_VECTORP (obj
))
3752 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3753 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3755 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3758 if (SCM_NCONSP (obj
))
3760 ans
= tl
= scm_cons_source (obj
,
3761 scm_copy_tree (SCM_CAR (obj
)),
3763 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3765 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3769 SCM_SETCDR (tl
, obj
);
3775 SCM scm_system_transformer
;
3778 scm_i_eval_x (SCM exp
, SCM env
)
3780 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3781 if (SCM_NIMP (transformer
))
3782 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3783 return SCM_XEVAL (exp
, env
);
3787 scm_i_eval (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 (scm_copy_tree (exp
), env
);
3796 scm_eval_x (SCM exp
, SCM module
)
3798 return scm_i_eval_x (exp
,
3799 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module
)));
3802 /* Eval does not take the second arg optionally. This is intentional
3803 * in order to be R5RS compatible, and to prepare for the new module
3804 * system, where we would like to make the choice of evaluation
3805 * environment explicit.
3808 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3809 (SCM exp
, SCM environment
),
3810 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3811 "environment given by @var{environment specifier}.")
3812 #define FUNC_NAME s_scm_eval
3814 SCM_VALIDATE_MODULE (2, environment
);
3815 return scm_i_eval (scm_copy_tree (exp
),
3816 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment
)));
3820 #if (SCM_DEBUG_DEPRECATED == 0)
3822 /* Use scm_selected_module () or scm_interaction_environment ()
3823 * instead. The former is the module selected during loading of code.
3824 * The latter is the module in which the user of this thread currently
3825 * types expressions.
3828 SCM scm_top_level_lookup_closure_var
;
3830 /* Avoid using this functionality altogether (except for implementing
3831 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3833 * Applications should use either C level scm_eval_x or Scheme scm_eval. */
3836 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3839 return scm_i_eval (obj
, env
);
3841 return scm_i_eval_x (obj
, env
);
3844 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3845 (SCM obj
, SCM env_thunk
),
3846 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3847 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3848 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3849 #define FUNC_NAME s_scm_eval2
3851 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3855 #endif /* DEPRECATED */
3858 /* At this point, scm_deval and scm_dapply are generated.
3861 #ifdef DEBUG_EXTENSIONS
3871 scm_init_opts (scm_evaluator_traps
,
3872 scm_evaluator_trap_table
,
3873 SCM_N_EVALUATOR_TRAPS
);
3874 scm_init_opts (scm_eval_options_interface
,
3876 SCM_N_EVAL_OPTIONS
);
3878 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3879 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3880 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3882 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3883 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
3885 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3886 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3887 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3888 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3889 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3891 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3892 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3893 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3894 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3895 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3896 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3901 #if SCM_DEBUG_DEPRECATED == 0
3902 scm_top_level_lookup_closure_var
=
3903 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
3906 #ifdef DEBUG_EXTENSIONS
3907 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3908 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3909 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3910 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3913 #ifndef SCM_MAGIC_SNARFER
3914 #include "libguile/eval.x"
3917 scm_add_feature ("delay");