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"
107 SCM (*scm_memoize_method
) (SCM
, SCM
);
111 /* The evaluator contains a plethora of EVAL symbols.
112 * This is an attempt at explanation.
114 * The following macros should be used in code which is read twice
115 * (where the choice of evaluator is hard soldered):
117 * SCM_CEVAL is the symbol used within one evaluator to call itself.
118 * Originally, it is defined to scm_ceval, but is redefined to
119 * scm_deval during the second pass.
121 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
122 * only side effects of expressions matter. All immediates are
125 * SCM_EVALIM is used when it is known that the expression is an
126 * immediate. (This macro never calls an evaluator.)
128 * EVALCAR evaluates the car of an expression.
130 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
131 * car is a lisp cell.
133 * The following macros should be used in code which is read once
134 * (where the choice of evaluator is dynamic):
136 * SCM_XEVAL takes care of immediates without calling an evaluator. It
137 * then calls scm_ceval *or* scm_deval, depending on the debugging
140 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
141 * depending on the debugging mode.
143 * The main motivation for keeping this plethora is efficiency
144 * together with maintainability (=> locality of code).
147 #define SCM_CEVAL scm_ceval
148 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
150 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
151 ? *scm_lookupcar (x, env, 1) \
152 : SCM_CEVAL (SCM_CAR (x), env))
154 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
155 ? (SCM_IMP (SCM_CAR (x)) \
156 ? SCM_EVALIM (SCM_CAR (x), env) \
157 : SCM_GLOC_VAL (SCM_CAR (x))) \
158 : EVALCELLCAR (x, env))
160 #define EXTEND_ENV SCM_EXTEND_ENV
162 #ifdef MEMOIZE_LOCALS
165 scm_ilookup (SCM iloc
, SCM env
)
167 register int ir
= SCM_IFRAME (iloc
);
168 register SCM er
= env
;
169 for (; 0 != ir
; --ir
)
172 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
174 if (SCM_ICDRP (iloc
))
175 return SCM_CDRLOC (er
);
176 return SCM_CARLOC (SCM_CDR (er
));
182 /* The Lookup Car Race
185 Memoization of variables and special forms is done while executing
186 the code for the first time. As long as there is only one thread
187 everything is fine, but as soon as two threads execute the same
188 code concurrently `for the first time' they can come into conflict.
190 This memoization includes rewriting variable references into more
191 efficient forms and expanding macros. Furthermore, macro expansion
192 includes `compiling' special forms like `let', `cond', etc. into
193 tree-code instructions.
195 There shouldn't normally be a problem with memoizing local and
196 global variable references (into ilocs and glocs), because all
197 threads will mutate the code in *exactly* the same way and (if I
198 read the C code correctly) it is not possible to observe a half-way
199 mutated cons cell. The lookup procedure can handle this
200 transparently without any critical sections.
202 It is different with macro expansion, because macro expansion
203 happens outside of the lookup procedure and can't be
204 undone. Therefore it can't cope with it. It has to indicate
205 failure when it detects a lost race and hope that the caller can
206 handle it. Luckily, it turns out that this is the case.
208 An example to illustrate this: Suppose that the follwing form will
209 be memoized concurrently by two threads
213 Let's first examine the lookup of X in the body. The first thread
214 decides that it has to find the symbol "x" in the environment and
215 starts to scan it. Then the other thread takes over and actually
216 overtakes the first. It looks up "x" and substitutes an
217 appropriate iloc for it. Now the first thread continues and
218 completes its lookup. It comes to exactly the same conclusions as
219 the second one and could - without much ado - just overwrite the
220 iloc with the same iloc.
222 But let's see what will happen when the race occurs while looking
223 up the symbol "let" at the start of the form. It could happen that
224 the second thread interrupts the lookup of the first thread and not
225 only substitutes a gloc for it but goes right ahead and replaces it
226 with the compiled form (#@let* (x 12) x). Now, when the first
227 thread completes its lookup, it would replace the #@let* with a
228 gloc pointing to the "let" binding, effectively reverting the form
229 to (let (x 12) x). This is wrong. It has to detect that it has
230 lost the race and the evaluator has to reconsider the changed form
233 This race condition could be resolved with some kind of traffic
234 light (like mutexes) around scm_lookupcar, but I think that it is
235 best to avoid them in this case. They would serialize memoization
236 completely and because lookup involves calling arbitrary Scheme
237 code (via the lookup-thunk), threads could be blocked for an
238 arbitrary amount of time or even deadlock. But with the current
239 solution a lot of unnecessary work is potentially done. */
241 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
242 return NULL to indicate a failed lookup due to some race conditions
243 between threads. This only happens when VLOC is the first cell of
244 a special form that will eventually be memoized (like `let', etc.)
245 In that case the whole lookup is bogus and the caller has to
246 reconsider the complete special form.
248 SCM_LOOKUPCAR is still there, of course. It just calls
249 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
250 should only be called when it is known that VLOC is not the first
251 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
252 for NULL. I think I've found the only places where this
255 #endif /* USE_THREADS */
257 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
261 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
264 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
268 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
270 register SCM var2
= var
;
272 #ifdef MEMOIZE_LOCALS
273 register SCM iloc
= SCM_ILOC00
;
275 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
277 if (!SCM_CONSP (SCM_CAR (env
)))
279 al
= SCM_CARLOC (env
);
280 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
284 if (SCM_EQ_P (fl
, var
))
286 #ifdef MEMOIZE_LOCALS
288 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
291 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
293 return SCM_CDRLOC (*al
);
298 al
= SCM_CDRLOC (*al
);
299 if (SCM_EQ_P (SCM_CAR (fl
), var
))
301 #ifdef MEMOIZE_LOCALS
302 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
303 if (SCM_UNBNDP (SCM_CAR (*al
)))
310 if (SCM_CAR (vloc
) != var
)
313 SCM_SETCAR (vloc
, iloc
);
315 return SCM_CARLOC (*al
);
317 #ifdef MEMOIZE_LOCALS
318 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
321 #ifdef MEMOIZE_LOCALS
322 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
326 SCM top_thunk
, vcell
;
329 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
333 top_thunk
= SCM_BOOL_F
;
334 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
335 if (SCM_FALSEP (vcell
))
341 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
345 /* scm_everr (vloc, genv,...) */
349 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
350 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
352 scm_misc_error (NULL
, "Damaged environment: ~S",
353 scm_cons (var
, SCM_EOL
));
356 /* A variable could not be found, but we shall not throw an error. */
357 static SCM undef_object
= SCM_UNDEFINED
;
358 return &undef_object
;
363 if (SCM_CAR (vloc
) != var2
)
365 /* Some other thread has changed the very cell we are working
366 on. In effect, it must have done our job or messed it up
369 var
= SCM_CAR (vloc
);
370 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
371 return SCM_GLOC_VAL_LOC (var
);
372 #ifdef MEMOIZE_LOCALS
373 if ((SCM_UNPACK (var
) & 127) == (127 & SCM_UNPACK (SCM_ILOC00
)))
374 return scm_ilookup (var
, genv
);
376 /* We can't cope with anything else than glocs and ilocs. When
377 a special form has been memoized (i.e. `let' into `#@let') we
378 return NULL and expect the calling function to do the right
379 thing. For the evaluator, this means going back and redoing
380 the dispatch on the car of the form. */
383 #endif /* USE_THREADS */
385 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
386 /* Except wait...what if the var is not a vcell,
387 * but syntax or something.... */
388 return SCM_CDRLOC (var
);
393 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
395 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
402 #define unmemocar scm_unmemocar
405 scm_unmemocar (SCM form
, SCM env
)
412 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
413 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
414 #ifdef MEMOIZE_LOCALS
415 #ifdef DEBUG_EXTENSIONS
416 else if (SCM_ILOCP (c
))
420 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
422 env
= SCM_CAR (SCM_CAR (env
));
423 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
425 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
434 scm_eval_car (SCM pair
, SCM env
)
436 return SCM_XEVALCAR (pair
, env
);
441 * The following rewrite expressions and
442 * some memoized forms have different syntax
445 const char scm_s_expression
[] = "missing or extra expression";
446 const char scm_s_test
[] = "bad test";
447 const char scm_s_body
[] = "bad body";
448 const char scm_s_bindings
[] = "bad bindings";
449 const char scm_s_variable
[] = "bad variable";
450 const char scm_s_clauses
[] = "bad or missing clauses";
451 const char scm_s_formals
[] = "bad formals";
453 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
454 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
458 #ifdef DEBUG_EXTENSIONS
459 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
464 /* Check that the body denoted by XORIG is valid and rewrite it into
465 its internal form. The internal form of a body is just the body
466 itself, but prefixed with an ISYM that denotes to what kind of
467 outer construct this body belongs. A lambda body starts with
468 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
469 etc. The one exception is a body that belongs to a letrec that has
470 been formed by rewriting internal defines: it starts with
473 /* XXX - Besides controlling the rewriting of internal defines, the
474 additional ISYM could be used for improved error messages.
475 This is not done yet. */
478 scm_m_body (SCM op
, SCM xorig
, const char *what
)
480 SCM_ASSYNT (scm_ilength (xorig
) >= 1, xorig
, scm_s_expression
, what
);
482 /* Don't add another ISYM if one is present already. */
483 if (SCM_ISYMP (SCM_CAR (xorig
)))
486 /* Retain possible doc string. */
487 if (!SCM_CONSP (SCM_CAR (xorig
)))
489 if (SCM_NNULLP (SCM_CDR(xorig
)))
490 return scm_cons (SCM_CAR (xorig
),
491 scm_m_body (op
, SCM_CDR(xorig
), what
));
495 return scm_cons (op
, xorig
);
498 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
499 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
502 scm_m_quote (SCM xorig
, SCM env
)
504 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
506 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
507 xorig
, scm_s_expression
, s_quote
);
508 return scm_cons (SCM_IM_QUOTE
, x
);
513 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
514 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
517 scm_m_begin (SCM xorig
, SCM env
)
519 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
520 xorig
, scm_s_expression
, s_begin
);
521 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
524 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
525 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
528 scm_m_if (SCM xorig
, SCM env
)
530 int len
= scm_ilength (SCM_CDR (xorig
));
531 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
532 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
536 /* Will go into the RnRS module when Guile is factorized.
537 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
538 const char scm_s_set_x
[] = "set!";
539 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
542 scm_m_set_x (SCM xorig
, SCM env
)
544 SCM x
= SCM_CDR (xorig
);
545 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
546 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
547 xorig
, scm_s_variable
, scm_s_set_x
);
548 return scm_cons (SCM_IM_SET_X
, x
);
555 scm_m_vref (SCM xorig
, SCM env
)
557 SCM x
= SCM_CDR (xorig
);
558 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
559 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
561 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
562 scm_misc_error (NULL
,
564 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
566 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
567 xorig
, scm_s_variable
, s_vref
);
568 return scm_cons (IM_VREF
, x
);
574 scm_m_vset (SCM xorig
, SCM env
)
576 SCM x
= SCM_CDR (xorig
);
577 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
578 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
579 || UDSCM_VARIABLEP (SCM_CAR (x
))),
580 xorig
, scm_s_variable
, s_vset
);
581 return scm_cons (IM_VSET
, x
);
586 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
587 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
590 scm_m_and (SCM xorig
, SCM env
)
592 int len
= scm_ilength (SCM_CDR (xorig
));
593 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
595 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
600 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
601 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
604 scm_m_or (SCM xorig
, SCM env
)
606 int len
= scm_ilength (SCM_CDR (xorig
));
607 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
609 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
615 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
616 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
619 scm_m_case (SCM xorig
, SCM env
)
621 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
622 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
623 while (SCM_NIMP (x
= SCM_CDR (x
)))
626 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
627 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
628 || SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)),
629 xorig
, scm_s_clauses
, s_case
);
631 return scm_cons (SCM_IM_CASE
, cdrx
);
635 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
636 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
640 scm_m_cond (SCM xorig
, SCM env
)
642 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
643 int len
= scm_ilength (x
);
644 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
648 len
= scm_ilength (arg1
);
649 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
650 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
652 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
653 xorig
, "bad ELSE clause", s_cond
);
654 SCM_SETCAR (arg1
, SCM_BOOL_T
);
656 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
657 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
658 xorig
, "bad recipient", s_cond
);
661 return scm_cons (SCM_IM_COND
, cdrx
);
664 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
665 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
668 scm_m_lambda (SCM xorig
, SCM env
)
670 SCM proc
, x
= SCM_CDR (xorig
);
671 if (scm_ilength (x
) < 2)
674 if (SCM_NULLP (proc
))
676 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
680 if (SCM_SYMBOLP (proc
))
682 if (SCM_NCONSP (proc
))
684 while (SCM_NIMP (proc
))
686 if (SCM_NCONSP (proc
))
688 if (!SCM_SYMBOLP (proc
))
693 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
695 proc
= SCM_CDR (proc
);
697 if (SCM_NNULLP (proc
))
700 scm_wta (xorig
, scm_s_formals
, s_lambda
);
704 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
705 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
708 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
709 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
713 scm_m_letstar (SCM xorig
, SCM env
)
715 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
716 int len
= scm_ilength (x
);
717 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
719 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
720 while (SCM_NIMP (proc
))
722 arg1
= SCM_CAR (proc
);
723 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
724 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
725 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
726 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
727 proc
= SCM_CDR (proc
);
729 x
= scm_cons (vars
, SCM_CDR (x
));
731 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
732 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
735 /* DO gets the most radically altered syntax
736 (do ((<var1> <init1> <step1>)
742 (do_mem (varn ... var2 var1)
743 (<init1> <init2> ... <initn>)
746 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
749 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
750 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
753 scm_m_do (SCM xorig
, SCM env
)
755 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
756 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
757 SCM
*initloc
= &inits
, *steploc
= &steps
;
758 int len
= scm_ilength (x
);
759 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
761 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
762 while (SCM_NIMP(proc
))
764 arg1
= SCM_CAR (proc
);
765 len
= scm_ilength (arg1
);
766 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
767 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
768 /* vars reversed here, inits and steps reversed at evaluation */
769 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
770 arg1
= SCM_CDR (arg1
);
771 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
772 initloc
= SCM_CDRLOC (*initloc
);
773 arg1
= SCM_CDR (arg1
);
774 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
775 steploc
= SCM_CDRLOC (*steploc
);
776 proc
= SCM_CDR (proc
);
779 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
780 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
781 x
= scm_cons2 (vars
, inits
, x
);
782 return scm_cons (SCM_IM_DO
, x
);
785 /* evalcar is small version of inline EVALCAR when we don't care about
788 #define evalcar scm_eval_car
791 static SCM
iqq (SCM form
, SCM env
, int depth
);
793 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
794 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
797 scm_m_quasiquote (SCM xorig
, SCM env
)
799 SCM x
= SCM_CDR (xorig
);
800 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
801 return iqq (SCM_CAR (x
), env
, 1);
806 iqq (SCM form
,SCM env
,int depth
)
812 if (SCM_VECTORP (form
))
814 long i
= SCM_LENGTH (form
);
815 SCM
*data
= SCM_VELTS (form
);
818 tmp
= scm_cons (data
[i
], tmp
);
819 return scm_vector (iqq (tmp
, env
, depth
));
821 if (SCM_NCONSP(form
))
823 tmp
= SCM_CAR (form
);
824 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
829 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
833 form
= SCM_CDR (form
);
834 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
835 form
, SCM_ARG1
, s_quasiquote
);
837 return evalcar (form
, env
);
838 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
840 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
844 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
846 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
849 /* Here are acros which return values rather than code. */
851 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
852 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
855 scm_m_delay (SCM xorig
, SCM env
)
857 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
858 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
862 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
863 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
866 scm_m_define (SCM x
, SCM env
)
870 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
871 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
874 while (SCM_CONSP (proc
))
875 { /* nested define syntax */
876 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
877 proc
= SCM_CAR (proc
);
879 SCM_ASSYNT (SCM_SYMBOLP (proc
),
880 arg1
, scm_s_variable
, s_define
);
881 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
882 if (SCM_TOP_LEVEL (env
))
884 x
= evalcar (x
, env
);
885 #ifdef DEBUG_EXTENSIONS
886 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
890 if (SCM_CLOSUREP (arg1
)
891 /* Only the first definition determines the name. */
892 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
893 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
894 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
895 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
897 arg1
= SCM_CDR (arg1
);
902 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
903 SCM_SETCDR (arg1
, x
);
905 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
907 return SCM_UNSPECIFIED
;
910 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
916 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
918 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
919 char *what
= SCM_CHARS (SCM_CAR (xorig
));
920 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
921 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
924 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
927 /* vars scm_list reversed here, inits reversed at evaluation */
928 arg1
= SCM_CAR (proc
);
929 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
930 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
931 vars
= scm_cons (SCM_CAR (arg1
), vars
);
932 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
933 initloc
= SCM_CDRLOC (*initloc
);
935 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
937 return scm_cons2 (op
, vars
,
938 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
941 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
942 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
945 scm_m_letrec (SCM xorig
, SCM env
)
947 SCM x
= SCM_CDR (xorig
);
948 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
950 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
951 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
952 scm_m_body (SCM_IM_LETREC
,
957 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
960 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
961 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
964 scm_m_let (SCM xorig
, SCM env
)
966 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
967 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
968 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
970 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
974 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
976 /* null or single binding, let* is faster */
977 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
978 scm_m_body (SCM_IM_LET
,
984 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
985 if (SCM_CONSP (proc
))
987 /* plain let, proc is <bindings> */
988 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
991 if (!SCM_SYMBOLP (proc
))
992 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
993 name
= proc
; /* named let, build equiv letrec */
995 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
996 proc
= SCM_CAR (x
); /* bindings list */
997 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
998 while (SCM_NIMP (proc
))
999 { /* vars and inits both in order */
1000 arg1
= SCM_CAR (proc
);
1001 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1002 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1003 xorig
, scm_s_variable
, s_let
);
1004 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1005 varloc
= SCM_CDRLOC (*varloc
);
1006 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1007 initloc
= SCM_CDRLOC (*initloc
);
1008 proc
= SCM_CDR (proc
);
1011 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1012 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1013 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1015 scm_acons (name
, inits
, SCM_EOL
));
1016 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1020 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1021 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1022 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1025 scm_m_apply (SCM xorig
, SCM env
)
1027 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1028 xorig
, scm_s_expression
, s_atapply
);
1029 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1033 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1034 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1038 scm_m_cont (SCM xorig
, SCM env
)
1040 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1041 xorig
, scm_s_expression
, s_atcall_cc
);
1042 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1045 /* Multi-language support */
1050 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1053 scm_m_nil_cond (SCM xorig
, SCM env
)
1055 int len
= scm_ilength (SCM_CDR (xorig
));
1056 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1057 scm_s_expression
, "nil-cond");
1058 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1061 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1064 scm_m_nil_ify (SCM xorig
, SCM env
)
1066 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1067 xorig
, scm_s_expression
, "nil-ify");
1068 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1071 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1074 scm_m_t_ify (SCM xorig
, SCM env
)
1076 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1077 xorig
, scm_s_expression
, "t-ify");
1078 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1081 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1084 scm_m_0_cond (SCM xorig
, SCM env
)
1086 int len
= scm_ilength (SCM_CDR (xorig
));
1087 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1088 scm_s_expression
, "0-cond");
1089 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1095 scm_m_0_ify (SCM xorig
, SCM env
)
1097 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1098 xorig
, scm_s_expression
, "0-ify");
1099 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1102 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1105 scm_m_1_ify (SCM xorig
, SCM env
)
1107 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1108 xorig
, scm_s_expression
, "1-ify");
1109 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1112 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1115 scm_m_atfop (SCM xorig
, SCM env
)
1117 SCM x
= SCM_CDR (xorig
), vcell
;
1118 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1119 vcell
= scm_symbol_fref (SCM_CAR (x
));
1120 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1121 "Symbol's function definition is void", NULL
);
1122 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1126 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1129 scm_m_atbind (SCM xorig
, SCM env
)
1131 SCM x
= SCM_CDR (xorig
);
1132 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1138 while (SCM_NIMP (SCM_CDR (env
)))
1139 env
= SCM_CDR (env
);
1140 env
= SCM_CAR (env
);
1141 if (SCM_CONSP (env
))
1146 while (SCM_NIMP (x
))
1148 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1151 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1155 scm_m_expand_body (SCM xorig
, SCM env
)
1157 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1158 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1160 while (SCM_NIMP (x
))
1163 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1165 if (SCM_IMP (SCM_CAR (form
)))
1167 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1170 form
= scm_macroexp (scm_cons_source (form
,
1175 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1177 defs
= scm_cons (SCM_CDR (form
), defs
);
1180 else if (SCM_NIMP(defs
))
1184 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1186 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1190 x
= scm_cons (form
, SCM_CDR(x
));
1195 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1196 if (SCM_NIMP (defs
))
1198 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1200 scm_cons2 (scm_sym_define
, defs
, x
),
1206 SCM_SETCAR (xorig
, SCM_CAR (x
));
1207 SCM_SETCDR (xorig
, SCM_CDR (x
));
1214 scm_macroexp (SCM x
, SCM env
)
1218 /* Don't bother to produce error messages here. We get them when we
1219 eventually execute the code for real. */
1222 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1227 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1228 if (proc_ptr
== NULL
)
1230 /* We have lost the race. */
1236 proc
= *scm_lookupcar (x
, env
, 0);
1239 /* Only handle memoizing macros. `Acros' and `macros' are really
1240 special forms and should not be evaluated here. */
1243 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1244 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1248 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1250 if (scm_ilength (res
) <= 0)
1251 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1254 SCM_SETCAR (x
, SCM_CAR (res
));
1255 SCM_SETCDR (x
, SCM_CDR (res
));
1261 /* scm_unmemocopy takes a memoized expression together with its
1262 * environment and rewrites it to its original form. Thus, it is the
1263 * inversion of the rewrite rules above. The procedure is not
1264 * optimized for speed. It's used in scm_iprin1 when printing the
1265 * code of a closure, in scm_procedure_source, in display_frame when
1266 * generating the source for a stackframe in a backtrace, and in
1267 * display_expression.
1270 /* We should introduce an anti-macro interface so that it is possible
1271 * to plug in transformers in both directions from other compilation
1272 * units. unmemocopy could then dispatch to anti-macro transformers.
1273 * (Those transformers could perhaps be written in slightly more
1274 * readable style... :)
1277 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1280 unmemocopy (SCM x
, SCM env
)
1283 #ifdef DEBUG_EXTENSIONS
1286 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1288 #ifdef DEBUG_EXTENSIONS
1289 p
= scm_whash_lookup (scm_source_whash
, x
);
1291 switch (SCM_TYP7 (x
))
1293 case SCM_BIT8(SCM_IM_AND
):
1294 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1296 case SCM_BIT8(SCM_IM_BEGIN
):
1297 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1299 case SCM_BIT8(SCM_IM_CASE
):
1300 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1302 case SCM_BIT8(SCM_IM_COND
):
1303 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1305 case SCM_BIT8(SCM_IM_DO
):
1306 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1308 case SCM_BIT8(SCM_IM_IF
):
1309 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1311 case SCM_BIT8(SCM_IM_LET
):
1312 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1314 case SCM_BIT8(SCM_IM_LETREC
):
1317 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1321 f
= v
= SCM_CAR (x
);
1323 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1325 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1326 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1329 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1330 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1332 /* build transformed binding list */
1334 while (SCM_NIMP (v
))
1336 z
= scm_acons (SCM_CAR (v
),
1337 scm_cons (SCM_CAR (e
),
1338 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1340 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1346 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1348 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1352 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1355 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1356 /* body forms are now to be found in SCM_CDR (x)
1357 (this is how *real* code look like! :) */
1361 case SCM_BIT8(SCM_IM_LETSTAR
):
1369 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1372 y
= z
= scm_acons (SCM_CAR (b
),
1374 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1376 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1377 b
= SCM_CDR (SCM_CDR (b
));
1380 SCM_SETCDR (y
, SCM_EOL
);
1381 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1386 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1388 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1391 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1392 b
= SCM_CDR (SCM_CDR (b
));
1394 while (SCM_NIMP (b
));
1395 SCM_SETCDR (z
, SCM_EOL
);
1397 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1400 case SCM_BIT8(SCM_IM_OR
):
1401 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1403 case SCM_BIT8(SCM_IM_LAMBDA
):
1405 ls
= scm_cons (scm_sym_lambda
,
1406 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1407 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1409 case SCM_BIT8(SCM_IM_QUOTE
):
1410 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1412 case SCM_BIT8(SCM_IM_SET_X
):
1413 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1415 case SCM_BIT8(SCM_IM_DEFINE
):
1419 ls
= scm_cons (scm_sym_define
,
1420 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1421 if (SCM_NNULLP (env
))
1422 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1425 case SCM_BIT8(SCM_MAKISYM (0)):
1429 switch (SCM_ISYMNUM (z
))
1431 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1432 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1434 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1435 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1437 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1438 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1442 /* appease the Sun compiler god: */ ;
1446 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1451 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1453 if (SCM_ISYMP (SCM_CAR (x
)))
1454 /* skip body markers */
1456 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1462 #ifdef DEBUG_EXTENSIONS
1463 if (SCM_NFALSEP (p
))
1464 scm_whash_insert (scm_source_whash
, ls
, p
);
1471 scm_unmemocopy (SCM x
, SCM env
)
1473 if (SCM_NNULLP (env
))
1474 /* Make a copy of the lowest frame to protect it from
1475 modifications by SCM_IM_DEFINE */
1476 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1478 return unmemocopy (x
, env
);
1481 #ifndef SCM_RECKLESS
1484 scm_badargsp (SCM formals
, SCM args
)
1486 while (SCM_NIMP (formals
))
1488 if (SCM_NCONSP (formals
))
1492 formals
= SCM_CDR (formals
);
1493 args
= SCM_CDR (args
);
1495 return SCM_NNULLP (args
) ? 1 : 0;
1500 scm_badformalsp (SCM closure
, int n
)
1502 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1503 while (SCM_NIMP (formals
))
1505 if (SCM_NCONSP (formals
))
1510 formals
= SCM_CDR (formals
);
1517 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1519 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1520 while (SCM_NIMP (l
))
1525 if (SCM_IMP (SCM_CAR (l
)))
1526 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1528 res
= EVALCELLCAR (l
, env
);
1530 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1532 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1534 res
= SCM_CAR (l
); /* struct planted in code */
1536 res
= SCM_PACK (vcell
);
1541 res
= EVALCAR (l
, env
);
1543 *lloc
= scm_cons (res
, SCM_EOL
);
1544 lloc
= SCM_CDRLOC (*lloc
);
1551 scm_wrong_num_args (proc
);
1558 scm_eval_body (SCM code
, SCM env
)
1563 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1565 if (SCM_IMP (SCM_CAR (code
)))
1567 if (SCM_ISYMP (SCM_CAR (code
)))
1569 code
= scm_m_expand_body (code
, env
);
1574 SCM_XEVAL (SCM_CAR (code
), env
);
1577 return SCM_XEVALCAR (code
, env
);
1584 /* SECTION: This code is specific for the debugging support. One
1585 * branch is read when DEVAL isn't defined, the other when DEVAL is
1591 #define SCM_APPLY scm_apply
1592 #define PREP_APPLY(proc, args)
1594 #define RETURN(x) return x;
1595 #ifdef STACK_CHECKING
1596 #ifndef NO_CEVAL_STACK_CHECKING
1597 #define EVAL_STACK_CHECKING
1604 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1606 #define SCM_APPLY scm_dapply
1608 #define PREP_APPLY(p, l) \
1609 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1611 #define ENTER_APPLY \
1613 SCM_SET_ARGSREADY (debug);\
1614 if (CHECK_APPLY && SCM_TRAPS_P)\
1615 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1617 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1618 SCM_SET_TRACED_FRAME (debug); \
1619 if (SCM_CHEAPTRAPS_P)\
1621 tmp = scm_make_debugobj (&debug);\
1622 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1626 scm_make_cont (&tmp);\
1627 if (!setjmp (SCM_JMPBUF (tmp)))\
1628 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1633 #define RETURN(e) {proc = (e); goto exit;}
1634 #ifdef STACK_CHECKING
1635 #ifndef EVAL_STACK_CHECKING
1636 #define EVAL_STACK_CHECKING
1640 /* scm_ceval_ptr points to the currently selected evaluator.
1641 * *fixme*: Although efficiency is important here, this state variable
1642 * should probably not be a global. It should be related to the
1647 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1649 /* scm_last_debug_frame contains a pointer to the last debugging
1650 * information stack frame. It is accessed very often from the
1651 * debugging evaluator, so it should probably not be indirectly
1652 * addressed. Better to save and restore it from the current root at
1657 scm_debug_frame
*scm_last_debug_frame
;
1660 /* scm_debug_eframe_size is the number of slots available for pseudo
1661 * stack frames at each real stack frame.
1664 int scm_debug_eframe_size
;
1666 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1670 scm_option scm_eval_opts
[] = {
1671 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1674 scm_option scm_debug_opts
[] = {
1675 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1676 "*Flyweight representation of the stack at traps." },
1677 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1678 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1679 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1680 "Record procedure names at definition." },
1681 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1682 "Display backtrace in anti-chronological order." },
1683 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1684 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1685 { SCM_OPTION_INTEGER
, "frames", 3,
1686 "Maximum number of tail-recursive frames in backtrace." },
1687 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1688 "Maximal number of stored backtrace frames." },
1689 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1690 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1691 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1692 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1695 scm_option scm_evaluator_trap_table
[] = {
1696 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1697 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1698 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1699 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1702 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1705 #define FUNC_NAME s_scm_eval_options_interface
1709 ans
= scm_options (setting
,
1713 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1719 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1722 #define FUNC_NAME s_scm_evaluator_traps
1726 ans
= scm_options (setting
,
1727 scm_evaluator_trap_table
,
1728 SCM_N_EVALUATOR_TRAPS
,
1730 SCM_RESET_DEBUG_MODE
;
1737 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1739 SCM
*results
= lloc
, res
;
1740 while (SCM_NIMP (l
))
1745 if (SCM_IMP (SCM_CAR (l
)))
1746 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1748 res
= EVALCELLCAR (l
, env
);
1750 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1752 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1754 res
= SCM_CAR (l
); /* struct planted in code */
1756 res
= SCM_PACK (vcell
);
1761 res
= EVALCAR (l
, env
);
1763 *lloc
= scm_cons (res
, SCM_EOL
);
1764 lloc
= SCM_CDRLOC (*lloc
);
1771 scm_wrong_num_args (proc
);
1780 /* SECTION: Some local definitions for the evaluator.
1784 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1787 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1789 /* SECTION: This is the evaluator. Like any real monster, it has
1790 * three heads. This code is compiled twice.
1796 scm_ceval (SCM x
, SCM env
)
1802 scm_deval (SCM x
, SCM env
)
1807 SCM_CEVAL (SCM x
, SCM env
)
1816 scm_debug_frame debug
;
1817 scm_debug_info
*debug_info_end
;
1818 debug
.prev
= scm_last_debug_frame
;
1819 debug
.status
= scm_debug_eframe_size
;
1821 * The debug.vect contains twice as much scm_debug_info frames as the
1822 * user has specified with (debug-set! frames <n>).
1824 * Even frames are eval frames, odd frames are apply frames.
1826 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1827 * sizeof (debug
.vect
[0]));
1828 debug
.info
= debug
.vect
;
1829 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1830 scm_last_debug_frame
= &debug
;
1832 #ifdef EVAL_STACK_CHECKING
1833 if (scm_stack_checking_enabled_p
1834 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1837 debug
.info
->e
.exp
= x
;
1838 debug
.info
->e
.env
= env
;
1840 scm_report_stack_overflow ();
1847 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1850 SCM_CLEAR_ARGSREADY (debug
);
1851 if (SCM_OVERFLOWP (debug
))
1854 * In theory, this should be the only place where it is necessary to
1855 * check for space in debug.vect since both eval frames and
1856 * available space are even.
1858 * For this to be the case, however, it is necessary that primitive
1859 * special forms which jump back to `loop', `begin' or some similar
1860 * label call PREP_APPLY. A convenient way to do this is to jump to
1861 * `loopnoap' or `cdrxnoap'.
1863 else if (++debug
.info
>= debug_info_end
)
1865 SCM_SET_OVERFLOW (debug
);
1869 debug
.info
->e
.exp
= x
;
1870 debug
.info
->e
.env
= env
;
1871 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1872 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1874 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1875 SCM_SET_TAILREC (debug
);
1876 if (SCM_CHEAPTRAPS_P
)
1877 t
.arg1
= scm_make_debugobj (&debug
);
1880 scm_make_cont (&t
.arg1
);
1881 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1883 x
= SCM_THROW_VALUE (t
.arg1
);
1889 /* This gives the possibility for the debugger to
1890 modify the source expression before evaluation. */
1894 scm_ithrow (scm_sym_enter_frame
,
1895 scm_cons2 (t
.arg1
, tail
,
1896 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1900 #if defined (USE_THREADS) || defined (DEVAL)
1904 switch (SCM_TYP7 (x
))
1906 case scm_tc7_symbol
:
1907 /* Only happens when called at top level.
1909 x
= scm_cons (x
, SCM_UNDEFINED
);
1912 case SCM_BIT8(SCM_IM_AND
):
1915 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1916 if (SCM_FALSEP (EVALCAR (x
, env
)))
1918 RETURN (SCM_BOOL_F
);
1922 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1925 case SCM_BIT8(SCM_IM_BEGIN
):
1927 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1933 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1935 if (SCM_IMP (SCM_CAR (x
)))
1937 if (SCM_ISYMP (SCM_CAR (x
)))
1939 x
= scm_m_expand_body (x
, env
);
1944 SCM_CEVAL (SCM_CAR (x
), env
);
1948 carloop
: /* scm_eval car of last form in list */
1949 if (SCM_NCELLP (SCM_CAR (x
)))
1952 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1955 if (SCM_SYMBOLP (SCM_CAR (x
)))
1958 RETURN (*scm_lookupcar (x
, env
, 1))
1962 goto loop
; /* tail recurse */
1965 case SCM_BIT8(SCM_IM_CASE
):
1967 t
.arg1
= EVALCAR (x
, env
);
1968 while (SCM_NIMP (x
= SCM_CDR (x
)))
1971 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1974 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1977 proc
= SCM_CAR (proc
);
1978 while (SCM_NIMP (proc
))
1980 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1982 x
= SCM_CDR (SCM_CAR (x
));
1983 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1986 proc
= SCM_CDR (proc
);
1989 RETURN (SCM_UNSPECIFIED
)
1992 case SCM_BIT8(SCM_IM_COND
):
1993 while (SCM_NIMP (x
= SCM_CDR (x
)))
1996 t
.arg1
= EVALCAR (proc
, env
);
1997 if (SCM_NFALSEP (t
.arg1
))
2004 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2006 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2010 proc
= EVALCAR (proc
, env
);
2011 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2012 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2017 RETURN (SCM_UNSPECIFIED
)
2020 case SCM_BIT8(SCM_IM_DO
):
2022 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2023 t
.arg1
= SCM_EOL
; /* values */
2024 while (SCM_NIMP (proc
))
2026 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2027 proc
= SCM_CDR (proc
);
2029 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2030 x
= SCM_CDR (SCM_CDR (x
));
2031 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2033 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2035 t
.arg1
= SCM_CAR (proc
); /* body */
2036 SIDEVAL (t
.arg1
, env
);
2038 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2040 proc
= SCM_CDR (proc
))
2041 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2042 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2046 RETURN (SCM_UNSPECIFIED
);
2047 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2051 case SCM_BIT8(SCM_IM_IF
):
2053 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2055 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2057 RETURN (SCM_UNSPECIFIED
);
2059 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2063 case SCM_BIT8(SCM_IM_LET
):
2065 proc
= SCM_CAR (SCM_CDR (x
));
2069 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2071 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2072 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2077 case SCM_BIT8(SCM_IM_LETREC
):
2079 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2085 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2087 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2088 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2092 case SCM_BIT8(SCM_IM_LETSTAR
):
2097 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2102 t
.arg1
= SCM_CAR (proc
);
2103 proc
= SCM_CDR (proc
);
2104 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2106 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2109 case SCM_BIT8(SCM_IM_OR
):
2112 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2114 x
= EVALCAR (x
, env
);
2115 if (SCM_NFALSEP (x
))
2121 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2125 case SCM_BIT8(SCM_IM_LAMBDA
):
2126 RETURN (scm_closure (SCM_CDR (x
), env
));
2129 case SCM_BIT8(SCM_IM_QUOTE
):
2130 RETURN (SCM_CAR (SCM_CDR (x
)));
2133 case SCM_BIT8(SCM_IM_SET_X
):
2136 switch (SCM_ITAG3 (proc
))
2139 t
.lloc
= scm_lookupcar (x
, env
, 1);
2141 case scm_tc3_cons_gloc
:
2142 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2144 #ifdef MEMOIZE_LOCALS
2146 t
.lloc
= scm_ilookup (proc
, env
);
2151 *t
.lloc
= EVALCAR (x
, env
);
2155 RETURN (SCM_UNSPECIFIED
);
2159 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2160 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2162 /* new syntactic forms go here. */
2163 case SCM_BIT8(SCM_MAKISYM (0)):
2165 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2166 switch SCM_ISYMNUM (proc
)
2169 case (SCM_ISYMNUM (IM_VREF
)):
2172 var
= SCM_CAR (SCM_CDR (x
));
2173 RETURN (SCM_CDR(var
));
2175 case (SCM_ISYMNUM (IM_VSET
)):
2176 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2177 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2178 RETURN (SCM_UNSPECIFIED
)
2181 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2183 proc
= EVALCAR (proc
, env
);
2184 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2185 if (SCM_CLOSUREP (proc
))
2188 PREP_APPLY (proc
, SCM_EOL
);
2189 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2190 t
.arg1
= EVALCAR (t
.arg1
, env
);
2192 debug
.info
->a
.args
= t
.arg1
;
2194 #ifndef SCM_RECKLESS
2195 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2199 /* Copy argument list */
2200 if (SCM_IMP (t
.arg1
))
2204 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2205 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2206 && SCM_CONSP (t
.arg1
))
2208 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2212 SCM_SETCDR (tl
, t
.arg1
);
2215 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2216 x
= SCM_CODE (proc
);
2222 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2223 scm_make_cont (&t
.arg1
);
2224 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2227 val
= SCM_THROW_VALUE (t
.arg1
);
2231 proc
= evalcar (proc
, env
);
2232 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2233 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2237 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2238 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2240 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2241 proc
= SCM_CADR (x
); /* unevaluated operands */
2242 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2244 arg2
= *scm_ilookup (proc
, env
);
2245 else if (SCM_NCONSP (proc
))
2247 if (SCM_NCELLP (proc
))
2248 arg2
= SCM_GLOC_VAL (proc
);
2250 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2254 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2255 t
.lloc
= SCM_CDRLOC (arg2
);
2256 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2258 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2259 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2264 /* The type dispatch code is duplicated here
2265 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2266 * cuts down execution time for type dispatch to 50%.
2269 int i
, n
, end
, mask
;
2270 SCM z
= SCM_CDDR (x
);
2271 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2272 proc
= SCM_CADR (z
);
2274 if (SCM_NIMP (proc
))
2276 /* Prepare for linear search */
2279 end
= SCM_LENGTH (proc
);
2283 /* Compute a hash value */
2284 int hashset
= SCM_INUM (proc
);
2286 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2287 proc
= SCM_CADR (z
);
2290 if (SCM_NIMP (t
.arg1
))
2293 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2294 [scm_si_hashsets
+ hashset
];
2295 t
.arg1
= SCM_CDR (t
.arg1
);
2297 while (--j
&& SCM_NIMP (t
.arg1
));
2302 /* Search for match */
2306 z
= SCM_VELTS (proc
)[i
];
2307 t
.arg1
= arg2
; /* list of arguments */
2308 if (SCM_NIMP (t
.arg1
))
2311 /* More arguments than specifiers => CLASS != ENV */
2312 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2314 t
.arg1
= SCM_CDR (t
.arg1
);
2317 while (--j
&& SCM_NIMP (t
.arg1
));
2318 /* Fewer arguments than specifiers => CAR != ENV */
2319 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2322 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2324 SCM_CMETHOD_ENV (z
));
2325 x
= SCM_CMETHOD_CODE (z
);
2331 z
= scm_memoize_method (x
, arg2
);
2335 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2337 t
.arg1
= EVALCAR (x
, env
);
2338 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2340 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2342 t
.arg1
= EVALCAR (x
, env
);
2345 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2346 = SCM_UNPACK (EVALCAR (proc
, env
));
2347 RETURN (SCM_UNSPECIFIED
)
2349 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2351 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2353 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2354 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2356 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2358 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2364 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2367 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2369 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2373 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2375 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2377 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2379 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2381 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2382 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2384 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2386 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2392 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2395 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2397 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2401 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2403 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2407 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2410 t
.arg1
= SCM_CAR (x
);
2411 arg2
= SCM_CDAR (env
);
2412 while (SCM_NIMP (arg2
))
2414 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2415 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2417 SCM_SETCAR (arg2
, proc
);
2418 t
.arg1
= SCM_CDR (t
.arg1
);
2419 arg2
= SCM_CDR (arg2
);
2421 t
.arg1
= SCM_CAR (x
);
2422 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2424 arg2
= x
= SCM_CDR (x
);
2425 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2427 SIDEVAL (SCM_CAR (x
), env
);
2430 proc
= EVALCAR (x
, env
);
2432 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2433 arg2
= SCM_CDAR (env
);
2434 while (SCM_NIMP (arg2
))
2436 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2438 t
.arg1
= SCM_CDR (t
.arg1
);
2439 arg2
= SCM_CDR (arg2
);
2451 /* scm_everr (x, env,...) */
2452 scm_misc_error (NULL
,
2453 "Wrong type to apply: ~S",
2454 scm_listify (proc
, SCM_UNDEFINED
));
2455 case scm_tc7_vector
:
2459 case scm_tc7_byvect
:
2466 #ifdef HAVE_LONG_LONGS
2467 case scm_tc7_llvect
:
2470 case scm_tc7_string
:
2471 case scm_tc7_substring
:
2473 case scm_tcs_closures
:
2481 #ifdef MEMOIZE_LOCALS
2482 case SCM_BIT8(SCM_ILOC00
):
2483 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2484 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2485 #ifndef SCM_RECKLESS
2491 #endif /* ifdef MEMOIZE_LOCALS */
2494 case scm_tcs_cons_gloc
: {
2495 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2497 /* This is a struct implanted in the code, not a gloc. */
2500 proc
= SCM_PACK (vcell
);
2501 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2502 #ifndef SCM_RECKLESS
2511 case scm_tcs_cons_nimcar
:
2512 if (SCM_SYMBOLP (SCM_CAR (x
)))
2515 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2518 /* we have lost the race, start again. */
2523 proc
= *scm_lookupcar (x
, env
, 1);
2531 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2537 /* Set a flag during macro expansion so that macro
2538 application frames can be deleted from the backtrace. */
2539 SCM_SET_MACROEXP (debug
);
2541 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2542 scm_cons (env
, scm_listofnull
));
2545 SCM_CLEAR_MACROEXP (debug
);
2547 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2550 if (scm_ilength (t
.arg1
) <= 0)
2551 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2553 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2556 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2557 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2558 /* Prevent memoizing result of define macro */
2560 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2561 scm_set_source_properties_x (debug
.info
->e
.exp
,
2562 scm_source_properties (x
));
2566 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2567 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2571 /* Prevent memoizing of debug info expression. */
2572 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2577 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2578 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2582 if (SCM_NIMP (x
= t
.arg1
))
2590 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2591 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2592 #ifndef SCM_RECKLESS
2596 if (SCM_CLOSUREP (proc
))
2598 arg2
= SCM_CAR (SCM_CODE (proc
));
2599 t
.arg1
= SCM_CDR (x
);
2600 while (SCM_NIMP (arg2
))
2602 if (SCM_NCONSP (arg2
))
2604 if (SCM_IMP (t
.arg1
))
2605 goto umwrongnumargs
;
2606 arg2
= SCM_CDR (arg2
);
2607 t
.arg1
= SCM_CDR (t
.arg1
);
2609 if (SCM_NNULLP (t
.arg1
))
2610 goto umwrongnumargs
;
2612 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2613 goto handle_a_macro
;
2619 PREP_APPLY (proc
, SCM_EOL
);
2620 if (SCM_NULLP (SCM_CDR (x
))) {
2623 switch (SCM_TYP7 (proc
))
2624 { /* no arguments given */
2625 case scm_tc7_subr_0
:
2626 RETURN (SCM_SUBRF (proc
) ());
2627 case scm_tc7_subr_1o
:
2628 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2630 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2631 case scm_tc7_rpsubr
:
2632 RETURN (SCM_BOOL_T
);
2634 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2636 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2638 RETURN (scm_smob_apply_0 (proc
));
2642 proc
= SCM_CCLO_SUBR (proc
);
2644 debug
.info
->a
.proc
= proc
;
2645 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2650 proc
= SCM_PROCEDURE (proc
);
2652 debug
.info
->a
.proc
= proc
;
2654 if (!SCM_CLOSUREP (proc
))
2656 if (scm_badformalsp (proc
, 0))
2657 goto umwrongnumargs
;
2658 case scm_tcs_closures
:
2659 x
= SCM_CODE (proc
);
2660 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2662 case scm_tcs_cons_gloc
:
2663 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2665 x
= SCM_ENTITY_PROCEDURE (proc
);
2669 else if (!SCM_I_OPERATORP (proc
))
2674 proc
= (SCM_I_ENTITYP (proc
)
2675 ? SCM_ENTITY_PROCEDURE (proc
)
2676 : SCM_OPERATOR_PROCEDURE (proc
));
2678 debug
.info
->a
.proc
= proc
;
2679 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2681 if (SCM_NIMP (proc
))
2686 case scm_tc7_contin
:
2687 case scm_tc7_subr_1
:
2688 case scm_tc7_subr_2
:
2689 case scm_tc7_subr_2o
:
2691 case scm_tc7_subr_3
:
2692 case scm_tc7_lsubr_2
:
2696 /* scm_everr (x, env,...) */
2697 scm_wrong_num_args (proc
);
2699 /* handle macros here */
2704 /* must handle macros by here */
2709 else if (SCM_CONSP (x
))
2711 if (SCM_IMP (SCM_CAR (x
)))
2712 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2714 t
.arg1
= EVALCELLCAR (x
, env
);
2716 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2718 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2720 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2722 t
.arg1
= SCM_PACK (vcell
);
2727 t
.arg1
= EVALCAR (x
, env
);
2730 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2737 switch (SCM_TYP7 (proc
))
2738 { /* have one argument in t.arg1 */
2739 case scm_tc7_subr_2o
:
2740 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2741 case scm_tc7_subr_1
:
2742 case scm_tc7_subr_1o
:
2743 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2745 if (SCM_SUBRF (proc
))
2747 if (SCM_INUMP (t
.arg1
))
2749 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2751 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2752 if (SCM_REALP (t
.arg1
))
2754 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2757 if (SCM_BIGP (t
.arg1
))
2759 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2763 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2764 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2766 proc
= SCM_SNAME (proc
);
2768 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2769 while ('c' != *--chrs
)
2771 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2772 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2773 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2777 case scm_tc7_rpsubr
:
2778 RETURN (SCM_BOOL_T
);
2780 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2783 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2785 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2788 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2790 RETURN (scm_smob_apply_1 (proc
, t
.arg1
));
2795 proc
= SCM_CCLO_SUBR (proc
);
2797 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2798 debug
.info
->a
.proc
= proc
;
2803 proc
= SCM_PROCEDURE (proc
);
2805 debug
.info
->a
.proc
= proc
;
2807 if (!SCM_CLOSUREP (proc
))
2809 if (scm_badformalsp (proc
, 1))
2810 goto umwrongnumargs
;
2811 case scm_tcs_closures
:
2813 x
= SCM_CODE (proc
);
2815 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2817 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2820 case scm_tc7_contin
:
2821 scm_call_continuation (proc
, t
.arg1
);
2822 case scm_tcs_cons_gloc
:
2823 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2825 x
= SCM_ENTITY_PROCEDURE (proc
);
2827 arg2
= debug
.info
->a
.args
;
2829 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2833 else if (!SCM_I_OPERATORP (proc
))
2839 proc
= (SCM_I_ENTITYP (proc
)
2840 ? SCM_ENTITY_PROCEDURE (proc
)
2841 : SCM_OPERATOR_PROCEDURE (proc
));
2843 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2844 debug
.info
->a
.proc
= proc
;
2846 if (SCM_NIMP (proc
))
2851 case scm_tc7_subr_2
:
2852 case scm_tc7_subr_0
:
2853 case scm_tc7_subr_3
:
2854 case scm_tc7_lsubr_2
:
2863 else if (SCM_CONSP (x
))
2865 if (SCM_IMP (SCM_CAR (x
)))
2866 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2868 arg2
= EVALCELLCAR (x
, env
);
2870 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2872 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2874 arg2
= SCM_CAR (x
); /* struct planted in code */
2876 arg2
= SCM_PACK (vcell
);
2881 arg2
= EVALCAR (x
, env
);
2883 { /* have two or more arguments */
2885 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2888 if (SCM_NULLP (x
)) {
2893 switch (SCM_TYP7 (proc
))
2894 { /* have two arguments */
2895 case scm_tc7_subr_2
:
2896 case scm_tc7_subr_2o
:
2897 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2900 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2902 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2904 case scm_tc7_lsubr_2
:
2905 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2906 case scm_tc7_rpsubr
:
2908 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2910 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2912 RETURN (scm_smob_apply_2 (proc
, t
.arg1
, arg2
));
2917 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2918 scm_cons (proc
, debug
.info
->a
.args
),
2921 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2922 scm_cons2 (proc
, t
.arg1
,
2929 /* case scm_tc7_cclo:
2930 x = scm_cons(arg2, scm_eval_args(x, env));
2933 proc = SCM_CCLO_SUBR(proc);
2936 case scm_tcs_cons_gloc
:
2937 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2939 x
= SCM_ENTITY_PROCEDURE (proc
);
2941 arg2
= debug
.info
->a
.args
;
2943 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2947 else if (!SCM_I_OPERATORP (proc
))
2953 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2954 ? SCM_ENTITY_PROCEDURE (proc
)
2955 : SCM_OPERATOR_PROCEDURE (proc
),
2956 scm_cons (proc
, debug
.info
->a
.args
),
2959 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2960 ? SCM_ENTITY_PROCEDURE (proc
)
2961 : SCM_OPERATOR_PROCEDURE (proc
),
2962 scm_cons2 (proc
, t
.arg1
,
2970 case scm_tc7_subr_0
:
2972 case scm_tc7_subr_1o
:
2973 case scm_tc7_subr_1
:
2974 case scm_tc7_subr_3
:
2975 case scm_tc7_contin
:
2980 proc
= SCM_PROCEDURE (proc
);
2982 debug
.info
->a
.proc
= proc
;
2984 if (!SCM_CLOSUREP (proc
))
2986 if (scm_badformalsp (proc
, 2))
2987 goto umwrongnumargs
;
2988 case scm_tcs_closures
:
2991 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2995 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2996 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2998 x
= SCM_CODE (proc
);
3003 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3007 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3008 scm_deval_args (x
, env
, proc
,
3009 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3013 switch (SCM_TYP7 (proc
))
3014 { /* have 3 or more arguments */
3016 case scm_tc7_subr_3
:
3017 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3018 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3019 SCM_CADDR (debug
.info
->a
.args
)));
3021 #ifdef BUILTIN_RPASUBR
3022 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3023 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3026 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3027 arg2
= SCM_CDR (arg2
);
3029 while (SCM_NIMP (arg2
));
3031 #endif /* BUILTIN_RPASUBR */
3032 case scm_tc7_rpsubr
:
3033 #ifdef BUILTIN_RPASUBR
3034 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3036 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3039 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3041 arg2
= SCM_CAR (t
.arg1
);
3042 t
.arg1
= SCM_CDR (t
.arg1
);
3044 while (SCM_NIMP (t
.arg1
));
3046 #else /* BUILTIN_RPASUBR */
3047 RETURN (SCM_APPLY (proc
, t
.arg1
,
3049 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3051 #endif /* BUILTIN_RPASUBR */
3052 case scm_tc7_lsubr_2
:
3053 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3054 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3056 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3058 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3060 RETURN (scm_smob_apply_3 (proc
, t
.arg1
, arg2
,
3061 SCM_CDDR (debug
.info
->a
.args
)));
3067 proc
= SCM_PROCEDURE (proc
);
3068 debug
.info
->a
.proc
= proc
;
3069 if (!SCM_CLOSUREP (proc
))
3071 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3072 goto umwrongnumargs
;
3073 case scm_tcs_closures
:
3074 SCM_SET_ARGSREADY (debug
);
3075 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3078 x
= SCM_CODE (proc
);
3081 case scm_tc7_subr_3
:
3082 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3083 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3085 #ifdef BUILTIN_RPASUBR
3086 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3089 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3092 while (SCM_NIMP (x
));
3094 #endif /* BUILTIN_RPASUBR */
3095 case scm_tc7_rpsubr
:
3096 #ifdef BUILTIN_RPASUBR
3097 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3101 t
.arg1
= EVALCAR (x
, env
);
3102 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3107 while (SCM_NIMP (x
));
3109 #else /* BUILTIN_RPASUBR */
3110 RETURN (SCM_APPLY (proc
, t
.arg1
,
3112 scm_eval_args (x
, env
, proc
),
3114 #endif /* BUILTIN_RPASUBR */
3115 case scm_tc7_lsubr_2
:
3116 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3118 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3120 scm_eval_args (x
, env
, proc
))));
3122 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3124 RETURN (scm_smob_apply_3 (proc
, t
.arg1
, arg2
,
3125 scm_eval_args (x
, env
, proc
)));
3131 proc
= SCM_PROCEDURE (proc
);
3132 if (!SCM_CLOSUREP (proc
))
3135 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3136 if (SCM_NULLP (formals
)
3137 || (SCM_CONSP (formals
)
3138 && (SCM_NULLP (SCM_CDR (formals
))
3139 || (SCM_CONSP (SCM_CDR (formals
))
3140 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3141 goto umwrongnumargs
;
3143 case scm_tcs_closures
:
3145 SCM_SET_ARGSREADY (debug
);
3147 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3150 scm_eval_args (x
, env
, proc
)),
3152 x
= SCM_CODE (proc
);
3155 case scm_tcs_cons_gloc
:
3156 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3159 arg2
= debug
.info
->a
.args
;
3161 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3163 x
= SCM_ENTITY_PROCEDURE (proc
);
3166 else if (!SCM_I_OPERATORP (proc
))
3170 case scm_tc7_subr_2
:
3171 case scm_tc7_subr_1o
:
3172 case scm_tc7_subr_2o
:
3173 case scm_tc7_subr_0
:
3175 case scm_tc7_subr_1
:
3176 case scm_tc7_contin
:
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
);
3192 scm_make_cont (&t
.arg1
);
3193 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3195 proc
= SCM_THROW_VALUE (t
.arg1
);
3199 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3202 scm_last_debug_frame
= debug
.prev
;
3208 /* SECTION: This code is compiled once.
3213 /* This code processes the arguments to apply:
3215 (apply PROC ARG1 ... ARGS)
3217 Given a list (ARG1 ... ARGS), this function conses the ARG1
3218 ... arguments onto the front of ARGS, and returns the resulting
3219 list. Note that ARGS is a list; thus, the argument to this
3220 function is a list whose last element is a list.
3222 Apply calls this function, and applies PROC to the elements of the
3223 result. apply:nconc2last takes care of building the list of
3224 arguments, given (ARG1 ... ARGS).
3226 Rather than do new consing, apply:nconc2last destroys its argument.
3227 On that topic, this code came into my care with the following
3228 beautifully cryptic comment on that topic: "This will only screw
3229 you if you do (scm_apply scm_apply '( ... ))" If you know what
3230 they're referring to, send me a patch to this comment. */
3232 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3235 #define FUNC_NAME s_scm_nconc2last
3238 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3240 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3241 lloc
= SCM_CDRLOC (*lloc
);
3242 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3243 *lloc
= SCM_CAR (*lloc
);
3251 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3252 * It is compiled twice.
3258 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3265 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3270 /* Apply a function to a list of arguments.
3272 This function is exported to the Scheme level as taking two
3273 required arguments and a tail argument, as if it were:
3274 (lambda (proc arg1 . args) ...)
3275 Thus, if you just have a list of arguments to pass to a procedure,
3276 pass the list as ARG1, and '() for ARGS. If you have some fixed
3277 args, pass the first as ARG1, then cons any remaining fixed args
3278 onto the front of your argument list, and pass that as ARGS. */
3281 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3283 #ifdef DEBUG_EXTENSIONS
3285 scm_debug_frame debug
;
3286 scm_debug_info debug_vect_body
;
3287 debug
.prev
= scm_last_debug_frame
;
3288 debug
.status
= SCM_APPLYFRAME
;
3289 debug
.vect
= &debug_vect_body
;
3290 debug
.vect
[0].a
.proc
= proc
;
3291 debug
.vect
[0].a
.args
= SCM_EOL
;
3292 scm_last_debug_frame
= &debug
;
3295 return scm_dapply (proc
, arg1
, args
);
3299 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3301 /* If ARGS is the empty list, then we're calling apply with only two
3302 arguments --- ARG1 is the list of arguments for PROC. Whatever
3303 the case, futz with things so that ARG1 is the first argument to
3304 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3307 Setting the debug apply frame args this way is pretty messy.
3308 Perhaps we should store arg1 and args directly in the frame as
3309 received, and let scm_frame_arguments unpack them, because that's
3310 a relatively rare operation. This works for now; if the Guile
3311 developer archives are still around, see Mikael's post of
3313 if (SCM_NULLP (args
))
3315 if (SCM_NULLP (arg1
))
3317 arg1
= SCM_UNDEFINED
;
3319 debug
.vect
[0].a
.args
= SCM_EOL
;
3325 debug
.vect
[0].a
.args
= arg1
;
3327 args
= SCM_CDR (arg1
);
3328 arg1
= SCM_CAR (arg1
);
3333 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3334 args
= scm_nconc2last (args
);
3336 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3340 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3343 if (SCM_CHEAPTRAPS_P
)
3344 tmp
= scm_make_debugobj (&debug
);
3347 scm_make_cont (&tmp
);
3348 if (setjmp (SCM_JMPBUF (tmp
)))
3351 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3359 switch (SCM_TYP7 (proc
))
3361 case scm_tc7_subr_2o
:
3362 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3363 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3364 case scm_tc7_subr_2
:
3365 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3367 args
= SCM_CAR (args
);
3368 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3369 case scm_tc7_subr_0
:
3370 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3371 RETURN (SCM_SUBRF (proc
) ())
3372 case scm_tc7_subr_1
:
3373 case scm_tc7_subr_1o
:
3374 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3375 RETURN (SCM_SUBRF (proc
) (arg1
))
3377 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3378 if (SCM_SUBRF (proc
))
3380 if (SCM_INUMP (arg1
))
3382 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3384 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3385 if (SCM_REALP (arg1
))
3387 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3390 if (SCM_BIGP (arg1
))
3391 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3394 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3395 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3397 proc
= SCM_SNAME (proc
);
3399 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3400 while ('c' != *--chrs
)
3402 SCM_ASSERT (SCM_CONSP (arg1
),
3403 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3404 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3408 case scm_tc7_subr_3
:
3409 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3412 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3414 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3416 case scm_tc7_lsubr_2
:
3417 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3418 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3420 if (SCM_NULLP (args
))
3421 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3422 while (SCM_NIMP (args
))
3424 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3425 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3426 args
= SCM_CDR (args
);
3429 case scm_tc7_rpsubr
:
3430 if (SCM_NULLP (args
))
3431 RETURN (SCM_BOOL_T
);
3432 while (SCM_NIMP (args
))
3434 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3435 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3436 RETURN (SCM_BOOL_F
);
3437 arg1
= SCM_CAR (args
);
3438 args
= SCM_CDR (args
);
3440 RETURN (SCM_BOOL_T
);
3441 case scm_tcs_closures
:
3443 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3445 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3447 #ifndef SCM_RECKLESS
3448 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3452 /* Copy argument list */
3457 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3458 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3460 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3464 SCM_SETCDR (tl
, arg1
);
3467 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3468 proc
= SCM_CDR (SCM_CODE (proc
));
3471 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3473 if (SCM_IMP (SCM_CAR (proc
)))
3475 if (SCM_ISYMP (SCM_CAR (proc
)))
3477 proc
= scm_m_expand_body (proc
, args
);
3482 SCM_CEVAL (SCM_CAR (proc
), args
);
3485 RETURN (EVALCAR (proc
, args
));
3487 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3489 if (SCM_UNBNDP (arg1
))
3490 RETURN (scm_smob_apply_0 (proc
))
3491 else if (SCM_NULLP (args
))
3492 RETURN (scm_smob_apply_1 (proc
, arg1
))
3493 else if (SCM_NULLP (SCM_CDR (args
)))
3494 RETURN (scm_smob_apply_2 (proc
, arg1
, SCM_CAR (args
)))
3496 RETURN (scm_smob_apply_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3497 case scm_tc7_contin
:
3498 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3499 scm_call_continuation (proc
, arg1
);
3503 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3505 proc
= SCM_CCLO_SUBR (proc
);
3506 debug
.vect
[0].a
.proc
= proc
;
3507 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3509 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3511 proc
= SCM_CCLO_SUBR (proc
);
3516 proc
= SCM_PROCEDURE (proc
);
3518 debug
.vect
[0].a
.proc
= proc
;
3521 case scm_tcs_cons_gloc
:
3522 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3525 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3527 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3529 RETURN (scm_apply_generic (proc
, args
));
3531 else if (!SCM_I_OPERATORP (proc
))
3536 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3538 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3541 proc
= (SCM_I_ENTITYP (proc
)
3542 ? SCM_ENTITY_PROCEDURE (proc
)
3543 : SCM_OPERATOR_PROCEDURE (proc
));
3545 debug
.vect
[0].a
.proc
= proc
;
3546 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3548 if (SCM_NIMP (proc
))
3554 scm_wrong_num_args (proc
);
3557 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3562 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3563 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3565 SCM_CLEAR_TRACED_FRAME (debug
);
3566 if (SCM_CHEAPTRAPS_P
)
3567 arg1
= scm_make_debugobj (&debug
);
3570 scm_make_cont (&arg1
);
3571 if (setjmp (SCM_JMPBUF (arg1
)))
3573 proc
= SCM_THROW_VALUE (arg1
);
3577 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3580 scm_last_debug_frame
= debug
.prev
;
3586 /* SECTION: The rest of this file is only read once.
3591 /* Typechecking for multi-argument MAP and FOR-EACH.
3593 Verify that each element of the vector ARGV, except for the first,
3594 is a proper list whose length is LEN. Attribute errors to WHO,
3595 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3597 check_map_args (SCM argv
,
3604 SCM
*ve
= SCM_VELTS (argv
);
3607 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3609 int elt_len
= scm_ilength (ve
[i
]);
3614 scm_apply_generic (gf
, scm_cons (proc
, args
));
3616 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3620 scm_out_of_range (who
, ve
[i
]);
3623 scm_remember (&argv
);
3627 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3629 /* Note: Currently, scm_map applies PROC to the argument list(s)
3630 sequentially, starting with the first element(s). This is used in
3631 evalext.c where the Scheme procedure `map-in-order', which guarantees
3632 sequential behaviour, is implemented using scm_map. If the
3633 behaviour changes, we need to update `map-in-order'.
3637 scm_map (SCM proc
, SCM arg1
, SCM args
)
3638 #define FUNC_NAME s_map
3643 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3645 len
= scm_ilength (arg1
);
3646 SCM_GASSERTn (len
>= 0,
3647 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3648 SCM_VALIDATE_REST_ARGUMENT (args
);
3649 if (SCM_NULLP (args
))
3651 while (SCM_NIMP (arg1
))
3653 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3655 pres
= SCM_CDRLOC (*pres
);
3656 arg1
= SCM_CDR (arg1
);
3660 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3661 ve
= SCM_VELTS (args
);
3662 #ifndef SCM_RECKLESS
3663 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3668 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3670 if (SCM_IMP (ve
[i
]))
3672 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3673 ve
[i
] = SCM_CDR (ve
[i
]);
3675 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3676 pres
= SCM_CDRLOC (*pres
);
3682 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3685 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3686 #define FUNC_NAME s_for_each
3688 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3690 len
= scm_ilength (arg1
);
3691 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3692 SCM_ARG2
, s_for_each
);
3693 SCM_VALIDATE_REST_ARGUMENT (args
);
3696 while SCM_NIMP (arg1
)
3698 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3699 arg1
= SCM_CDR (arg1
);
3701 return SCM_UNSPECIFIED
;
3703 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3704 ve
= SCM_VELTS (args
);
3705 #ifndef SCM_RECKLESS
3706 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3711 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3714 (ve
[i
]) return SCM_UNSPECIFIED
;
3715 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3716 ve
[i
] = SCM_CDR (ve
[i
]);
3718 scm_apply (proc
, arg1
, SCM_EOL
);
3725 scm_closure (SCM code
, SCM env
)
3729 SCM_SETCODE (z
, code
);
3730 SCM_SETENV (z
, env
);
3735 long scm_tc16_promise
;
3738 scm_makprom (SCM code
)
3740 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3746 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3748 int writingp
= SCM_WRITINGP (pstate
);
3749 scm_puts ("#<promise ", port
);
3750 SCM_SET_WRITINGP (pstate
, 1);
3751 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3752 SCM_SET_WRITINGP (pstate
, writingp
);
3753 scm_putc ('>', port
);
3758 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3760 "If the promise X has not been computed yet, compute and return\n"
3761 "X, otherwise just return the previously computed value.")
3762 #define FUNC_NAME s_scm_force
3764 SCM_VALIDATE_SMOB (1, x
, promise
);
3765 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3767 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3768 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3771 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3772 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3776 return SCM_CELL_OBJECT_1 (x
);
3781 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3783 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3784 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3785 #define FUNC_NAME s_scm_promise_p
3787 return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise
, x
));
3792 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3793 (SCM xorig
, SCM x
, SCM y
),
3794 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3795 "Any source properties associated with @var{xorig} are also associated\n"
3796 "with the new pair.")
3797 #define FUNC_NAME s_scm_cons_source
3801 SCM_SET_CELL_OBJECT_0 (z
, x
);
3802 SCM_SET_CELL_OBJECT_1 (z
, y
);
3803 /* Copy source properties possibly associated with xorig. */
3804 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3806 scm_whash_insert (scm_source_whash
, z
, p
);
3812 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3814 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3815 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3816 "contents of both pairs and vectors (since both cons cells and vector\n"
3817 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3818 "any other object.")
3819 #define FUNC_NAME s_scm_copy_tree
3824 if (SCM_VECTORP (obj
))
3826 scm_sizet i
= SCM_LENGTH (obj
);
3827 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3829 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3832 if (SCM_NCONSP (obj
))
3834 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3835 ans
= tl
= scm_cons_source (obj
,
3836 scm_copy_tree (SCM_CAR (obj
)),
3838 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3840 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3844 SCM_SETCDR (tl
, obj
);
3850 SCM scm_system_transformer
;
3853 scm_i_eval_x (SCM exp
, SCM env
)
3855 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3856 if (SCM_NIMP (transformer
))
3857 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3858 return SCM_XEVAL (exp
, env
);
3862 scm_i_eval (SCM exp
, SCM env
)
3864 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3865 if (SCM_NIMP (transformer
))
3866 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3867 return SCM_XEVAL (scm_copy_tree (exp
), env
);
3871 scm_eval_x (SCM exp
, SCM module
)
3873 return scm_i_eval_x (exp
,
3874 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module
)));
3877 /* Eval does not take the second arg optionally. This is intentional
3878 * in order to be R5RS compatible, and to prepare for the new module
3879 * system, where we would like to make the choice of evaluation
3880 * environment explicit.
3883 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3884 (SCM exp
, SCM environment
),
3885 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3886 "environment given by @var{environment specifier}.")
3887 #define FUNC_NAME s_scm_eval
3889 SCM_VALIDATE_MODULE (2, environment
);
3890 return scm_i_eval (scm_copy_tree (exp
),
3891 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment
)));
3895 #if (SCM_DEBUG_DEPRECATED == 0)
3897 /* Use scm_selected_module () or scm_interaction_environment ()
3898 * instead. The former is the module selected during loading of code.
3899 * The latter is the module in which the user of this thread currently
3900 * types expressions.
3903 SCM scm_top_level_lookup_closure_var
;
3905 /* Avoid using this functionality altogether (except for implementing
3906 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3908 * Applications should use either C level scm_eval_x or Scheme scm_eval. */
3911 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3914 return scm_i_eval (obj
, env
);
3916 return scm_i_eval_x (obj
, env
);
3919 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3920 (SCM obj
, SCM env_thunk
),
3921 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3922 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3923 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3924 #define FUNC_NAME s_scm_eval2
3926 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3930 #endif /* DEPRECATED */
3933 /* At this point, scm_deval and scm_dapply are generated.
3936 #ifdef DEBUG_EXTENSIONS
3946 scm_init_opts (scm_evaluator_traps
,
3947 scm_evaluator_trap_table
,
3948 SCM_N_EVALUATOR_TRAPS
);
3949 scm_init_opts (scm_eval_options_interface
,
3951 SCM_N_EVAL_OPTIONS
);
3953 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3954 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3955 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3957 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3958 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
3960 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3961 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3962 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3963 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3964 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3966 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3967 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3968 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3969 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3970 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3971 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3976 #if SCM_DEBUG_DEPRECATED == 0
3977 scm_top_level_lookup_closure_var
=
3978 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
3981 #ifdef DEBUG_EXTENSIONS
3982 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3983 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3984 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3985 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3988 #include "libguile/eval.x"
3990 scm_add_feature ("delay");