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
);
905 if (SCM_NIMP (SCM_CDR (arg1
)) && (SCM_SNAME (SCM_CDR (arg1
)) == proc
)
906 && (SCM_CDR (arg1
) != x
))
907 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
910 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
911 scm_warn ("redefining ", SCM_CHARS (proc
));
913 SCM_SETCDR (arg1
, x
);
915 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
917 return SCM_UNSPECIFIED
;
920 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
926 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
928 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
929 char *what
= SCM_CHARS (SCM_CAR (xorig
));
930 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
931 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
934 SCM_ASSYNT (scm_ilength (proc
) >= 1, xorig
, scm_s_bindings
, what
);
937 /* vars scm_list reversed here, inits reversed at evaluation */
938 arg1
= SCM_CAR (proc
);
939 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, what
);
940 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, what
);
941 vars
= scm_cons (SCM_CAR (arg1
), vars
);
942 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
943 initloc
= SCM_CDRLOC (*initloc
);
945 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
947 return scm_cons2 (op
, vars
,
948 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
951 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
952 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
955 scm_m_letrec (SCM xorig
, SCM env
)
957 SCM x
= SCM_CDR (xorig
);
958 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
960 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
961 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
962 scm_m_body (SCM_IM_LETREC
,
967 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
970 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
971 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
974 scm_m_let (SCM xorig
, SCM env
)
976 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
977 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
978 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
980 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
984 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
986 /* null or single binding, let* is faster */
987 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
988 scm_m_body (SCM_IM_LET
,
994 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
995 if (SCM_CONSP (proc
))
997 /* plain let, proc is <bindings> */
998 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1001 if (!SCM_SYMBOLP (proc
))
1002 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1003 name
= proc
; /* named let, build equiv letrec */
1005 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1006 proc
= SCM_CAR (x
); /* bindings list */
1007 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1008 while (SCM_NIMP (proc
))
1009 { /* vars and inits both in order */
1010 arg1
= SCM_CAR (proc
);
1011 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1012 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1013 xorig
, scm_s_variable
, s_let
);
1014 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1015 varloc
= SCM_CDRLOC (*varloc
);
1016 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1017 initloc
= SCM_CDRLOC (*initloc
);
1018 proc
= SCM_CDR (proc
);
1021 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1022 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1023 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1025 scm_acons (name
, inits
, SCM_EOL
));
1026 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1030 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1031 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1032 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1035 scm_m_apply (SCM xorig
, SCM env
)
1037 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1038 xorig
, scm_s_expression
, s_atapply
);
1039 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1043 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1044 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1048 scm_m_cont (SCM xorig
, SCM env
)
1050 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1051 xorig
, scm_s_expression
, s_atcall_cc
);
1052 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1055 /* Multi-language support */
1060 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1063 scm_m_nil_cond (SCM xorig
, SCM env
)
1065 int len
= scm_ilength (SCM_CDR (xorig
));
1066 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1067 scm_s_expression
, "nil-cond");
1068 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1071 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1074 scm_m_nil_ify (SCM xorig
, SCM env
)
1076 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1077 xorig
, scm_s_expression
, "nil-ify");
1078 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1081 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1084 scm_m_t_ify (SCM xorig
, SCM env
)
1086 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1087 xorig
, scm_s_expression
, "t-ify");
1088 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1091 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1094 scm_m_0_cond (SCM xorig
, SCM env
)
1096 int len
= scm_ilength (SCM_CDR (xorig
));
1097 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1098 scm_s_expression
, "0-cond");
1099 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1102 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1105 scm_m_0_ify (SCM xorig
, SCM env
)
1107 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1108 xorig
, scm_s_expression
, "0-ify");
1109 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1112 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1115 scm_m_1_ify (SCM xorig
, SCM env
)
1117 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1118 xorig
, scm_s_expression
, "1-ify");
1119 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1122 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1125 scm_m_atfop (SCM xorig
, SCM env
)
1127 SCM x
= SCM_CDR (xorig
), vcell
;
1128 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1129 vcell
= scm_symbol_fref (SCM_CAR (x
));
1130 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1131 "Symbol's function definition is void", NULL
);
1132 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1136 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1139 scm_m_atbind (SCM xorig
, SCM env
)
1141 SCM x
= SCM_CDR (xorig
);
1142 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1148 while (SCM_NIMP (SCM_CDR (env
)))
1149 env
= SCM_CDR (env
);
1150 env
= SCM_CAR (env
);
1151 if (SCM_CONSP (env
))
1156 while (SCM_NIMP (x
))
1158 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1161 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1165 scm_m_expand_body (SCM xorig
, SCM env
)
1167 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1168 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1170 while (SCM_NIMP (x
))
1173 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1175 if (SCM_IMP (SCM_CAR (form
)))
1177 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1180 form
= scm_macroexp (scm_cons_source (form
,
1185 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1187 defs
= scm_cons (SCM_CDR (form
), defs
);
1190 else if (SCM_NIMP(defs
))
1194 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1196 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1200 x
= scm_cons (form
, SCM_CDR(x
));
1205 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1206 if (SCM_NIMP (defs
))
1208 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1210 scm_cons2 (scm_sym_define
, defs
, x
),
1216 SCM_SETCAR (xorig
, SCM_CAR (x
));
1217 SCM_SETCDR (xorig
, SCM_CDR (x
));
1224 scm_macroexp (SCM x
, SCM env
)
1228 /* Don't bother to produce error messages here. We get them when we
1229 eventually execute the code for real. */
1232 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1237 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1238 if (proc_ptr
== NULL
)
1240 /* We have lost the race. */
1246 proc
= *scm_lookupcar (x
, env
, 0);
1249 /* Only handle memoizing macros. `Acros' and `macros' are really
1250 special forms and should not be evaluated here. */
1253 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1254 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1258 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1260 if (scm_ilength (res
) <= 0)
1261 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1264 SCM_SETCAR (x
, SCM_CAR (res
));
1265 SCM_SETCDR (x
, SCM_CDR (res
));
1271 /* scm_unmemocopy takes a memoized expression together with its
1272 * environment and rewrites it to its original form. Thus, it is the
1273 * inversion of the rewrite rules above. The procedure is not
1274 * optimized for speed. It's used in scm_iprin1 when printing the
1275 * code of a closure, in scm_procedure_source, in display_frame when
1276 * generating the source for a stackframe in a backtrace, and in
1277 * display_expression.
1280 /* We should introduce an anti-macro interface so that it is possible
1281 * to plug in transformers in both directions from other compilation
1282 * units. unmemocopy could then dispatch to anti-macro transformers.
1283 * (Those transformers could perhaps be written in slightly more
1284 * readable style... :)
1287 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1290 unmemocopy (SCM x
, SCM env
)
1293 #ifdef DEBUG_EXTENSIONS
1296 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1298 #ifdef DEBUG_EXTENSIONS
1299 p
= scm_whash_lookup (scm_source_whash
, x
);
1301 switch (SCM_TYP7 (x
))
1303 case SCM_BIT8(SCM_IM_AND
):
1304 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1306 case SCM_BIT8(SCM_IM_BEGIN
):
1307 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1309 case SCM_BIT8(SCM_IM_CASE
):
1310 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1312 case SCM_BIT8(SCM_IM_COND
):
1313 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1315 case SCM_BIT8(SCM_IM_DO
):
1316 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1318 case SCM_BIT8(SCM_IM_IF
):
1319 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1321 case SCM_BIT8(SCM_IM_LET
):
1322 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1324 case SCM_BIT8(SCM_IM_LETREC
):
1327 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1331 f
= v
= SCM_CAR (x
);
1333 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1335 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1336 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1339 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1340 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1342 /* build transformed binding list */
1344 while (SCM_NIMP (v
))
1346 z
= scm_acons (SCM_CAR (v
),
1347 scm_cons (SCM_CAR (e
),
1348 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1350 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1356 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1358 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1362 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1365 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1366 /* body forms are now to be found in SCM_CDR (x)
1367 (this is how *real* code look like! :) */
1371 case SCM_BIT8(SCM_IM_LETSTAR
):
1379 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1382 y
= z
= scm_acons (SCM_CAR (b
),
1384 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1386 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1387 b
= SCM_CDR (SCM_CDR (b
));
1390 SCM_SETCDR (y
, SCM_EOL
);
1391 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1396 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1398 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1401 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1402 b
= SCM_CDR (SCM_CDR (b
));
1404 while (SCM_NIMP (b
));
1405 SCM_SETCDR (z
, SCM_EOL
);
1407 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1410 case SCM_BIT8(SCM_IM_OR
):
1411 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1413 case SCM_BIT8(SCM_IM_LAMBDA
):
1415 ls
= scm_cons (scm_sym_lambda
,
1416 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1417 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1419 case SCM_BIT8(SCM_IM_QUOTE
):
1420 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1422 case SCM_BIT8(SCM_IM_SET_X
):
1423 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1425 case SCM_BIT8(SCM_IM_DEFINE
):
1429 ls
= scm_cons (scm_sym_define
,
1430 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1431 if (SCM_NNULLP (env
))
1432 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1435 case SCM_BIT8(SCM_MAKISYM (0)):
1439 switch (SCM_ISYMNUM (z
))
1441 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1442 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1444 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1445 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1447 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1448 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1452 /* appease the Sun compiler god: */ ;
1456 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1461 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1463 if (SCM_ISYMP (SCM_CAR (x
)))
1464 /* skip body markers */
1466 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1472 #ifdef DEBUG_EXTENSIONS
1473 if (SCM_NFALSEP (p
))
1474 scm_whash_insert (scm_source_whash
, ls
, p
);
1481 scm_unmemocopy (SCM x
, SCM env
)
1483 if (SCM_NNULLP (env
))
1484 /* Make a copy of the lowest frame to protect it from
1485 modifications by SCM_IM_DEFINE */
1486 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1488 return unmemocopy (x
, env
);
1491 #ifndef SCM_RECKLESS
1494 scm_badargsp (SCM formals
, SCM args
)
1496 while (SCM_NIMP (formals
))
1498 if (SCM_NCONSP (formals
))
1502 formals
= SCM_CDR (formals
);
1503 args
= SCM_CDR (args
);
1505 return SCM_NNULLP (args
) ? 1 : 0;
1510 scm_badformalsp (SCM closure
, int n
)
1512 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1513 while (SCM_NIMP (formals
))
1515 if (SCM_NCONSP (formals
))
1520 formals
= SCM_CDR (formals
);
1527 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1529 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1530 while (SCM_NIMP (l
))
1535 if (SCM_IMP (SCM_CAR (l
)))
1536 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1538 res
= EVALCELLCAR (l
, env
);
1540 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1542 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1544 res
= SCM_CAR (l
); /* struct planted in code */
1546 res
= SCM_PACK (vcell
);
1551 res
= EVALCAR (l
, env
);
1553 *lloc
= scm_cons (res
, SCM_EOL
);
1554 lloc
= SCM_CDRLOC (*lloc
);
1561 scm_wrong_num_args (proc
);
1568 scm_eval_body (SCM code
, SCM env
)
1573 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1575 if (SCM_IMP (SCM_CAR (code
)))
1577 if (SCM_ISYMP (SCM_CAR (code
)))
1579 code
= scm_m_expand_body (code
, env
);
1584 SCM_XEVAL (SCM_CAR (code
), env
);
1587 return SCM_XEVALCAR (code
, env
);
1594 /* SECTION: This code is specific for the debugging support. One
1595 * branch is read when DEVAL isn't defined, the other when DEVAL is
1601 #define SCM_APPLY scm_apply
1602 #define PREP_APPLY(proc, args)
1604 #define RETURN(x) return x;
1605 #ifdef STACK_CHECKING
1606 #ifndef NO_CEVAL_STACK_CHECKING
1607 #define EVAL_STACK_CHECKING
1614 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1616 #define SCM_APPLY scm_dapply
1618 #define PREP_APPLY(p, l) \
1619 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1621 #define ENTER_APPLY \
1623 SCM_SET_ARGSREADY (debug);\
1624 if (CHECK_APPLY && SCM_TRAPS_P)\
1625 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1627 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1628 SCM_SET_TRACED_FRAME (debug); \
1629 if (SCM_CHEAPTRAPS_P)\
1631 tmp = scm_make_debugobj (&debug);\
1632 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1636 scm_make_cont (&tmp);\
1637 if (!setjmp (SCM_JMPBUF (tmp)))\
1638 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1643 #define RETURN(e) {proc = (e); goto exit;}
1644 #ifdef STACK_CHECKING
1645 #ifndef EVAL_STACK_CHECKING
1646 #define EVAL_STACK_CHECKING
1650 /* scm_ceval_ptr points to the currently selected evaluator.
1651 * *fixme*: Although efficiency is important here, this state variable
1652 * should probably not be a global. It should be related to the
1657 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1659 /* scm_last_debug_frame contains a pointer to the last debugging
1660 * information stack frame. It is accessed very often from the
1661 * debugging evaluator, so it should probably not be indirectly
1662 * addressed. Better to save and restore it from the current root at
1667 scm_debug_frame
*scm_last_debug_frame
;
1670 /* scm_debug_eframe_size is the number of slots available for pseudo
1671 * stack frames at each real stack frame.
1674 int scm_debug_eframe_size
;
1676 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1680 scm_option scm_eval_opts
[] = {
1681 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1684 scm_option scm_debug_opts
[] = {
1685 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1686 "*Flyweight representation of the stack at traps." },
1687 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1688 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1689 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1690 "Record procedure names at definition." },
1691 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1692 "Display backtrace in anti-chronological order." },
1693 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1694 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1695 { SCM_OPTION_INTEGER
, "frames", 3,
1696 "Maximum number of tail-recursive frames in backtrace." },
1697 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1698 "Maximal number of stored backtrace frames." },
1699 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1700 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1701 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1702 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1705 scm_option scm_evaluator_trap_table
[] = {
1706 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1707 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1708 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1709 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1712 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1715 #define FUNC_NAME s_scm_eval_options_interface
1719 ans
= scm_options (setting
,
1723 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1729 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1732 #define FUNC_NAME s_scm_evaluator_traps
1736 ans
= scm_options (setting
,
1737 scm_evaluator_trap_table
,
1738 SCM_N_EVALUATOR_TRAPS
,
1740 SCM_RESET_DEBUG_MODE
;
1747 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1749 SCM
*results
= lloc
, res
;
1750 while (SCM_NIMP (l
))
1755 if (SCM_IMP (SCM_CAR (l
)))
1756 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1758 res
= EVALCELLCAR (l
, env
);
1760 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1762 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1764 res
= SCM_CAR (l
); /* struct planted in code */
1766 res
= SCM_PACK (vcell
);
1771 res
= EVALCAR (l
, env
);
1773 *lloc
= scm_cons (res
, SCM_EOL
);
1774 lloc
= SCM_CDRLOC (*lloc
);
1781 scm_wrong_num_args (proc
);
1790 /* SECTION: Some local definitions for the evaluator.
1794 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1797 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1799 /* SECTION: This is the evaluator. Like any real monster, it has
1800 * three heads. This code is compiled twice.
1806 scm_ceval (SCM x
, SCM env
)
1812 scm_deval (SCM x
, SCM env
)
1817 SCM_CEVAL (SCM x
, SCM env
)
1826 scm_debug_frame debug
;
1827 scm_debug_info
*debug_info_end
;
1828 debug
.prev
= scm_last_debug_frame
;
1829 debug
.status
= scm_debug_eframe_size
;
1831 * The debug.vect contains twice as much scm_debug_info frames as the
1832 * user has specified with (debug-set! frames <n>).
1834 * Even frames are eval frames, odd frames are apply frames.
1836 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1837 * sizeof (debug
.vect
[0]));
1838 debug
.info
= debug
.vect
;
1839 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1840 scm_last_debug_frame
= &debug
;
1842 #ifdef EVAL_STACK_CHECKING
1843 if (scm_stack_checking_enabled_p
1844 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1847 debug
.info
->e
.exp
= x
;
1848 debug
.info
->e
.env
= env
;
1850 scm_report_stack_overflow ();
1857 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1860 SCM_CLEAR_ARGSREADY (debug
);
1861 if (SCM_OVERFLOWP (debug
))
1864 * In theory, this should be the only place where it is necessary to
1865 * check for space in debug.vect since both eval frames and
1866 * available space are even.
1868 * For this to be the case, however, it is necessary that primitive
1869 * special forms which jump back to `loop', `begin' or some similar
1870 * label call PREP_APPLY. A convenient way to do this is to jump to
1871 * `loopnoap' or `cdrxnoap'.
1873 else if (++debug
.info
>= debug_info_end
)
1875 SCM_SET_OVERFLOW (debug
);
1879 debug
.info
->e
.exp
= x
;
1880 debug
.info
->e
.env
= env
;
1881 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1882 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1884 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1885 SCM_SET_TAILREC (debug
);
1886 if (SCM_CHEAPTRAPS_P
)
1887 t
.arg1
= scm_make_debugobj (&debug
);
1890 scm_make_cont (&t
.arg1
);
1891 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1893 x
= SCM_THROW_VALUE (t
.arg1
);
1899 /* This gives the possibility for the debugger to
1900 modify the source expression before evaluation. */
1904 scm_ithrow (scm_sym_enter_frame
,
1905 scm_cons2 (t
.arg1
, tail
,
1906 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1910 #if defined (USE_THREADS) || defined (DEVAL)
1914 switch (SCM_TYP7 (x
))
1916 case scm_tcs_symbols
:
1917 /* Only happens when called at top level.
1919 x
= scm_cons (x
, SCM_UNDEFINED
);
1922 case SCM_BIT8(SCM_IM_AND
):
1925 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1926 if (SCM_FALSEP (EVALCAR (x
, env
)))
1928 RETURN (SCM_BOOL_F
);
1932 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1935 case SCM_BIT8(SCM_IM_BEGIN
):
1937 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1943 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1945 if (SCM_IMP (SCM_CAR (x
)))
1947 if (SCM_ISYMP (SCM_CAR (x
)))
1949 x
= scm_m_expand_body (x
, env
);
1954 SCM_CEVAL (SCM_CAR (x
), env
);
1958 carloop
: /* scm_eval car of last form in list */
1959 if (SCM_NCELLP (SCM_CAR (x
)))
1962 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1965 if (SCM_SYMBOLP (SCM_CAR (x
)))
1968 RETURN (*scm_lookupcar (x
, env
, 1))
1972 goto loop
; /* tail recurse */
1975 case SCM_BIT8(SCM_IM_CASE
):
1977 t
.arg1
= EVALCAR (x
, env
);
1978 while (SCM_NIMP (x
= SCM_CDR (x
)))
1981 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1984 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1987 proc
= SCM_CAR (proc
);
1988 while (SCM_NIMP (proc
))
1990 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1992 x
= SCM_CDR (SCM_CAR (x
));
1993 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1996 proc
= SCM_CDR (proc
);
1999 RETURN (SCM_UNSPECIFIED
)
2002 case SCM_BIT8(SCM_IM_COND
):
2003 while (SCM_NIMP (x
= SCM_CDR (x
)))
2006 t
.arg1
= EVALCAR (proc
, env
);
2007 if (SCM_NFALSEP (t
.arg1
))
2014 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2016 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2020 proc
= EVALCAR (proc
, env
);
2021 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2022 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2027 RETURN (SCM_UNSPECIFIED
)
2030 case SCM_BIT8(SCM_IM_DO
):
2032 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2033 t
.arg1
= SCM_EOL
; /* values */
2034 while (SCM_NIMP (proc
))
2036 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2037 proc
= SCM_CDR (proc
);
2039 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2040 x
= SCM_CDR (SCM_CDR (x
));
2041 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2043 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2045 t
.arg1
= SCM_CAR (proc
); /* body */
2046 SIDEVAL (t
.arg1
, env
);
2048 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2050 proc
= SCM_CDR (proc
))
2051 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2052 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2056 RETURN (SCM_UNSPECIFIED
);
2057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2061 case SCM_BIT8(SCM_IM_IF
):
2063 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2065 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2067 RETURN (SCM_UNSPECIFIED
);
2069 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2073 case SCM_BIT8(SCM_IM_LET
):
2075 proc
= SCM_CAR (SCM_CDR (x
));
2079 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2081 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2082 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2087 case SCM_BIT8(SCM_IM_LETREC
):
2089 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2095 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2097 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2098 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2102 case SCM_BIT8(SCM_IM_LETSTAR
):
2107 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2112 t
.arg1
= SCM_CAR (proc
);
2113 proc
= SCM_CDR (proc
);
2114 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2116 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2119 case SCM_BIT8(SCM_IM_OR
):
2122 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2124 x
= EVALCAR (x
, env
);
2125 if (SCM_NFALSEP (x
))
2131 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2135 case SCM_BIT8(SCM_IM_LAMBDA
):
2136 RETURN (scm_closure (SCM_CDR (x
), env
));
2139 case SCM_BIT8(SCM_IM_QUOTE
):
2140 RETURN (SCM_CAR (SCM_CDR (x
)));
2143 case SCM_BIT8(SCM_IM_SET_X
):
2146 switch (SCM_ITAG3 (proc
))
2149 t
.lloc
= scm_lookupcar (x
, env
, 1);
2151 case scm_tc3_cons_gloc
:
2152 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2154 #ifdef MEMOIZE_LOCALS
2156 t
.lloc
= scm_ilookup (proc
, env
);
2161 *t
.lloc
= EVALCAR (x
, env
);
2165 RETURN (SCM_UNSPECIFIED
);
2169 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2170 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2172 /* new syntactic forms go here. */
2173 case SCM_BIT8(SCM_MAKISYM (0)):
2175 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2176 switch SCM_ISYMNUM (proc
)
2179 case (SCM_ISYMNUM (IM_VREF
)):
2182 var
= SCM_CAR (SCM_CDR (x
));
2183 RETURN (SCM_CDR(var
));
2185 case (SCM_ISYMNUM (IM_VSET
)):
2186 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2187 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2188 RETURN (SCM_UNSPECIFIED
)
2191 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2193 proc
= EVALCAR (proc
, env
);
2194 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2195 if (SCM_CLOSUREP (proc
))
2198 PREP_APPLY (proc
, SCM_EOL
);
2199 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2200 t
.arg1
= EVALCAR (t
.arg1
, env
);
2202 debug
.info
->a
.args
= t
.arg1
;
2204 #ifndef SCM_RECKLESS
2205 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2209 /* Copy argument list */
2210 if (SCM_IMP (t
.arg1
))
2214 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2215 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2216 && SCM_CONSP (t
.arg1
))
2218 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2222 SCM_SETCDR (tl
, t
.arg1
);
2225 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2226 x
= SCM_CODE (proc
);
2232 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2233 scm_make_cont (&t
.arg1
);
2234 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2237 val
= SCM_THROW_VALUE (t
.arg1
);
2241 proc
= evalcar (proc
, env
);
2242 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2243 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2247 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2248 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2250 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2251 proc
= SCM_CADR (x
); /* unevaluated operands */
2252 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2254 arg2
= *scm_ilookup (proc
, env
);
2255 else if (SCM_NCONSP (proc
))
2257 if (SCM_NCELLP (proc
))
2258 arg2
= SCM_GLOC_VAL (proc
);
2260 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2264 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2265 t
.lloc
= SCM_CDRLOC (arg2
);
2266 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2268 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2269 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2274 /* The type dispatch code is duplicated here
2275 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2276 * cuts down execution time for type dispatch to 50%.
2279 int i
, n
, end
, mask
;
2280 SCM z
= SCM_CDDR (x
);
2281 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2282 proc
= SCM_CADR (z
);
2284 if (SCM_NIMP (proc
))
2286 /* Prepare for linear search */
2289 end
= SCM_LENGTH (proc
);
2293 /* Compute a hash value */
2294 int hashset
= SCM_INUM (proc
);
2296 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2297 proc
= SCM_CADR (z
);
2300 if (SCM_NIMP (t
.arg1
))
2303 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2304 [scm_si_hashsets
+ hashset
];
2305 t
.arg1
= SCM_CDR (t
.arg1
);
2307 while (--j
&& SCM_NIMP (t
.arg1
));
2312 /* Search for match */
2316 z
= SCM_VELTS (proc
)[i
];
2317 t
.arg1
= arg2
; /* list of arguments */
2318 if (SCM_NIMP (t
.arg1
))
2321 /* More arguments than specifiers => CLASS != ENV */
2322 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2324 t
.arg1
= SCM_CDR (t
.arg1
);
2327 while (--j
&& SCM_NIMP (t
.arg1
));
2328 /* Fewer arguments than specifiers => CAR != ENV */
2329 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2332 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2334 SCM_CMETHOD_ENV (z
));
2335 x
= SCM_CMETHOD_CODE (z
);
2341 z
= scm_memoize_method (x
, arg2
);
2345 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2347 t
.arg1
= EVALCAR (x
, env
);
2348 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2350 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2352 t
.arg1
= EVALCAR (x
, env
);
2355 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2356 = SCM_UNPACK (EVALCAR (proc
, env
));
2357 RETURN (SCM_UNSPECIFIED
)
2359 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2361 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2363 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2364 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2366 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2368 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2374 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2377 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2379 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2383 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2385 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2387 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2389 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2391 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2392 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2394 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2396 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2402 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2405 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2407 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2411 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2413 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2417 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2420 t
.arg1
= SCM_CAR (x
);
2421 arg2
= SCM_CDAR (env
);
2422 while (SCM_NIMP (arg2
))
2424 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2425 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2427 SCM_SETCAR (arg2
, proc
);
2428 t
.arg1
= SCM_CDR (t
.arg1
);
2429 arg2
= SCM_CDR (arg2
);
2431 t
.arg1
= SCM_CAR (x
);
2432 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2434 arg2
= x
= SCM_CDR (x
);
2435 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2437 SIDEVAL (SCM_CAR (x
), env
);
2440 proc
= EVALCAR (x
, env
);
2442 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2443 arg2
= SCM_CDAR (env
);
2444 while (SCM_NIMP (arg2
))
2446 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2448 t
.arg1
= SCM_CDR (t
.arg1
);
2449 arg2
= SCM_CDR (arg2
);
2461 /* scm_everr (x, env,...) */
2462 scm_misc_error (NULL
,
2463 "Wrong type to apply: ~S",
2464 scm_listify (proc
, SCM_UNDEFINED
));
2465 case scm_tc7_vector
:
2469 case scm_tc7_byvect
:
2476 #ifdef HAVE_LONG_LONGS
2477 case scm_tc7_llvect
:
2480 case scm_tc7_string
:
2481 case scm_tc7_substring
:
2483 case scm_tcs_closures
:
2491 #ifdef MEMOIZE_LOCALS
2492 case SCM_BIT8(SCM_ILOC00
):
2493 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2494 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2495 #ifndef SCM_RECKLESS
2501 #endif /* ifdef MEMOIZE_LOCALS */
2504 case scm_tcs_cons_gloc
: {
2505 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2507 /* This is a struct implanted in the code, not a gloc. */
2510 proc
= SCM_PACK (vcell
);
2511 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2512 #ifndef SCM_RECKLESS
2521 case scm_tcs_cons_nimcar
:
2522 if (SCM_SYMBOLP (SCM_CAR (x
)))
2525 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2528 /* we have lost the race, start again. */
2533 proc
= *scm_lookupcar (x
, env
, 1);
2541 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2547 /* Set a flag during macro expansion so that macro
2548 application frames can be deleted from the backtrace. */
2549 SCM_SET_MACROEXP (debug
);
2551 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2552 scm_cons (env
, scm_listofnull
));
2555 SCM_CLEAR_MACROEXP (debug
);
2557 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2560 if (scm_ilength (t
.arg1
) <= 0)
2561 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2563 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2566 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2567 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2568 /* Prevent memoizing result of define macro */
2570 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2571 scm_set_source_properties_x (debug
.info
->e
.exp
,
2572 scm_source_properties (x
));
2576 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2577 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2581 /* Prevent memoizing of debug info expression. */
2582 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2587 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2588 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2592 if (SCM_NIMP (x
= t
.arg1
))
2600 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2601 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2602 #ifndef SCM_RECKLESS
2606 if (SCM_CLOSUREP (proc
))
2608 arg2
= SCM_CAR (SCM_CODE (proc
));
2609 t
.arg1
= SCM_CDR (x
);
2610 while (SCM_NIMP (arg2
))
2612 if (SCM_NCONSP (arg2
))
2614 if (SCM_IMP (t
.arg1
))
2615 goto umwrongnumargs
;
2616 arg2
= SCM_CDR (arg2
);
2617 t
.arg1
= SCM_CDR (t
.arg1
);
2619 if (SCM_NNULLP (t
.arg1
))
2620 goto umwrongnumargs
;
2622 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2623 goto handle_a_macro
;
2629 PREP_APPLY (proc
, SCM_EOL
);
2630 if (SCM_NULLP (SCM_CDR (x
))) {
2633 switch (SCM_TYP7 (proc
))
2634 { /* no arguments given */
2635 case scm_tc7_subr_0
:
2636 RETURN (SCM_SUBRF (proc
) ());
2637 case scm_tc7_subr_1o
:
2638 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2640 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2641 case scm_tc7_rpsubr
:
2642 RETURN (SCM_BOOL_T
);
2644 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2646 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2648 RETURN (scm_smob_apply_0 (proc
));
2652 proc
= SCM_CCLO_SUBR (proc
);
2654 debug
.info
->a
.proc
= proc
;
2655 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2660 proc
= SCM_PROCEDURE (proc
);
2662 debug
.info
->a
.proc
= proc
;
2664 if (!SCM_CLOSUREP (proc
))
2666 if (scm_badformalsp (proc
, 0))
2667 goto umwrongnumargs
;
2668 case scm_tcs_closures
:
2669 x
= SCM_CODE (proc
);
2670 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2672 case scm_tcs_cons_gloc
:
2673 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2675 x
= SCM_ENTITY_PROCEDURE (proc
);
2679 else if (!SCM_I_OPERATORP (proc
))
2684 proc
= (SCM_I_ENTITYP (proc
)
2685 ? SCM_ENTITY_PROCEDURE (proc
)
2686 : SCM_OPERATOR_PROCEDURE (proc
));
2688 debug
.info
->a
.proc
= proc
;
2689 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2691 if (SCM_NIMP (proc
))
2696 case scm_tc7_contin
:
2697 case scm_tc7_subr_1
:
2698 case scm_tc7_subr_2
:
2699 case scm_tc7_subr_2o
:
2701 case scm_tc7_subr_3
:
2702 case scm_tc7_lsubr_2
:
2706 /* scm_everr (x, env,...) */
2707 scm_wrong_num_args (proc
);
2709 /* handle macros here */
2714 /* must handle macros by here */
2719 else if (SCM_CONSP (x
))
2721 if (SCM_IMP (SCM_CAR (x
)))
2722 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2724 t
.arg1
= EVALCELLCAR (x
, env
);
2726 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2728 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2730 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2732 t
.arg1
= SCM_PACK (vcell
);
2737 t
.arg1
= EVALCAR (x
, env
);
2740 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2747 switch (SCM_TYP7 (proc
))
2748 { /* have one argument in t.arg1 */
2749 case scm_tc7_subr_2o
:
2750 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2751 case scm_tc7_subr_1
:
2752 case scm_tc7_subr_1o
:
2753 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2755 if (SCM_SUBRF (proc
))
2757 if (SCM_INUMP (t
.arg1
))
2759 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2761 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2762 if (SCM_REALP (t
.arg1
))
2764 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2767 if (SCM_BIGP (t
.arg1
))
2769 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2773 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2774 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2776 proc
= SCM_SNAME (proc
);
2778 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2779 while ('c' != *--chrs
)
2781 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2782 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2783 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2787 case scm_tc7_rpsubr
:
2788 RETURN (SCM_BOOL_T
);
2790 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2793 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2795 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2798 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2800 RETURN (scm_smob_apply_1 (proc
, t
.arg1
));
2805 proc
= SCM_CCLO_SUBR (proc
);
2807 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2808 debug
.info
->a
.proc
= proc
;
2813 proc
= SCM_PROCEDURE (proc
);
2815 debug
.info
->a
.proc
= proc
;
2817 if (!SCM_CLOSUREP (proc
))
2819 if (scm_badformalsp (proc
, 1))
2820 goto umwrongnumargs
;
2821 case scm_tcs_closures
:
2823 x
= SCM_CODE (proc
);
2825 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2827 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2830 case scm_tc7_contin
:
2831 scm_call_continuation (proc
, t
.arg1
);
2832 case scm_tcs_cons_gloc
:
2833 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2835 x
= SCM_ENTITY_PROCEDURE (proc
);
2837 arg2
= debug
.info
->a
.args
;
2839 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2843 else if (!SCM_I_OPERATORP (proc
))
2849 proc
= (SCM_I_ENTITYP (proc
)
2850 ? SCM_ENTITY_PROCEDURE (proc
)
2851 : SCM_OPERATOR_PROCEDURE (proc
));
2853 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2854 debug
.info
->a
.proc
= proc
;
2856 if (SCM_NIMP (proc
))
2861 case scm_tc7_subr_2
:
2862 case scm_tc7_subr_0
:
2863 case scm_tc7_subr_3
:
2864 case scm_tc7_lsubr_2
:
2873 else if (SCM_CONSP (x
))
2875 if (SCM_IMP (SCM_CAR (x
)))
2876 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2878 arg2
= EVALCELLCAR (x
, env
);
2880 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2882 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2884 arg2
= SCM_CAR (x
); /* struct planted in code */
2886 arg2
= SCM_PACK (vcell
);
2891 arg2
= EVALCAR (x
, env
);
2893 { /* have two or more arguments */
2895 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2898 if (SCM_NULLP (x
)) {
2903 switch (SCM_TYP7 (proc
))
2904 { /* have two arguments */
2905 case scm_tc7_subr_2
:
2906 case scm_tc7_subr_2o
:
2907 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2910 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2912 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2914 case scm_tc7_lsubr_2
:
2915 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2916 case scm_tc7_rpsubr
:
2918 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2920 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
2922 RETURN (scm_smob_apply_2 (proc
, t
.arg1
, arg2
));
2927 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2928 scm_cons (proc
, debug
.info
->a
.args
),
2931 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2932 scm_cons2 (proc
, t
.arg1
,
2939 /* case scm_tc7_cclo:
2940 x = scm_cons(arg2, scm_eval_args(x, env));
2943 proc = SCM_CCLO_SUBR(proc);
2946 case scm_tcs_cons_gloc
:
2947 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2949 x
= SCM_ENTITY_PROCEDURE (proc
);
2951 arg2
= debug
.info
->a
.args
;
2953 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2957 else if (!SCM_I_OPERATORP (proc
))
2963 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2964 ? SCM_ENTITY_PROCEDURE (proc
)
2965 : SCM_OPERATOR_PROCEDURE (proc
),
2966 scm_cons (proc
, debug
.info
->a
.args
),
2969 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2970 ? SCM_ENTITY_PROCEDURE (proc
)
2971 : SCM_OPERATOR_PROCEDURE (proc
),
2972 scm_cons2 (proc
, t
.arg1
,
2980 case scm_tc7_subr_0
:
2982 case scm_tc7_subr_1o
:
2983 case scm_tc7_subr_1
:
2984 case scm_tc7_subr_3
:
2985 case scm_tc7_contin
:
2990 proc
= SCM_PROCEDURE (proc
);
2992 debug
.info
->a
.proc
= proc
;
2994 if (!SCM_CLOSUREP (proc
))
2996 if (scm_badformalsp (proc
, 2))
2997 goto umwrongnumargs
;
2998 case scm_tcs_closures
:
3001 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3005 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3006 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
3008 x
= SCM_CODE (proc
);
3013 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3017 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3018 scm_deval_args (x
, env
, proc
,
3019 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3023 switch (SCM_TYP7 (proc
))
3024 { /* have 3 or more arguments */
3026 case scm_tc7_subr_3
:
3027 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3028 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3029 SCM_CADDR (debug
.info
->a
.args
)));
3031 #ifdef BUILTIN_RPASUBR
3032 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3033 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3036 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3037 arg2
= SCM_CDR (arg2
);
3039 while (SCM_NIMP (arg2
));
3041 #endif /* BUILTIN_RPASUBR */
3042 case scm_tc7_rpsubr
:
3043 #ifdef BUILTIN_RPASUBR
3044 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3046 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3049 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3051 arg2
= SCM_CAR (t
.arg1
);
3052 t
.arg1
= SCM_CDR (t
.arg1
);
3054 while (SCM_NIMP (t
.arg1
));
3056 #else /* BUILTIN_RPASUBR */
3057 RETURN (SCM_APPLY (proc
, t
.arg1
,
3059 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3061 #endif /* BUILTIN_RPASUBR */
3062 case scm_tc7_lsubr_2
:
3063 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3064 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3066 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3068 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3070 RETURN (scm_smob_apply_3 (proc
, t
.arg1
, arg2
,
3071 SCM_CDDR (debug
.info
->a
.args
)));
3077 proc
= SCM_PROCEDURE (proc
);
3078 debug
.info
->a
.proc
= proc
;
3079 if (!SCM_CLOSUREP (proc
))
3081 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3082 goto umwrongnumargs
;
3083 case scm_tcs_closures
:
3084 SCM_SET_ARGSREADY (debug
);
3085 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3088 x
= SCM_CODE (proc
);
3091 case scm_tc7_subr_3
:
3092 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3093 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3095 #ifdef BUILTIN_RPASUBR
3096 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3099 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3102 while (SCM_NIMP (x
));
3104 #endif /* BUILTIN_RPASUBR */
3105 case scm_tc7_rpsubr
:
3106 #ifdef BUILTIN_RPASUBR
3107 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3111 t
.arg1
= EVALCAR (x
, env
);
3112 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3117 while (SCM_NIMP (x
));
3119 #else /* BUILTIN_RPASUBR */
3120 RETURN (SCM_APPLY (proc
, t
.arg1
,
3122 scm_eval_args (x
, env
, proc
),
3124 #endif /* BUILTIN_RPASUBR */
3125 case scm_tc7_lsubr_2
:
3126 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3128 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3130 scm_eval_args (x
, env
, proc
))));
3132 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3134 RETURN (scm_smob_apply_3 (proc
, t
.arg1
, arg2
,
3135 scm_eval_args (x
, env
, proc
)));
3141 proc
= SCM_PROCEDURE (proc
);
3142 if (!SCM_CLOSUREP (proc
))
3145 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3146 if (SCM_NULLP (formals
)
3147 || (SCM_CONSP (formals
)
3148 && (SCM_NULLP (SCM_CDR (formals
))
3149 || (SCM_CONSP (SCM_CDR (formals
))
3150 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3151 goto umwrongnumargs
;
3153 case scm_tcs_closures
:
3155 SCM_SET_ARGSREADY (debug
);
3157 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3160 scm_eval_args (x
, env
, proc
)),
3162 x
= SCM_CODE (proc
);
3165 case scm_tcs_cons_gloc
:
3166 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3169 arg2
= debug
.info
->a
.args
;
3171 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3173 x
= SCM_ENTITY_PROCEDURE (proc
);
3176 else if (!SCM_I_OPERATORP (proc
))
3180 case scm_tc7_subr_2
:
3181 case scm_tc7_subr_1o
:
3182 case scm_tc7_subr_2o
:
3183 case scm_tc7_subr_0
:
3185 case scm_tc7_subr_1
:
3186 case scm_tc7_contin
:
3194 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3195 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3197 SCM_CLEAR_TRACED_FRAME (debug
);
3198 if (SCM_CHEAPTRAPS_P
)
3199 t
.arg1
= scm_make_debugobj (&debug
);
3202 scm_make_cont (&t
.arg1
);
3203 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3205 proc
= SCM_THROW_VALUE (t
.arg1
);
3209 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3212 scm_last_debug_frame
= debug
.prev
;
3218 /* SECTION: This code is compiled once.
3223 /* This code processes the arguments to apply:
3225 (apply PROC ARG1 ... ARGS)
3227 Given a list (ARG1 ... ARGS), this function conses the ARG1
3228 ... arguments onto the front of ARGS, and returns the resulting
3229 list. Note that ARGS is a list; thus, the argument to this
3230 function is a list whose last element is a list.
3232 Apply calls this function, and applies PROC to the elements of the
3233 result. apply:nconc2last takes care of building the list of
3234 arguments, given (ARG1 ... ARGS).
3236 Rather than do new consing, apply:nconc2last destroys its argument.
3237 On that topic, this code came into my care with the following
3238 beautifully cryptic comment on that topic: "This will only screw
3239 you if you do (scm_apply scm_apply '( ... ))" If you know what
3240 they're referring to, send me a patch to this comment. */
3242 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3245 #define FUNC_NAME s_scm_nconc2last
3248 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3250 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3251 lloc
= SCM_CDRLOC (*lloc
);
3252 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3253 *lloc
= SCM_CAR (*lloc
);
3261 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3262 * It is compiled twice.
3268 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3275 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3280 /* Apply a function to a list of arguments.
3282 This function is exported to the Scheme level as taking two
3283 required arguments and a tail argument, as if it were:
3284 (lambda (proc arg1 . args) ...)
3285 Thus, if you just have a list of arguments to pass to a procedure,
3286 pass the list as ARG1, and '() for ARGS. If you have some fixed
3287 args, pass the first as ARG1, then cons any remaining fixed args
3288 onto the front of your argument list, and pass that as ARGS. */
3291 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3293 #ifdef DEBUG_EXTENSIONS
3295 scm_debug_frame debug
;
3296 scm_debug_info debug_vect_body
;
3297 debug
.prev
= scm_last_debug_frame
;
3298 debug
.status
= SCM_APPLYFRAME
;
3299 debug
.vect
= &debug_vect_body
;
3300 debug
.vect
[0].a
.proc
= proc
;
3301 debug
.vect
[0].a
.args
= SCM_EOL
;
3302 scm_last_debug_frame
= &debug
;
3305 return scm_dapply (proc
, arg1
, args
);
3309 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3311 /* If ARGS is the empty list, then we're calling apply with only two
3312 arguments --- ARG1 is the list of arguments for PROC. Whatever
3313 the case, futz with things so that ARG1 is the first argument to
3314 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3317 Setting the debug apply frame args this way is pretty messy.
3318 Perhaps we should store arg1 and args directly in the frame as
3319 received, and let scm_frame_arguments unpack them, because that's
3320 a relatively rare operation. This works for now; if the Guile
3321 developer archives are still around, see Mikael's post of
3323 if (SCM_NULLP (args
))
3325 if (SCM_NULLP (arg1
))
3327 arg1
= SCM_UNDEFINED
;
3329 debug
.vect
[0].a
.args
= SCM_EOL
;
3335 debug
.vect
[0].a
.args
= arg1
;
3337 args
= SCM_CDR (arg1
);
3338 arg1
= SCM_CAR (arg1
);
3343 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3344 args
= scm_nconc2last (args
);
3346 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3350 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3353 if (SCM_CHEAPTRAPS_P
)
3354 tmp
= scm_make_debugobj (&debug
);
3357 scm_make_cont (&tmp
);
3358 if (setjmp (SCM_JMPBUF (tmp
)))
3361 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3369 switch (SCM_TYP7 (proc
))
3371 case scm_tc7_subr_2o
:
3372 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3373 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3374 case scm_tc7_subr_2
:
3375 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3377 args
= SCM_CAR (args
);
3378 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3379 case scm_tc7_subr_0
:
3380 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3381 RETURN (SCM_SUBRF (proc
) ())
3382 case scm_tc7_subr_1
:
3383 case scm_tc7_subr_1o
:
3384 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3385 RETURN (SCM_SUBRF (proc
) (arg1
))
3387 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3388 if (SCM_SUBRF (proc
))
3390 if (SCM_INUMP (arg1
))
3392 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3394 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3395 if (SCM_REALP (arg1
))
3397 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3400 if (SCM_BIGP (arg1
))
3401 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3404 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3405 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3407 proc
= SCM_SNAME (proc
);
3409 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3410 while ('c' != *--chrs
)
3412 SCM_ASSERT (SCM_CONSP (arg1
),
3413 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3414 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3418 case scm_tc7_subr_3
:
3419 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3422 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3424 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3426 case scm_tc7_lsubr_2
:
3427 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3428 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3430 if (SCM_NULLP (args
))
3431 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3432 while (SCM_NIMP (args
))
3434 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3435 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3436 args
= SCM_CDR (args
);
3439 case scm_tc7_rpsubr
:
3440 if (SCM_NULLP (args
))
3441 RETURN (SCM_BOOL_T
);
3442 while (SCM_NIMP (args
))
3444 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3445 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3446 RETURN (SCM_BOOL_F
);
3447 arg1
= SCM_CAR (args
);
3448 args
= SCM_CDR (args
);
3450 RETURN (SCM_BOOL_T
);
3451 case scm_tcs_closures
:
3453 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3455 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3457 #ifndef SCM_RECKLESS
3458 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3462 /* Copy argument list */
3467 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3468 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3470 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3474 SCM_SETCDR (tl
, arg1
);
3477 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3478 proc
= SCM_CDR (SCM_CODE (proc
));
3481 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3483 if (SCM_IMP (SCM_CAR (proc
)))
3485 if (SCM_ISYMP (SCM_CAR (proc
)))
3487 proc
= scm_m_expand_body (proc
, args
);
3492 SCM_CEVAL (SCM_CAR (proc
), args
);
3495 RETURN (EVALCAR (proc
, args
));
3497 if (!SCM_SMOB_DESCRIPTOR (proc
).apply
)
3499 if (SCM_NULLP (args
))
3500 RETURN (scm_smob_apply_0 (proc
))
3501 else if (SCM_NULLP (SCM_CDR (args
)))
3502 RETURN (scm_smob_apply_1 (proc
, SCM_CAR (args
)))
3503 else if (SCM_NULLP (SCM_CDDR (args
)))
3504 RETURN (scm_smob_apply_2 (proc
, SCM_CAR (args
), SCM_CADR (args
)))
3506 RETURN (scm_smob_apply_3 (proc
, SCM_CAR (args
), SCM_CADR (args
),
3508 case scm_tc7_contin
:
3509 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3510 scm_call_continuation (proc
, arg1
);
3514 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3516 proc
= SCM_CCLO_SUBR (proc
);
3517 debug
.vect
[0].a
.proc
= proc
;
3518 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3520 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3522 proc
= SCM_CCLO_SUBR (proc
);
3527 proc
= SCM_PROCEDURE (proc
);
3529 debug
.vect
[0].a
.proc
= proc
;
3532 case scm_tcs_cons_gloc
:
3533 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3536 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3538 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3540 RETURN (scm_apply_generic (proc
, args
));
3542 else if (!SCM_I_OPERATORP (proc
))
3547 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3549 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3552 proc
= (SCM_I_ENTITYP (proc
)
3553 ? SCM_ENTITY_PROCEDURE (proc
)
3554 : SCM_OPERATOR_PROCEDURE (proc
));
3556 debug
.vect
[0].a
.proc
= proc
;
3557 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3559 if (SCM_NIMP (proc
))
3565 scm_wrong_num_args (proc
);
3568 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3573 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3574 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3576 SCM_CLEAR_TRACED_FRAME (debug
);
3577 if (SCM_CHEAPTRAPS_P
)
3578 arg1
= scm_make_debugobj (&debug
);
3581 scm_make_cont (&arg1
);
3582 if (setjmp (SCM_JMPBUF (arg1
)))
3584 proc
= SCM_THROW_VALUE (arg1
);
3588 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3591 scm_last_debug_frame
= debug
.prev
;
3597 /* SECTION: The rest of this file is only read once.
3602 /* Typechecking for multi-argument MAP and FOR-EACH.
3604 Verify that each element of the vector ARGV, except for the first,
3605 is a proper list whose length is LEN. Attribute errors to WHO,
3606 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3608 check_map_args (SCM argv
,
3615 SCM
*ve
= SCM_VELTS (argv
);
3618 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3620 int elt_len
= scm_ilength (ve
[i
]);
3625 scm_apply_generic (gf
, scm_cons (proc
, args
));
3627 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3631 scm_out_of_range (who
, ve
[i
]);
3634 scm_remember (&argv
);
3638 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3640 /* Note: Currently, scm_map applies PROC to the argument list(s)
3641 sequentially, starting with the first element(s). This is used in
3642 evalext.c where the Scheme procedure `map-in-order', which guarantees
3643 sequential behaviour, is implemented using scm_map. If the
3644 behaviour changes, we need to update `map-in-order'.
3648 scm_map (SCM proc
, SCM arg1
, SCM args
)
3649 #define FUNC_NAME s_map
3654 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3656 len
= scm_ilength (arg1
);
3657 SCM_GASSERTn (len
>= 0,
3658 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3659 SCM_VALIDATE_REST_ARGUMENT (args
);
3660 if (SCM_NULLP (args
))
3662 while (SCM_NIMP (arg1
))
3664 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3666 pres
= SCM_CDRLOC (*pres
);
3667 arg1
= SCM_CDR (arg1
);
3671 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3672 ve
= SCM_VELTS (args
);
3673 #ifndef SCM_RECKLESS
3674 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3679 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3681 if (SCM_IMP (ve
[i
]))
3683 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3684 ve
[i
] = SCM_CDR (ve
[i
]);
3686 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3687 pres
= SCM_CDRLOC (*pres
);
3693 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3696 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3697 #define FUNC_NAME s_for_each
3699 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3701 len
= scm_ilength (arg1
);
3702 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3703 SCM_ARG2
, s_for_each
);
3704 SCM_VALIDATE_REST_ARGUMENT (args
);
3707 while SCM_NIMP (arg1
)
3709 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3710 arg1
= SCM_CDR (arg1
);
3712 return SCM_UNSPECIFIED
;
3714 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3715 ve
= SCM_VELTS (args
);
3716 #ifndef SCM_RECKLESS
3717 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3722 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3725 (ve
[i
]) return SCM_UNSPECIFIED
;
3726 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3727 ve
[i
] = SCM_CDR (ve
[i
]);
3729 scm_apply (proc
, arg1
, SCM_EOL
);
3736 scm_closure (SCM code
, SCM env
)
3740 SCM_SETCODE (z
, code
);
3741 SCM_SETENV (z
, env
);
3746 long scm_tc16_promise
;
3749 scm_makprom (SCM code
)
3751 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3757 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3759 int writingp
= SCM_WRITINGP (pstate
);
3760 scm_puts ("#<promise ", port
);
3761 SCM_SET_WRITINGP (pstate
, 1);
3762 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3763 SCM_SET_WRITINGP (pstate
, writingp
);
3764 scm_putc ('>', port
);
3769 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3771 "If the promise X has not been computed yet, compute and return\n"
3772 "X, otherwise just return the previously computed value.")
3773 #define FUNC_NAME s_scm_force
3775 SCM_VALIDATE_SMOB (1, x
, promise
);
3776 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3778 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3779 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3782 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3783 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3787 return SCM_CELL_OBJECT_1 (x
);
3792 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3794 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3795 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3796 #define FUNC_NAME s_scm_promise_p
3798 return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_promise
, x
));
3803 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3804 (SCM xorig
, SCM x
, SCM y
),
3806 #define FUNC_NAME s_scm_cons_source
3810 SCM_SET_CELL_OBJECT_0 (z
, x
);
3811 SCM_SET_CELL_OBJECT_1 (z
, y
);
3812 /* Copy source properties possibly associated with xorig. */
3813 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3815 scm_whash_insert (scm_source_whash
, z
, p
);
3821 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3823 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3824 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3825 "contents of both pairs and vectors (since both cons cells and vector\n"
3826 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3827 "any other object.")
3828 #define FUNC_NAME s_scm_copy_tree
3833 if (SCM_VECTORP (obj
))
3835 scm_sizet i
= SCM_LENGTH (obj
);
3836 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3838 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3841 if (SCM_NCONSP (obj
))
3843 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3844 ans
= tl
= scm_cons_source (obj
,
3845 scm_copy_tree (SCM_CAR (obj
)),
3847 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3849 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3853 SCM_SETCDR (tl
, obj
);
3859 SCM scm_system_transformer
;
3862 scm_i_eval_x (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 (exp
, env
);
3871 scm_i_eval (SCM exp
, SCM env
)
3873 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3874 if (SCM_NIMP (transformer
))
3875 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3876 return SCM_XEVAL (scm_copy_tree (exp
), env
);
3880 scm_eval_x (SCM exp
, SCM module
)
3882 return scm_i_eval_x (exp
,
3883 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (module
)));
3886 /* Eval does not take the second arg optionally. This is intentional
3887 * in order to be R5RS compatible, and to prepare for the new module
3888 * system, where we would like to make the choice of evaluation
3889 * environment explicit.
3892 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3893 (SCM exp
, SCM environment
),
3894 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3895 "environment given by @var{environment specifier}.")
3896 #define FUNC_NAME s_scm_eval
3898 SCM_VALIDATE_MODULE (2, environment
);
3899 return scm_i_eval (scm_copy_tree (exp
),
3900 scm_top_level_env (SCM_MODULE_EVAL_CLOSURE (environment
)));
3904 #if (SCM_DEBUG_DEPRECATED == 0)
3906 /* Use scm_selected_module () or scm_interaction_environment ()
3907 * instead. The former is the module selected during loading of code.
3908 * The latter is the module in which the user of this thread currently
3909 * types expressions.
3912 SCM scm_top_level_lookup_closure_var
;
3914 /* Avoid using this functionality altogether (except for implementing
3915 * libguile, where you can use scm_i_eval or scm_i_eval_x).
3917 * Applications should use either C level scm_eval_x or Scheme scm_eval. */
3920 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3923 return scm_i_eval (obj
, env
);
3925 return scm_i_eval_x (obj
, env
);
3928 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3929 (SCM obj
, SCM env_thunk
),
3930 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3931 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3932 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3933 #define FUNC_NAME s_scm_eval2
3935 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
3939 #endif /* DEPRECATED */
3942 /* At this point, scm_deval and scm_dapply are generated.
3945 #ifdef DEBUG_EXTENSIONS
3955 scm_init_opts (scm_evaluator_traps
,
3956 scm_evaluator_trap_table
,
3957 SCM_N_EVALUATOR_TRAPS
);
3958 scm_init_opts (scm_eval_options_interface
,
3960 SCM_N_EVAL_OPTIONS
);
3962 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3963 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3964 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3966 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3967 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
3969 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3970 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3971 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3972 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3973 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3975 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3976 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
3977 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
3978 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3979 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
3980 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
3985 #if SCM_DEBUG_DEPRECATED == 0
3986 scm_top_level_lookup_closure_var
=
3987 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
3990 #ifdef DEBUG_EXTENSIONS
3991 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3992 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3993 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3994 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3997 #include "libguile/eval.x"
3999 scm_add_feature ("delay");