1 /* Copyright (C) 1995,1996,1997,1998, 1999 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. */
43 /* This file is read twice in order to produce debugging versions of
44 * scm_ceval and scm_apply. These functions, scm_deval and
45 * scm_dapply, are produced when we define the preprocessor macro
46 * DEVAL. The file is divided into sections which are treated
47 * differently with respect to DEVAL. The heads of these sections are
48 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
57 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
58 #include "scmconfig.h"
60 /* AIX requires this to be the first thing in the file. The #pragma
61 directive is indented so pre-ANSI compilers will ignore it, rather
70 # ifndef alloca /* predefined by HP cc +Olibcalls */
82 #include "continuations.h"
99 /* The evaluator contains a plethora of EVAL symbols.
100 * This is an attempt at explanation.
102 * The following macros should be used in code which is read twice
103 * (where the choice of evaluator is hard soldered):
105 * SCM_CEVAL is the symbol used within one evaluator to call itself.
106 * Originally, it is defined to scm_ceval, but is redefined to
107 * scm_deval during the second pass.
109 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
110 * only side effects of expressions matter. All immediates are
113 * SCM_EVALIM is used when it is known that the expression is an
114 * immediate. (This macro never calls an evaluator.)
116 * EVALCAR evaluates the car of an expression.
118 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
119 * car is a lisp cell.
121 * The following macros should be used in code which is read once
122 * (where the choice of evaluator is dynamic):
124 * SCM_XEVAL takes care of immediates without calling an evaluator. It
125 * then calls scm_ceval *or* scm_deval, depending on the debugging
128 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
129 * depending on the debugging mode.
131 * The main motivation for keeping this plethora is efficiency
132 * together with maintainability (=> locality of code).
135 #define SCM_CEVAL scm_ceval
136 #define SIDEVAL(x, env) if (SCM_NIMP(x)) SCM_CEVAL((x), (env))
138 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
139 ? *scm_lookupcar(x, env, 1) \
140 : SCM_CEVAL(SCM_CAR(x), env))
142 #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
143 ? (SCM_IMP(SCM_CAR(x)) \
144 ? SCM_EVALIM(SCM_CAR(x), env) \
145 : SCM_GLOC_VAL(SCM_CAR(x))) \
146 : EVALCELLCAR(x, env))
148 #define EXTEND_ENV SCM_EXTEND_ENV
150 #ifdef MEMOIZE_LOCALS
153 scm_ilookup (iloc
, env
)
157 register int ir
= SCM_IFRAME (iloc
);
158 register SCM er
= env
;
159 for (; 0 != ir
; --ir
)
162 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
164 if (SCM_ICDRP (iloc
))
165 return SCM_CDRLOC (er
);
166 return SCM_CARLOC (SCM_CDR (er
));
172 /* The Lookup Car Race
175 Memoization of variables and special forms is done while executing
176 the code for the first time. As long as there is only one thread
177 everything is fine, but as soon as two threads execute the same
178 code concurrently `for the first time' they can come into conflict.
180 This memoization includes rewriting variable references into more
181 efficient forms and expanding macros. Furthermore, macro expansion
182 includes `compiling' special forms like `let', `cond', etc. into
183 tree-code instructions.
185 There shouldn't normally be a problem with memoizing local and
186 global variable references (into ilocs and glocs), because all
187 threads will mutate the code in *exactly* the same way and (if I
188 read the C code correctly) it is not possible to observe a half-way
189 mutated cons cell. The lookup procedure can handle this
190 transparently without any critical sections.
192 It is different with macro expansion, because macro expansion
193 happens outside of the lookup procedure and can't be
194 undone. Therefore it can't cope with it. It has to indicate
195 failure when it detects a lost race and hope that the caller can
196 handle it. Luckily, it turns out that this is the case.
198 An example to illustrate this: Suppose that the follwing form will
199 be memoized concurrently by two threads
203 Let's first examine the lookup of X in the body. The first thread
204 decides that it has to find the symbol "x" in the environment and
205 starts to scan it. Then the other thread takes over and actually
206 overtakes the first. It looks up "x" and substitutes an
207 appropriate iloc for it. Now the first thread continues and
208 completes its lookup. It comes to exactly the same conclusions as
209 the second one and could - without much ado - just overwrite the
210 iloc with the same iloc.
212 But let's see what will happen when the race occurs while looking
213 up the symbol "let" at the start of the form. It could happen that
214 the second thread interrupts the lookup of the first thread and not
215 only substitutes a gloc for it but goes right ahead and replaces it
216 with the compiled form (#@let* (x 12) x). Now, when the first
217 thread completes its lookup, it would replace the #@let* with a
218 gloc pointing to the "let" binding, effectively reverting the form
219 to (let (x 12) x). This is wrong. It has to detect that it has
220 lost the race and the evaluator has to reconsider the changed form
223 This race condition could be resolved with some kind of traffic
224 light (like mutexes) around scm_lookupcar, but I think that it is
225 best to avoid them in this case. They would serialize memoization
226 completely and because lookup involves calling arbitrary Scheme
227 code (via the lookup-thunk), threads could be blocked for an
228 arbitrary amount of time or even deadlock. But with the current
229 solution a lot of unnecessary work is potentially done. */
231 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
232 return NULL to indicate a failed lookup due to some race conditions
233 between threads. This only happens when VLOC is the first cell of
234 a special form that will eventually be memoized (like `let', etc.)
235 In that case the whole lookup is bogus and the caller has to
236 reconsider the complete special form.
238 SCM_LOOKUPCAR is still there, of course. It just calls
239 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
240 should only be called when it is known that VLOC is not the first
241 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
242 for NULL. I think I've found the only places where this
245 #endif /* USE_THREADS */
247 /* scm_lookupcar returns a pointer to this when a variable could not
248 be found and it should not throw an error. Never assign to this.
250 static scm_cell undef_cell
= { SCM_UNDEFINED
, SCM_UNDEFINED
};
254 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
257 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
261 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
263 register SCM var2
= var
;
265 #ifdef MEMOIZE_LOCALS
266 register SCM iloc
= SCM_ILOC00
;
268 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
270 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
272 al
= SCM_CARLOC (env
);
273 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
279 #ifdef MEMOIZE_LOCALS
281 if (SCM_CAR (vloc
) != var
)
284 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
286 return SCM_CDRLOC (*al
);
291 al
= SCM_CDRLOC (*al
);
292 if (SCM_CAR (fl
) == var
)
294 #ifdef MEMOIZE_LOCALS
295 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
296 if (SCM_UNBNDP (SCM_CAR (*al
)))
303 if (SCM_CAR (vloc
) != var
)
306 SCM_SETCAR (vloc
, iloc
);
308 return SCM_CARLOC (*al
);
310 #ifdef MEMOIZE_LOCALS
314 #ifdef MEMOIZE_LOCALS
315 iloc
= (~SCM_IDSTMSK
) & (iloc
+ SCM_IFRINC
);
319 SCM top_thunk
, vcell
;
322 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
326 top_thunk
= SCM_BOOL_F
;
327 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
328 if (vcell
== SCM_BOOL_F
)
334 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
338 /* scm_everr (vloc, genv,...) */
340 scm_misc_error (NULL
,
342 ? "Unbound variable: %S"
343 : "Damaged environment: %S",
344 scm_listify (var
, SCM_UNDEFINED
));
346 return SCM_CDRLOC (&undef_cell
);
350 if (SCM_CAR (vloc
) != var2
)
352 /* Some other thread has changed the very cell we are working
353 on. In effect, it must have done our job or messed it up
356 var
= SCM_CAR (vloc
);
358 return SCM_GLOC_VAL_LOC (var
);
359 #ifdef MEMOIZE_LOCALS
360 if ((var
& 127) == (127 & SCM_ILOC00
))
361 return scm_ilookup (var
, genv
);
363 /* We can't cope with anything else than glocs and ilocs. When
364 a special form has been memoized (i.e. `let' into `#@let') we
365 return NULL and expect the calling function to do the right
366 thing. For the evaluator, this means going back and redoing
367 the dispatch on the car of the form. */
370 #endif /* USE_THREADS */
372 SCM_SETCAR (vloc
, var
+ 1);
373 /* Except wait...what if the var is not a vcell,
374 * but syntax or something.... */
375 return SCM_CDRLOC (var
);
380 scm_lookupcar (vloc
, genv
, check
)
385 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
392 #define unmemocar scm_unmemocar
395 scm_unmemocar (form
, env
)
399 #ifdef DEBUG_EXTENSIONS
408 SCM_SETCAR (form
, SCM_CAR (c
- 1));
409 #ifdef MEMOIZE_LOCALS
410 #ifdef DEBUG_EXTENSIONS
411 else if (SCM_ILOCP (c
))
413 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
415 env
= SCM_CAR (SCM_CAR (env
));
416 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
418 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
427 scm_eval_car (pair
, env
)
431 return SCM_XEVALCAR (pair
, env
);
436 * The following rewrite expressions and
437 * some memoized forms have different syntax
440 const char scm_s_expression
[] = "missing or extra expression";
441 const char scm_s_test
[] = "bad test";
442 const char scm_s_body
[] = "bad body";
443 const char scm_s_bindings
[] = "bad bindings";
444 const char scm_s_variable
[] = "bad variable";
445 const char scm_s_clauses
[] = "bad or missing clauses";
446 const char scm_s_formals
[] = "bad formals";
448 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
449 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
453 #ifdef DEBUG_EXTENSIONS
454 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
458 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
462 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, const char *what
));
465 bodycheck (xorig
, bodyloc
, what
)
470 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
473 /* Check that the body denoted by XORIG is valid and rewrite it into
474 its internal form. The internal form of a body is just the body
475 itself, but prefixed with an ISYM that denotes to what kind of
476 outer construct this body belongs. A lambda body starts with
477 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
478 etc. The one exception is a body that belongs to a letrec that has
479 been formed by rewriting internal defines: it starts with
482 /* XXX - Besides controlling the rewriting of internal defines, the
483 additional ISYM could be used for improved error messages.
484 This is not done yet. */
487 scm_m_body (op
, xorig
, what
)
492 ASRTSYNTAX (scm_ilength (xorig
) >= 1, scm_s_expression
);
494 /* Don't add another ISYM if one is present already. */
495 if (SCM_ISYMP (SCM_CAR (xorig
)))
498 /* Retain possible doc string. */
499 if (SCM_IMP (SCM_CAR(xorig
)) || SCM_NCONSP (SCM_CAR (xorig
)))
501 if (SCM_NNULLP (SCM_CDR(xorig
)))
502 return scm_cons (SCM_CAR (xorig
),
503 scm_m_body (op
, SCM_CDR(xorig
), what
));
507 return scm_cons2 (op
, SCM_CAR (xorig
), SCM_CDR(xorig
));
510 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
511 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
514 scm_m_quote (xorig
, env
)
518 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
520 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
521 xorig
, scm_s_expression
, s_quote
);
522 return scm_cons (SCM_IM_QUOTE
, x
);
527 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
528 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
531 scm_m_begin (xorig
, env
)
535 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
536 xorig
, scm_s_expression
, s_begin
);
537 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
540 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
541 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
544 scm_m_if (xorig
, env
)
548 int len
= scm_ilength (SCM_CDR (xorig
));
549 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
550 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
554 /* Will go into the RnRS module when Guile is factorized.
555 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
556 const char scm_s_set_x
[] = "set!";
557 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
560 scm_m_set_x (xorig
, env
)
564 SCM x
= SCM_CDR (xorig
);
565 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
566 SCM_ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
567 xorig
, scm_s_variable
, scm_s_set_x
);
568 return scm_cons (SCM_IM_SET_X
, x
);
575 scm_m_vref (xorig
, env
)
579 SCM x
= SCM_CDR (xorig
);
580 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
581 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
583 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
584 scm_misc_error (NULL
,
586 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
588 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
589 xorig
, scm_s_variable
, s_vref
);
590 return scm_cons (IM_VREF
, x
);
596 scm_m_vset (xorig
, env
)
600 SCM x
= SCM_CDR (xorig
);
601 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
602 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
603 || UDSCM_VARIABLEP (SCM_CAR (x
))),
604 xorig
, scm_s_variable
, s_vset
);
605 return scm_cons (IM_VSET
, x
);
610 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
611 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
614 scm_m_and (xorig
, env
)
618 int len
= scm_ilength (SCM_CDR (xorig
));
619 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
621 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
626 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
627 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
630 scm_m_or (xorig
, env
)
634 int len
= scm_ilength (SCM_CDR (xorig
));
635 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
637 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
643 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
644 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
647 scm_m_case (xorig
, env
)
651 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
652 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
653 while (SCM_NIMP (x
= SCM_CDR (x
)))
656 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
657 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
658 || scm_sym_else
== SCM_CAR (proc
),
659 xorig
, scm_s_clauses
, s_case
);
661 return scm_cons (SCM_IM_CASE
, cdrx
);
665 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
666 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
670 scm_m_cond (xorig
, env
)
674 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
675 int len
= scm_ilength (x
);
676 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
680 len
= scm_ilength (arg1
);
681 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
682 if (scm_sym_else
== SCM_CAR (arg1
))
684 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
685 xorig
, "bad ELSE clause", s_cond
);
686 SCM_SETCAR (arg1
, SCM_BOOL_T
);
688 if (len
>= 2 && scm_sym_arrow
== SCM_CAR (SCM_CDR (arg1
)))
689 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
690 xorig
, "bad recipient", s_cond
);
693 return scm_cons (SCM_IM_COND
, cdrx
);
696 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
697 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
700 scm_m_lambda (xorig
, env
)
704 SCM proc
, x
= SCM_CDR (xorig
);
705 if (scm_ilength (x
) < 2)
708 if (SCM_NULLP (proc
))
710 if (SCM_IM_LET
== proc
) /* named let */
714 if (SCM_SYMBOLP (proc
))
716 if (SCM_NCONSP (proc
))
718 while (SCM_NIMP (proc
))
720 if (SCM_NCONSP (proc
))
722 if (!SCM_SYMBOLP (proc
))
727 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
729 proc
= SCM_CDR (proc
);
731 if (SCM_NNULLP (proc
))
734 scm_wta (xorig
, scm_s_formals
, s_lambda
);
738 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
739 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
742 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
743 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
747 scm_m_letstar (xorig
, env
)
751 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
752 int len
= scm_ilength (x
);
753 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
755 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
756 while (SCM_NIMP (proc
))
758 arg1
= SCM_CAR (proc
);
759 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
760 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
761 xorig
, scm_s_variable
, s_letstar
);
762 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
763 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
764 proc
= SCM_CDR (proc
);
766 x
= scm_cons (vars
, SCM_CDR (x
));
768 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
769 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
772 /* DO gets the most radically altered syntax
773 (do ((<var1> <init1> <step1>)
779 (do_mem (varn ... var2 var1)
780 (<init1> <init2> ... <initn>)
783 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
786 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
787 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
790 scm_m_do (xorig
, env
)
794 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
795 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
796 SCM
*initloc
= &inits
, *steploc
= &steps
;
797 int len
= scm_ilength (x
);
798 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
800 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
801 while (SCM_NIMP(proc
))
803 arg1
= SCM_CAR (proc
);
804 len
= scm_ilength (arg1
);
805 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
806 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
807 xorig
, scm_s_variable
, "do");
808 /* vars reversed here, inits and steps reversed at evaluation */
809 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
810 arg1
= SCM_CDR (arg1
);
811 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
812 initloc
= SCM_CDRLOC (*initloc
);
813 arg1
= SCM_CDR (arg1
);
814 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
815 steploc
= SCM_CDRLOC (*steploc
);
816 proc
= SCM_CDR (proc
);
819 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
820 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
821 x
= scm_cons2 (vars
, inits
, x
);
822 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
823 return scm_cons (SCM_IM_DO
, x
);
826 /* evalcar is small version of inline EVALCAR when we don't care about
829 #define evalcar scm_eval_car
832 static SCM iqq
SCM_P ((SCM form
, SCM env
, int depth
));
834 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
835 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
838 scm_m_quasiquote (xorig
, env
)
842 SCM x
= SCM_CDR (xorig
);
843 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
844 return iqq (SCM_CAR (x
), env
, 1);
849 iqq (form
, env
, depth
)
858 if (SCM_VECTORP (form
))
860 long i
= SCM_LENGTH (form
);
861 SCM
*data
= SCM_VELTS (form
);
864 tmp
= scm_cons (data
[i
], tmp
);
865 return scm_vector (iqq (tmp
, env
, depth
));
867 if (SCM_NCONSP(form
))
869 tmp
= SCM_CAR (form
);
870 if (scm_sym_quasiquote
== tmp
)
875 if (scm_sym_unquote
== tmp
)
879 form
= SCM_CDR (form
);
880 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
881 form
, SCM_ARG1
, s_quasiquote
);
883 return evalcar (form
, env
);
884 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
886 if (SCM_NIMP (tmp
) && (scm_sym_uq_splicing
== SCM_CAR (tmp
)))
890 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
892 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
895 /* Here are acros which return values rather than code. */
897 SCM_SYNTAX(s_delay
, "delay", scm_makacro
, scm_m_delay
);
900 scm_m_delay (xorig
, env
)
904 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
905 xorig
= SCM_CDR (xorig
);
906 return scm_makprom (scm_closure (scm_cons2 (SCM_EOL
, SCM_CAR (xorig
),
912 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
913 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
916 scm_m_define (x
, env
)
922 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
923 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
926 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
927 { /* nested define syntax */
928 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
929 proc
= SCM_CAR (proc
);
931 SCM_ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
),
932 arg1
, scm_s_variable
, s_define
);
933 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
934 if (SCM_TOP_LEVEL (env
))
936 x
= evalcar (x
, env
);
937 #ifdef DEBUG_EXTENSIONS
938 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
942 if (SCM_CLOSUREP (arg1
)
943 /* Only the first definition determines the name. */
944 && scm_procedure_property (arg1
, scm_sym_name
) == SCM_BOOL_F
)
945 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
946 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
947 && SCM_CDR (arg1
) != arg1
)
949 arg1
= SCM_CDR (arg1
);
954 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
957 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
958 && (SCM_CDR (arg1
) != x
))
959 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
962 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
963 scm_warn ("redefining ", SCM_CHARS (proc
));
965 SCM_SETCDR (arg1
, x
);
967 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
969 return SCM_UNSPECIFIED
;
972 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
978 scm_m_letrec1 (op
, imm
, xorig
, env
)
984 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
985 char *what
= SCM_CHARS (SCM_CAR (xorig
));
986 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
987 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
990 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
993 /* vars scm_list reversed here, inits reversed at evaluation */
994 arg1
= SCM_CAR (proc
);
995 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
996 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
998 vars
= scm_cons (SCM_CAR (arg1
), vars
);
999 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1000 initloc
= SCM_CDRLOC (*initloc
);
1002 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1004 return scm_cons2 (op
, vars
,
1005 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
1008 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
1009 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1012 scm_m_letrec (xorig
, env
)
1016 SCM x
= SCM_CDR (xorig
);
1017 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
1019 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
1020 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
1021 scm_m_body (SCM_IM_LETREC
,
1026 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
1029 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
1030 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1033 scm_m_let (xorig
, env
)
1037 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
1038 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
1039 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
1041 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1043 if (SCM_NULLP (proc
)
1044 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
1045 && SCM_NIMP (SCM_CAR (proc
))
1046 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
1048 /* null or single binding, let* is faster */
1049 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
1050 scm_m_body (SCM_IM_LET
,
1056 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
1057 if (SCM_CONSP (proc
))
1059 /* plain let, proc is <bindings> */
1060 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1063 if (!SCM_SYMBOLP (proc
))
1064 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1065 name
= proc
; /* named let, build equiv letrec */
1067 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1068 proc
= SCM_CAR (x
); /* bindings list */
1069 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1070 while (SCM_NIMP (proc
))
1071 { /* vars and inits both in order */
1072 arg1
= SCM_CAR (proc
);
1073 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1074 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
1075 xorig
, scm_s_variable
, s_let
);
1076 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1077 varloc
= SCM_CDRLOC (*varloc
);
1078 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1079 initloc
= SCM_CDRLOC (*initloc
);
1080 proc
= SCM_CDR (proc
);
1083 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1084 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1085 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1087 scm_acons (name
, inits
, SCM_EOL
));
1088 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1092 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1093 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1094 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1097 scm_m_apply (xorig
, env
)
1101 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1102 xorig
, scm_s_expression
, s_atapply
);
1103 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1107 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1108 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1112 scm_m_cont (xorig
, env
)
1116 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1117 xorig
, scm_s_expression
, s_atcall_cc
);
1118 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1121 /* Multi-language support */
1126 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1129 scm_m_nil_cond (SCM xorig
, SCM env
)
1131 int len
= scm_ilength (SCM_CDR (xorig
));
1132 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1133 scm_s_expression
, "nil-cond");
1134 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1137 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1140 scm_m_nil_ify (SCM xorig
, SCM env
)
1142 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1143 xorig
, scm_s_expression
, "nil-ify");
1144 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1147 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1150 scm_m_t_ify (SCM xorig
, SCM env
)
1152 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1153 xorig
, scm_s_expression
, "t-ify");
1154 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1157 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1160 scm_m_0_cond (SCM xorig
, SCM env
)
1162 int len
= scm_ilength (SCM_CDR (xorig
));
1163 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1164 scm_s_expression
, "0-cond");
1165 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1168 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1171 scm_m_0_ify (SCM xorig
, SCM env
)
1173 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1174 xorig
, scm_s_expression
, "0-ify");
1175 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1178 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1181 scm_m_1_ify (SCM xorig
, SCM env
)
1183 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1184 xorig
, scm_s_expression
, "1-ify");
1185 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1188 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1191 scm_m_atfop (SCM xorig
, SCM env
)
1193 SCM x
= SCM_CDR (xorig
), vcell
;
1194 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1195 vcell
= scm_symbol_fref (SCM_CAR (x
));
1196 SCM_ASSYNT (SCM_NIMP (vcell
) && SCM_CONSP (vcell
), x
,
1197 "Symbol's function definition is void", NULL
);
1198 SCM_SETCAR (x
, vcell
+ 1);
1202 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1205 scm_m_atbind (SCM xorig
, SCM env
)
1207 SCM x
= SCM_CDR (xorig
);
1208 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1214 while (SCM_NIMP (SCM_CDR (env
)))
1215 env
= SCM_CDR (env
);
1216 env
= SCM_CAR (env
);
1217 if (SCM_CONSP (env
))
1222 while (SCM_NIMP (x
))
1224 SCM_SETCAR (x
, scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
) + 1);
1227 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1231 scm_m_expand_body (SCM xorig
, SCM env
)
1233 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1234 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1236 while (SCM_NIMP (x
))
1239 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1241 if (SCM_IMP (SCM_CAR (form
)))
1243 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1246 form
= scm_macroexp (scm_cons_source (form
,
1251 if (SCM_IM_DEFINE
== SCM_CAR (form
))
1253 defs
= scm_cons (SCM_CDR (form
), defs
);
1256 else if (SCM_NIMP(defs
))
1260 else if (SCM_IM_BEGIN
== SCM_CAR (form
))
1262 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1266 x
= scm_cons (form
, SCM_CDR(x
));
1271 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1272 if (SCM_NIMP (defs
))
1274 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1276 scm_cons2 (scm_sym_define
, defs
, x
),
1282 SCM_SETCAR (xorig
, SCM_CAR (x
));
1283 SCM_SETCDR (xorig
, SCM_CDR (x
));
1290 scm_macroexp (SCM x
, SCM env
)
1294 /* Don't bother to produce error messages here. We get them when we
1295 eventually execute the code for real. */
1298 if (SCM_IMP (SCM_CAR (x
)) || !SCM_SYMBOLP (SCM_CAR (x
)))
1303 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1304 if (proc_ptr
== NULL
)
1306 /* We have lost the race. */
1312 proc
= *scm_lookupcar (x
, env
, 0);
1315 /* Only handle memoizing macros. `Acros' and `macros' are really
1316 special forms and should not be evaluated here. */
1319 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1320 || (int) (SCM_CAR (proc
) >> 16) != 2)
1324 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1326 if (scm_ilength (res
) <= 0)
1327 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1330 SCM_SETCAR (x
, SCM_CAR (res
));
1331 SCM_SETCDR (x
, SCM_CDR (res
));
1337 /* scm_unmemocopy takes a memoized expression together with its
1338 * environment and rewrites it to its original form. Thus, it is the
1339 * inversion of the rewrite rules above. The procedure is not
1340 * optimized for speed. It's used in scm_iprin1 when printing the
1341 * code of a closure, in scm_procedure_source, in display_frame when
1342 * generating the source for a stackframe in a backtrace, and in
1343 * display_expression.
1346 /* We should introduce an anti-macro interface so that it is possible
1347 * to plug in transformers in both directions from other compilation
1348 * units. unmemocopy could then dispatch to anti-macro transformers.
1349 * (Those transformers could perhaps be written in slightly more
1350 * readable style... :)
1353 static SCM unmemocopy
SCM_P ((SCM x
, SCM env
));
1361 #ifdef DEBUG_EXTENSIONS
1364 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1366 #ifdef DEBUG_EXTENSIONS
1367 p
= scm_whash_lookup (scm_source_whash
, x
);
1369 switch (SCM_TYP7 (x
))
1371 case (127 & SCM_IM_AND
):
1372 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1374 case (127 & SCM_IM_BEGIN
):
1375 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1377 case (127 & SCM_IM_CASE
):
1378 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1380 case (127 & SCM_IM_COND
):
1381 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1383 case (127 & SCM_IM_DO
):
1384 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1386 case (127 & SCM_IM_IF
):
1387 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1389 case (127 & SCM_IM_LET
):
1390 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1392 case (127 & SCM_IM_LETREC
):
1395 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1399 f
= v
= SCM_CAR (x
);
1401 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1403 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1404 SCM_CAR (ls
) == scm_sym_letrec
? z
: env
));
1407 s
= SCM_CAR (ls
) == scm_sym_do
1408 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1410 /* build transformed binding list */
1414 z
= scm_acons (SCM_CAR (v
),
1415 scm_cons (SCM_CAR (e
),
1416 SCM_CAR (s
) == SCM_CAR (v
)
1418 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1424 while (SCM_NIMP (v
));
1425 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1427 if (SCM_CAR (ls
) == scm_sym_do
)
1431 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1434 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1435 /* body forms are now to be found in SCM_CDR (x)
1436 (this is how *real* code look like! :) */
1440 case (127 & SCM_IM_LETSTAR
):
1448 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1451 y
= z
= scm_acons (SCM_CAR (b
),
1453 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1455 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1456 b
= SCM_CDR (SCM_CDR (b
));
1459 SCM_SETCDR (y
, SCM_EOL
);
1460 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1465 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1467 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1470 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1471 b
= SCM_CDR (SCM_CDR (b
));
1473 while (SCM_NIMP (b
));
1474 SCM_SETCDR (z
, SCM_EOL
);
1476 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1479 case (127 & SCM_IM_OR
):
1480 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1482 case (127 & SCM_IM_LAMBDA
):
1484 ls
= scm_cons (scm_sym_lambda
,
1485 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1486 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1488 case (127 & SCM_IM_QUOTE
):
1489 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1491 case (127 & SCM_IM_SET_X
):
1492 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1494 case (127 & SCM_IM_DEFINE
):
1498 ls
= scm_cons (scm_sym_define
,
1499 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1500 if (SCM_NNULLP (env
))
1501 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1504 case (127 & SCM_MAKISYM (0)):
1508 switch (SCM_ISYMNUM (z
))
1510 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1511 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1513 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1514 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1517 /* appease the Sun compiler god: */ ;
1521 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1526 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1528 if (SCM_IMP (SCM_CAR (x
)) && SCM_ISYMP (SCM_CAR (x
)))
1529 /* skip body markers */
1531 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1537 #ifdef DEBUG_EXTENSIONS
1538 if (SCM_NFALSEP (p
))
1539 scm_whash_insert (scm_source_whash
, ls
, p
);
1546 scm_unmemocopy (x
, env
)
1550 if (SCM_NNULLP (env
))
1551 /* Make a copy of the lowest frame to protect it from
1552 modifications by SCM_IM_DEFINE */
1553 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1555 return unmemocopy (x
, env
);
1558 #ifndef SCM_RECKLESS
1561 scm_badargsp (formals
, args
)
1565 while (SCM_NIMP (formals
))
1567 if (SCM_NCONSP (formals
))
1571 formals
= SCM_CDR (formals
);
1572 args
= SCM_CDR (args
);
1574 return SCM_NNULLP (args
) ? 1 : 0;
1581 scm_eval_args (l
, env
, proc
)
1586 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1587 while (SCM_NIMP (l
))
1592 else if (SCM_CONSP (l
))
1594 if (SCM_IMP (SCM_CAR (l
)))
1595 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1597 res
= EVALCELLCAR (l
, env
);
1599 else if (SCM_TYP3 (l
) == 1)
1601 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1602 res
= SCM_CAR (l
); /* struct planted in code */
1607 res
= EVALCAR (l
, env
);
1609 *lloc
= scm_cons (res
, SCM_EOL
);
1610 lloc
= SCM_CDRLOC (*lloc
);
1617 scm_wrong_num_args (proc
);
1624 scm_eval_body (SCM code
, SCM env
)
1629 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1631 if (SCM_IMP (SCM_CAR (code
)))
1633 if (SCM_ISYMP (SCM_CAR (code
)))
1635 code
= scm_m_expand_body (code
, env
);
1640 SCM_XEVAL (SCM_CAR (code
), env
);
1643 return SCM_XEVALCAR (code
, env
);
1650 /* SECTION: This code is specific for the debugging support. One
1651 * branch is read when DEVAL isn't defined, the other when DEVAL is
1657 #define SCM_APPLY scm_apply
1658 #define PREP_APPLY(proc, args)
1660 #define RETURN(x) return x;
1661 #ifdef STACK_CHECKING
1662 #ifndef NO_CEVAL_STACK_CHECKING
1663 #define EVAL_STACK_CHECKING
1670 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1672 #define SCM_APPLY scm_dapply
1674 #define PREP_APPLY(p, l) \
1675 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1677 #define ENTER_APPLY \
1679 SCM_SET_ARGSREADY (debug);\
1680 if (CHECK_APPLY && SCM_TRAPS_P)\
1681 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1683 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1684 SCM_SET_TRACED_FRAME (debug); \
1685 if (SCM_CHEAPTRAPS_P)\
1687 tmp = scm_make_debugobj (&debug);\
1688 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1692 scm_make_cont (&tmp);\
1693 if (!setjmp (SCM_JMPBUF (tmp)))\
1694 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1699 #define RETURN(e) {proc = (e); goto exit;}
1700 #ifdef STACK_CHECKING
1701 #ifndef EVAL_STACK_CHECKING
1702 #define EVAL_STACK_CHECKING
1706 /* scm_ceval_ptr points to the currently selected evaluator.
1707 * *fixme*: Although efficiency is important here, this state variable
1708 * should probably not be a global. It should be related to the
1713 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1715 /* scm_last_debug_frame contains a pointer to the last debugging
1716 * information stack frame. It is accessed very often from the
1717 * debugging evaluator, so it should probably not be indirectly
1718 * addressed. Better to save and restore it from the current root at
1723 scm_debug_frame
*scm_last_debug_frame
;
1726 /* scm_debug_eframe_size is the number of slots available for pseudo
1727 * stack frames at each real stack frame.
1730 int scm_debug_eframe_size
;
1732 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1736 scm_option scm_eval_opts
[] = {
1737 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1740 scm_option scm_debug_opts
[] = {
1741 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1742 "*Flyweight representation of the stack at traps." },
1743 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1744 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1745 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1746 "Record procedure names at definition." },
1747 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1748 "Display backtrace in anti-chronological order." },
1749 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1750 { SCM_OPTION_INTEGER
, "frames", 3,
1751 "Maximum number of tail-recursive frames in backtrace." },
1752 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1753 "Maximal number of stored backtrace frames." },
1754 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1755 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1756 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1757 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1760 scm_option scm_evaluator_trap_table
[] = {
1761 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1762 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1763 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1764 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1767 SCM_PROC (s_eval_options_interface
, "eval-options-interface", 0, 1, 0, scm_eval_options_interface
);
1770 scm_eval_options_interface (SCM setting
)
1774 ans
= scm_options (setting
,
1777 s_eval_options_interface
);
1778 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1783 SCM_PROC (s_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps
);
1786 scm_evaluator_traps (setting
)
1791 ans
= scm_options (setting
,
1792 scm_evaluator_trap_table
,
1793 SCM_N_EVALUATOR_TRAPS
,
1795 SCM_RESET_DEBUG_MODE
;
1801 scm_deval_args (l
, env
, proc
, lloc
)
1802 SCM l
, env
, proc
, *lloc
;
1804 SCM
*results
= lloc
, res
;
1805 while (SCM_NIMP (l
))
1810 else if (SCM_CONSP (l
))
1812 if (SCM_IMP (SCM_CAR (l
)))
1813 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1815 res
= EVALCELLCAR (l
, env
);
1817 else if (SCM_TYP3 (l
) == 1)
1819 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1820 res
= SCM_CAR (l
); /* struct planted in code */
1825 res
= EVALCAR (l
, env
);
1827 *lloc
= scm_cons (res
, SCM_EOL
);
1828 lloc
= SCM_CDRLOC (*lloc
);
1835 scm_wrong_num_args (proc
);
1844 /* SECTION: Some local definitions for the evaluator.
1849 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1851 #define CHECK_EQVISH(A,B) ((A) == (B))
1855 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1857 /* SECTION: This is the evaluator. Like any real monster, it has
1858 * three heads. This code is compiled twice.
1890 scm_debug_frame debug
;
1891 scm_debug_info
*debug_info_end
;
1892 debug
.prev
= scm_last_debug_frame
;
1893 debug
.status
= scm_debug_eframe_size
;
1895 * The debug.vect contains twice as much scm_debug_info frames as the
1896 * user has specified with (debug-set! frames <n>).
1898 * Even frames are eval frames, odd frames are apply frames.
1900 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1901 * sizeof (debug
.vect
[0]));
1902 debug
.info
= debug
.vect
;
1903 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1904 scm_last_debug_frame
= &debug
;
1906 #ifdef EVAL_STACK_CHECKING
1907 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1908 && scm_stack_checking_enabled_p
)
1911 debug
.info
->e
.exp
= x
;
1912 debug
.info
->e
.env
= env
;
1914 scm_report_stack_overflow ();
1921 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1924 SCM_CLEAR_ARGSREADY (debug
);
1925 if (SCM_OVERFLOWP (debug
))
1928 * In theory, this should be the only place where it is necessary to
1929 * check for space in debug.vect since both eval frames and
1930 * available space are even.
1932 * For this to be the case, however, it is necessary that primitive
1933 * special forms which jump back to `loop', `begin' or some similar
1934 * label call PREP_APPLY. A convenient way to do this is to jump to
1935 * `loopnoap' or `cdrxnoap'.
1937 else if (++debug
.info
>= debug_info_end
)
1939 SCM_SET_OVERFLOW (debug
);
1943 debug
.info
->e
.exp
= x
;
1944 debug
.info
->e
.env
= env
;
1945 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1946 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1948 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1949 SCM_SET_TAILREC (debug
);
1950 if (SCM_CHEAPTRAPS_P
)
1951 t
.arg1
= scm_make_debugobj (&debug
);
1954 scm_make_cont (&t
.arg1
);
1955 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1957 x
= SCM_THROW_VALUE (t
.arg1
);
1963 /* This gives the possibility for the debugger to
1964 modify the source expression before evaluation. */
1968 scm_ithrow (scm_sym_enter_frame
,
1969 scm_cons2 (t
.arg1
, tail
,
1970 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1974 #if defined (USE_THREADS) || defined (DEVAL)
1978 switch (SCM_TYP7 (x
))
1980 case scm_tcs_symbols
:
1981 /* Only happens when called at top level.
1983 x
= scm_cons (x
, SCM_UNDEFINED
);
1986 case (127 & SCM_IM_AND
):
1989 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1990 if (SCM_FALSEP (EVALCAR (x
, env
)))
1992 RETURN (SCM_BOOL_F
);
1996 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1999 case (127 & SCM_IM_BEGIN
):
2001 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2007 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2009 if (SCM_IMP (SCM_CAR (x
)))
2011 if (SCM_ISYMP (SCM_CAR (x
)))
2013 x
= scm_m_expand_body (x
, env
);
2018 SCM_CEVAL (SCM_CAR (x
), env
);
2022 carloop
: /* scm_eval car of last form in list */
2023 if (SCM_NCELLP (SCM_CAR (x
)))
2026 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
2029 if (SCM_SYMBOLP (SCM_CAR (x
)))
2032 RETURN (*scm_lookupcar (x
, env
, 1))
2036 goto loop
; /* tail recurse */
2039 case (127 & SCM_IM_CASE
):
2041 t
.arg1
= EVALCAR (x
, env
);
2042 while (SCM_NIMP (x
= SCM_CDR (x
)))
2045 if (scm_sym_else
== SCM_CAR (proc
))
2048 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2051 proc
= SCM_CAR (proc
);
2052 while (SCM_NIMP (proc
))
2054 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2056 x
= SCM_CDR (SCM_CAR (x
));
2057 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2060 proc
= SCM_CDR (proc
);
2063 RETURN (SCM_UNSPECIFIED
)
2066 case (127 & SCM_IM_COND
):
2067 while (SCM_NIMP (x
= SCM_CDR (x
)))
2070 t
.arg1
= EVALCAR (proc
, env
);
2071 if (SCM_NFALSEP (t
.arg1
))
2078 if (scm_sym_arrow
!= SCM_CAR (x
))
2080 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2084 proc
= EVALCAR (proc
, env
);
2085 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2086 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2091 RETURN (SCM_UNSPECIFIED
)
2094 case (127 & SCM_IM_DO
):
2096 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2097 t
.arg1
= SCM_EOL
; /* values */
2098 while (SCM_NIMP (proc
))
2100 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2101 proc
= SCM_CDR (proc
);
2103 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2104 x
= SCM_CDR (SCM_CDR (x
));
2105 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2107 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2109 t
.arg1
= SCM_CAR (proc
); /* body */
2110 SIDEVAL (t
.arg1
, env
);
2112 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2114 proc
= SCM_CDR (proc
))
2115 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2116 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2120 RETURN (SCM_UNSPECIFIED
);
2121 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2125 case (127 & SCM_IM_IF
):
2127 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2129 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2131 RETURN (SCM_UNSPECIFIED
);
2133 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2137 case (127 & SCM_IM_LET
):
2139 proc
= SCM_CAR (SCM_CDR (x
));
2143 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2145 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2146 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2151 case (127 & SCM_IM_LETREC
):
2153 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2159 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2161 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2162 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2166 case (127 & SCM_IM_LETSTAR
):
2171 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2176 t
.arg1
= SCM_CAR (proc
);
2177 proc
= SCM_CDR (proc
);
2178 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2180 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2183 case (127 & SCM_IM_OR
):
2186 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2188 x
= EVALCAR (x
, env
);
2189 if (SCM_NFALSEP (x
))
2195 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2199 case (127 & SCM_IM_LAMBDA
):
2200 RETURN (scm_closure (SCM_CDR (x
), env
));
2203 case (127 & SCM_IM_QUOTE
):
2204 RETURN (SCM_CAR (SCM_CDR (x
)));
2207 case (127 & SCM_IM_SET_X
):
2210 switch (7 & (int) proc
)
2213 t
.lloc
= scm_lookupcar (x
, env
, 1);
2216 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2218 #ifdef MEMOIZE_LOCALS
2220 t
.lloc
= scm_ilookup (proc
, env
);
2225 *t
.lloc
= EVALCAR (x
, env
);
2229 RETURN (SCM_UNSPECIFIED
);
2233 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
2234 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2236 /* new syntactic forms go here. */
2237 case (127 & SCM_MAKISYM (0)):
2239 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2240 switch SCM_ISYMNUM (proc
)
2243 case (SCM_ISYMNUM (IM_VREF
)):
2246 var
= SCM_CAR (SCM_CDR (x
));
2247 RETURN (SCM_CDR(var
));
2249 case (SCM_ISYMNUM (IM_VSET
)):
2250 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2251 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2252 RETURN (SCM_UNSPECIFIED
)
2255 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2257 proc
= EVALCAR (proc
, env
);
2258 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2259 if (SCM_CLOSUREP (proc
))
2262 PREP_APPLY (proc
, SCM_EOL
);
2263 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2264 t
.arg1
= EVALCAR (t
.arg1
, env
);
2266 debug
.info
->a
.args
= t
.arg1
;
2268 #ifndef SCM_RECKLESS
2269 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2273 /* Copy argument list */
2274 if (SCM_IMP (t
.arg1
))
2278 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2279 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2280 && SCM_CONSP (t
.arg1
))
2282 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2286 SCM_SETCDR (tl
, t
.arg1
);
2289 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2290 x
= SCM_CODE (proc
);
2296 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2297 scm_make_cont (&t
.arg1
);
2298 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2301 val
= SCM_THROW_VALUE (t
.arg1
);
2305 proc
= evalcar (proc
, env
);
2306 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2307 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2311 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2312 proc
= SCM_CADR (x
); /* unevaluated operands */
2313 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2315 arg2
= *scm_ilookup (proc
, env
);
2316 else if (SCM_NCONSP (proc
))
2318 if (SCM_NCELLP (proc
))
2319 arg2
= SCM_GLOC_VAL (proc
);
2321 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2325 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2326 t
.lloc
= SCM_CDRLOC (arg2
);
2327 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2329 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2330 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2335 proc
= scm_mcache_compute_cmethod (x
, arg2
);
2336 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (proc
)),
2338 SCM_CMETHOD_ENV (proc
));
2339 x
= SCM_CMETHOD_CODE (proc
);
2342 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2344 t
.arg1
= EVALCAR (x
, env
);
2345 RETURN (SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CADR (x
))]);
2347 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2349 t
.arg1
= EVALCAR (x
, env
);
2352 SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CAR (x
))]
2353 = EVALCAR (proc
, env
);
2354 RETURN (SCM_UNSPECIFIED
);
2356 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2358 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2360 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2361 || t
.arg1
== scm_nil
))
2363 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2365 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2371 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2374 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2376 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2380 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2382 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_t
: scm_nil
)
2384 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2386 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2388 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2389 || t
.arg1
== SCM_INUM0
))
2391 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2393 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2399 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2402 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2404 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2408 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2410 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2414 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2417 t
.arg1
= SCM_CAR (x
);
2418 arg2
= SCM_CDAR (env
);
2419 while (SCM_NIMP (arg2
))
2421 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2422 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2423 SCM_SETCAR (arg2
, proc
);
2424 t
.arg1
= SCM_CDR (t
.arg1
);
2425 arg2
= SCM_CDR (arg2
);
2427 t
.arg1
= SCM_CAR (x
);
2428 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2430 arg2
= x
= SCM_CDR (x
);
2431 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2433 SIDEVAL (SCM_CAR (x
), env
);
2436 proc
= EVALCAR (x
, env
);
2438 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2439 arg2
= SCM_CDAR (env
);
2440 while (SCM_NIMP (arg2
))
2442 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2443 t
.arg1
= SCM_CDR (t
.arg1
);
2444 arg2
= SCM_CDR (arg2
);
2456 /* scm_everr (x, env,...) */
2457 scm_misc_error (NULL
,
2458 "Wrong type to apply: %S",
2459 scm_listify (proc
, SCM_UNDEFINED
));
2460 case scm_tc7_vector
:
2463 case scm_tc7_byvect
:
2471 case scm_tc7_llvect
:
2473 case scm_tc7_string
:
2474 case scm_tc7_substring
:
2476 case scm_tcs_closures
:
2484 #ifdef MEMOIZE_LOCALS
2485 case (127 & SCM_ILOC00
):
2486 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2487 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2488 #ifndef SCM_RECKLESS
2494 #endif /* ifdef MEMOIZE_LOCALS */
2497 case scm_tcs_cons_gloc
:
2498 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2500 /* This is a struct implanted in the code, not a gloc. */
2502 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2503 #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 ((int) (SCM_CAR (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
));
2638 proc
= SCM_CCLO_SUBR (proc
);
2640 debug
.info
->a
.proc
= proc
;
2641 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2646 proc
= SCM_PROCEDURE (proc
);
2648 debug
.info
->a
.proc
= proc
;
2651 case scm_tcs_closures
:
2652 x
= SCM_CODE (proc
);
2653 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2655 case scm_tcs_cons_gloc
:
2656 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2658 x
= SCM_ENTITY_PROCEDURE (proc
);
2662 else if (!SCM_I_OPERATORP (proc
))
2667 proc
= (SCM_I_ENTITYP (proc
)
2668 ? SCM_ENTITY_PROCEDURE (proc
)
2669 : SCM_OPERATOR_PROCEDURE (proc
));
2671 debug
.info
->a
.proc
= proc
;
2672 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2674 if (SCM_NIMP (proc
))
2679 case scm_tc7_contin
:
2680 case scm_tc7_subr_1
:
2681 case scm_tc7_subr_2
:
2682 case scm_tc7_subr_2o
:
2684 case scm_tc7_subr_3
:
2685 case scm_tc7_lsubr_2
:
2689 /* scm_everr (x, env,...) */
2690 scm_wrong_num_args (proc
);
2692 /* handle macros here */
2697 /* must handle macros by here */
2702 else if (SCM_CONSP (x
))
2704 if (SCM_IMP (SCM_CAR (x
)))
2705 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2707 t
.arg1
= EVALCELLCAR (x
, env
);
2709 else if (SCM_TYP3 (x
) == 1)
2711 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2712 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2717 t
.arg1
= EVALCAR (x
, env
);
2720 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2727 switch (SCM_TYP7 (proc
))
2728 { /* have one argument in t.arg1 */
2729 case scm_tc7_subr_2o
:
2730 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2731 case scm_tc7_subr_1
:
2732 case scm_tc7_subr_1o
:
2733 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2736 if (SCM_SUBRF (proc
))
2738 if (SCM_INUMP (t
.arg1
))
2740 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2743 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2744 if (SCM_REALP (t
.arg1
))
2746 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2749 if (SCM_BIGP (t
.arg1
))
2751 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2755 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2756 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2759 proc
= (SCM
) SCM_SNAME (proc
);
2761 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2762 while ('c' != *--chrs
)
2764 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2765 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2766 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2770 case scm_tc7_rpsubr
:
2771 RETURN (SCM_BOOL_T
);
2773 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2776 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2778 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2784 proc
= SCM_CCLO_SUBR (proc
);
2786 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2787 debug
.info
->a
.proc
= proc
;
2792 proc
= SCM_PROCEDURE (proc
);
2794 debug
.info
->a
.proc
= proc
;
2797 case scm_tcs_closures
:
2799 x
= SCM_CODE (proc
);
2801 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2803 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2806 case scm_tc7_contin
:
2807 scm_call_continuation (proc
, t
.arg1
);
2808 case scm_tcs_cons_gloc
:
2809 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2811 x
= SCM_ENTITY_PROCEDURE (proc
);
2813 arg2
= debug
.info
->a
.args
;
2815 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2819 else if (!SCM_I_OPERATORP (proc
))
2825 proc
= (SCM_I_ENTITYP (proc
)
2826 ? SCM_ENTITY_PROCEDURE (proc
)
2827 : SCM_OPERATOR_PROCEDURE (proc
));
2829 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2830 debug
.info
->a
.proc
= proc
;
2832 if (SCM_NIMP (proc
))
2837 case scm_tc7_subr_2
:
2838 case scm_tc7_subr_0
:
2839 case scm_tc7_subr_3
:
2840 case scm_tc7_lsubr_2
:
2849 else if (SCM_CONSP (x
))
2851 if (SCM_IMP (SCM_CAR (x
)))
2852 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2854 arg2
= EVALCELLCAR (x
, env
);
2856 else if (SCM_TYP3 (x
) == 1)
2858 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2859 arg2
= SCM_CAR (x
); /* struct planted in code */
2864 arg2
= EVALCAR (x
, env
);
2866 { /* have two or more arguments */
2868 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2871 if (SCM_NULLP (x
)) {
2876 switch (SCM_TYP7 (proc
))
2877 { /* have two arguments */
2878 case scm_tc7_subr_2
:
2879 case scm_tc7_subr_2o
:
2880 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2883 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2885 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2887 case scm_tc7_lsubr_2
:
2888 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2889 case scm_tc7_rpsubr
:
2891 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2896 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2897 scm_cons (proc
, debug
.info
->a
.args
),
2900 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2901 scm_cons2 (proc
, t
.arg1
,
2908 /* case scm_tc7_cclo:
2909 x = scm_cons(arg2, scm_eval_args(x, env));
2912 proc = SCM_CCLO_SUBR(proc);
2916 proc
= SCM_PROCEDURE (proc
);
2918 debug
.info
->a
.proc
= proc
;
2921 case scm_tcs_cons_gloc
:
2922 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2924 x
= SCM_ENTITY_PROCEDURE (proc
);
2926 arg2
= debug
.info
->a
.args
;
2928 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2932 else if (!SCM_I_OPERATORP (proc
))
2938 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2939 ? SCM_ENTITY_PROCEDURE (proc
)
2940 : SCM_OPERATOR_PROCEDURE (proc
),
2941 scm_cons (proc
, debug
.info
->a
.args
),
2944 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2945 ? SCM_ENTITY_PROCEDURE (proc
)
2946 : SCM_OPERATOR_PROCEDURE (proc
),
2947 scm_cons2 (proc
, t
.arg1
,
2955 case scm_tc7_subr_0
:
2957 case scm_tc7_subr_1o
:
2958 case scm_tc7_subr_1
:
2959 case scm_tc7_subr_3
:
2960 case scm_tc7_contin
:
2964 case scm_tcs_closures
:
2967 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2971 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2972 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2974 x
= SCM_CODE (proc
);
2979 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2983 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2984 scm_deval_args (x
, env
, proc
,
2985 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2989 switch (SCM_TYP7 (proc
))
2990 { /* have 3 or more arguments */
2992 case scm_tc7_subr_3
:
2993 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2994 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2995 SCM_CADDR (debug
.info
->a
.args
)));
2997 #ifdef BUILTIN_RPASUBR
2998 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2999 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3002 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3003 arg2
= SCM_CDR (arg2
);
3005 while (SCM_NIMP (arg2
));
3007 #endif /* BUILTIN_RPASUBR */
3008 case scm_tc7_rpsubr
:
3009 #ifdef BUILTIN_RPASUBR
3010 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3012 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3015 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3017 arg2
= SCM_CAR (t
.arg1
);
3018 t
.arg1
= SCM_CDR (t
.arg1
);
3020 while (SCM_NIMP (t
.arg1
));
3022 #else /* BUILTIN_RPASUBR */
3023 RETURN (SCM_APPLY (proc
, t
.arg1
,
3025 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3027 #endif /* BUILTIN_RPASUBR */
3028 case scm_tc7_lsubr_2
:
3029 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3030 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3032 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3038 proc
= SCM_PROCEDURE (proc
);
3039 debug
.info
->a
.proc
= proc
;
3041 case scm_tcs_closures
:
3042 SCM_SET_ARGSREADY (debug
);
3043 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3046 x
= SCM_CODE (proc
);
3049 case scm_tc7_subr_3
:
3050 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3051 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3053 #ifdef BUILTIN_RPASUBR
3054 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3057 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3060 while (SCM_NIMP (x
));
3062 #endif /* BUILTIN_RPASUBR */
3063 case scm_tc7_rpsubr
:
3064 #ifdef BUILTIN_RPASUBR
3065 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3069 t
.arg1
= EVALCAR (x
, env
);
3070 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3075 while (SCM_NIMP (x
));
3077 #else /* BUILTIN_RPASUBR */
3078 RETURN (SCM_APPLY (proc
, t
.arg1
,
3080 scm_eval_args (x
, env
, proc
),
3082 #endif /* BUILTIN_RPASUBR */
3083 case scm_tc7_lsubr_2
:
3084 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3086 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3088 scm_eval_args (x
, env
, proc
))));
3094 proc
= SCM_PROCEDURE (proc
);
3096 case scm_tcs_closures
:
3098 SCM_SET_ARGSREADY (debug
);
3100 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3103 scm_eval_args (x
, env
, proc
)),
3105 x
= SCM_CODE (proc
);
3108 case scm_tcs_cons_gloc
:
3109 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3112 arg2
= debug
.info
->a
.args
;
3114 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3116 x
= SCM_ENTITY_PROCEDURE (proc
);
3119 else if (!SCM_I_OPERATORP (proc
))
3123 case scm_tc7_subr_2
:
3124 case scm_tc7_subr_1o
:
3125 case scm_tc7_subr_2o
:
3126 case scm_tc7_subr_0
:
3128 case scm_tc7_subr_1
:
3129 case scm_tc7_contin
:
3137 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3138 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3140 SCM_CLEAR_TRACED_FRAME (debug
);
3141 if (SCM_CHEAPTRAPS_P
)
3142 t
.arg1
= scm_make_debugobj (&debug
);
3145 scm_make_cont (&t
.arg1
);
3146 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3148 proc
= SCM_THROW_VALUE (t
.arg1
);
3152 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3155 scm_last_debug_frame
= debug
.prev
;
3161 /* SECTION: This code is compiled once.
3166 /* This code processes the arguments to apply:
3168 (apply PROC ARG1 ... ARGS)
3170 Given a list (ARG1 ... ARGS), this function conses the ARG1
3171 ... arguments onto the front of ARGS, and returns the resulting
3172 list. Note that ARGS is a list; thus, the argument to this
3173 function is a list whose last element is a list.
3175 Apply calls this function, and applies PROC to the elements of the
3176 result. apply:nconc2last takes care of building the list of
3177 arguments, given (ARG1 ... ARGS).
3179 Rather than do new consing, apply:nconc2last destroys its argument.
3180 On that topic, this code came into my care with the following
3181 beautifully cryptic comment on that topic: "This will only screw
3182 you if you do (scm_apply scm_apply '( ... ))" If you know what
3183 they're referring to, send me a patch to this comment. */
3185 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
3188 scm_nconc2last (lst
)
3192 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
3194 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3195 lloc
= SCM_CDRLOC (*lloc
);
3196 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
3197 *lloc
= SCM_CAR (*lloc
);
3204 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3205 * It is compiled twice.
3211 scm_apply (proc
, arg1
, args
)
3221 scm_dapply (proc
, arg1
, args
)
3229 /* Apply a function to a list of arguments.
3231 This function is exported to the Scheme level as taking two
3232 required arguments and a tail argument, as if it were:
3233 (lambda (proc arg1 . args) ...)
3234 Thus, if you just have a list of arguments to pass to a procedure,
3235 pass the list as ARG1, and '() for ARGS. If you have some fixed
3236 args, pass the first as ARG1, then cons any remaining fixed args
3237 onto the front of your argument list, and pass that as ARGS. */
3240 SCM_APPLY (proc
, arg1
, args
)
3245 #ifdef DEBUG_EXTENSIONS
3247 scm_debug_frame debug
;
3248 scm_debug_info debug_vect_body
;
3249 debug
.prev
= scm_last_debug_frame
;
3250 debug
.status
= SCM_APPLYFRAME
;
3251 debug
.vect
= &debug_vect_body
;
3252 debug
.vect
[0].a
.proc
= proc
;
3253 debug
.vect
[0].a
.args
= SCM_EOL
;
3254 scm_last_debug_frame
= &debug
;
3257 return scm_dapply (proc
, arg1
, args
);
3261 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3263 /* If ARGS is the empty list, then we're calling apply with only two
3264 arguments --- ARG1 is the list of arguments for PROC. Whatever
3265 the case, futz with things so that ARG1 is the first argument to
3266 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3269 Setting the debug apply frame args this way is pretty messy.
3270 Perhaps we should store arg1 and args directly in the frame as
3271 received, and let scm_frame_arguments unpack them, because that's
3272 a relatively rare operation. This works for now; if the Guile
3273 developer archives are still around, see Mikael's post of
3275 if (SCM_NULLP (args
))
3277 if (SCM_NULLP (arg1
))
3279 arg1
= SCM_UNDEFINED
;
3281 debug
.vect
[0].a
.args
= SCM_EOL
;
3287 debug
.vect
[0].a
.args
= arg1
;
3289 args
= SCM_CDR (arg1
);
3290 arg1
= SCM_CAR (arg1
);
3295 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
3296 args
= scm_nconc2last (args
);
3298 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3302 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3305 if (SCM_CHEAPTRAPS_P
)
3306 tmp
= scm_make_debugobj (&debug
);
3309 scm_make_cont (&tmp
);
3310 if (setjmp (SCM_JMPBUF (tmp
)))
3313 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3321 switch (SCM_TYP7 (proc
))
3323 case scm_tc7_subr_2o
:
3324 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3325 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3326 case scm_tc7_subr_2
:
3327 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3329 args
= SCM_CAR (args
);
3330 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3331 case scm_tc7_subr_0
:
3332 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3333 RETURN (SCM_SUBRF (proc
) ())
3334 case scm_tc7_subr_1
:
3335 case scm_tc7_subr_1o
:
3336 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3337 RETURN (SCM_SUBRF (proc
) (arg1
))
3339 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3341 if (SCM_SUBRF (proc
))
3343 if (SCM_INUMP (arg1
))
3345 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
3347 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3348 if (SCM_REALP (arg1
))
3350 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
3353 if (SCM_BIGP (arg1
))
3354 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
3357 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3358 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3361 proc
= (SCM
) SCM_SNAME (proc
);
3363 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3364 while ('c' != *--chrs
)
3366 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
3367 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3368 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3372 case scm_tc7_subr_3
:
3373 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3376 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3378 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3380 case scm_tc7_lsubr_2
:
3381 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
3382 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3384 if (SCM_NULLP (args
))
3385 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3386 while (SCM_NIMP (args
))
3388 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3389 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3390 args
= SCM_CDR (args
);
3393 case scm_tc7_rpsubr
:
3394 if (SCM_NULLP (args
))
3395 RETURN (SCM_BOOL_T
);
3396 while (SCM_NIMP (args
))
3398 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3399 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3400 RETURN (SCM_BOOL_F
);
3401 arg1
= SCM_CAR (args
);
3402 args
= SCM_CDR (args
);
3404 RETURN (SCM_BOOL_T
);
3405 case scm_tcs_closures
:
3407 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3409 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3411 #ifndef SCM_RECKLESS
3412 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3416 /* Copy argument list */
3421 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3422 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
3423 && SCM_CONSP (arg1
))
3425 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3429 SCM_SETCDR (tl
, arg1
);
3432 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3433 proc
= SCM_CDR (SCM_CODE (proc
));
3436 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3438 if (SCM_IMP (SCM_CAR (proc
)))
3440 if (SCM_ISYMP (SCM_CAR (proc
)))
3442 proc
= scm_m_expand_body (proc
, args
);
3447 SCM_CEVAL (SCM_CAR (proc
), args
);
3450 RETURN (EVALCAR (proc
, args
));
3451 case scm_tc7_contin
:
3452 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3453 scm_call_continuation (proc
, arg1
);
3457 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3459 proc
= SCM_CCLO_SUBR (proc
);
3460 debug
.vect
[0].a
.proc
= proc
;
3461 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3463 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3465 proc
= SCM_CCLO_SUBR (proc
);
3470 proc
= SCM_PROCEDURE (proc
);
3472 debug
.vect
[0].a
.proc
= proc
;
3475 case scm_tcs_cons_gloc
:
3476 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3479 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3481 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3483 RETURN (scm_apply_generic (proc
, args
));
3485 else if (!SCM_I_OPERATORP (proc
))
3490 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3492 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3495 proc
= (SCM_I_ENTITYP (proc
)
3496 ? SCM_ENTITY_PROCEDURE (proc
)
3497 : SCM_OPERATOR_PROCEDURE (proc
));
3499 debug
.vect
[0].a
.proc
= proc
;
3500 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3502 if (SCM_NIMP (proc
))
3508 scm_wrong_num_args (proc
);
3511 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3516 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3517 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3519 SCM_CLEAR_TRACED_FRAME (debug
);
3520 if (SCM_CHEAPTRAPS_P
)
3521 arg1
= scm_make_debugobj (&debug
);
3524 scm_make_cont (&arg1
);
3525 if (setjmp (SCM_JMPBUF (arg1
)))
3527 proc
= SCM_THROW_VALUE (arg1
);
3531 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3534 scm_last_debug_frame
= debug
.prev
;
3540 /* SECTION: The rest of this file is only read once.
3545 /* Typechecking for multi-argument MAP and FOR-EACH.
3547 Verify that each element of the vector ARGS, except for the first,
3548 is a proper list whose length is LEN. Attribute errors to WHO,
3549 and claim that the i'th element of ARGS is WHO's i+2'th argument. */
3551 check_map_args (long len
, SCM args
, const char *who
)
3553 SCM
*ve
= SCM_VELTS (args
);
3556 for (i
= SCM_LENGTH (args
) - 1; i
>= 1; i
--)
3558 int elt_len
= scm_ilength (ve
[i
]);
3561 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3564 scm_out_of_range (who
, ve
[i
]);
3567 scm_remember (&args
);
3571 SCM_PROC (s_map
, "map", 2, 0, 1, scm_map
);
3573 /* Note: Currently, scm_map applies PROC to the argument list(s)
3574 sequentially, starting with the first element(s). This is used in
3575 evalext.c where the Scheme procedure `serial-map', which guarantees
3576 sequential behaviour, is implemented using scm_map. If the
3577 behaviour changes, we need to update `serial-map'.
3581 scm_map (proc
, arg1
, args
)
3589 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3591 if (SCM_NULLP (arg1
))
3593 len
= scm_ilength (arg1
);
3594 SCM_ASSERT (len
>= 0, arg1
, SCM_ARG2
, s_map
);
3595 if (SCM_NULLP (args
))
3597 while (SCM_NIMP (arg1
))
3599 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
3600 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
3601 pres
= SCM_CDRLOC (*pres
);
3602 arg1
= SCM_CDR (arg1
);
3606 args
= scm_vector (scm_cons (arg1
, args
));
3607 ve
= SCM_VELTS (args
);
3608 #ifndef SCM_RECKLESS
3609 check_map_args (len
, args
, s_map
);
3614 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3616 if (SCM_IMP (ve
[i
]))
3618 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3619 ve
[i
] = SCM_CDR (ve
[i
]);
3621 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3622 pres
= SCM_CDRLOC (*pres
);
3627 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
3630 scm_for_each (proc
, arg1
, args
)
3635 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3638 return SCM_UNSPECIFIED
;
3639 len
= scm_ilength (arg1
);
3640 SCM_ASSERT (len
>= 0, arg1
, SCM_ARG2
, s_for_each
);
3643 while SCM_NIMP (arg1
)
3645 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3646 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3647 arg1
= SCM_CDR (arg1
);
3649 return SCM_UNSPECIFIED
;
3651 args
= scm_vector (scm_cons (arg1
, args
));
3652 ve
= SCM_VELTS (args
);
3653 #ifndef SCM_RECKLESS
3654 check_map_args (len
, args
, s_for_each
);
3659 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3662 (ve
[i
]) return SCM_UNSPECIFIED
;
3663 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3664 ve
[i
] = SCM_CDR (ve
[i
]);
3666 scm_apply (proc
, arg1
, SCM_EOL
);
3673 scm_closure (code
, env
)
3679 SCM_SETCODE (z
, code
);
3680 SCM_SETENV (z
, env
);
3685 long scm_tc16_promise
;
3691 SCM_RETURN_NEWSMOB (scm_tc16_promise
, code
);
3696 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
3699 prinprom (exp
, port
, pstate
)
3702 scm_print_state
*pstate
;
3704 int writingp
= SCM_WRITINGP (pstate
);
3705 scm_puts ("#<promise ", port
);
3706 SCM_SET_WRITINGP (pstate
, 1);
3707 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3708 SCM_SET_WRITINGP (pstate
, writingp
);
3709 scm_putc ('>', port
);
3714 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
3720 SCM_ASSERT (SCM_NIMP(x
) && SCM_TYP16 (x
) == scm_tc16_promise
,
3721 x
, SCM_ARG1
, s_force
);
3722 if (!((1L << 16) & SCM_CAR (x
)))
3724 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3725 if (!((1L << 16) & SCM_CAR (x
)))
3728 SCM_SETCDR (x
, ans
);
3729 SCM_SETOR_CAR (x
, (1L << 16));
3736 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
3742 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
3747 SCM_PROC (s_cons_source
, "cons-source", 3, 0, 0, scm_cons_source
);
3750 scm_cons_source (SCM xorig
, SCM x
, SCM y
)
3756 /* Copy source properties possibly associated with xorig. */
3757 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3759 scm_whash_insert (scm_source_whash
, z
, p
);
3763 SCM_PROC (s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
3772 if (SCM_VECTORP (obj
))
3774 scm_sizet i
= SCM_LENGTH (obj
);
3775 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3777 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3780 if (SCM_NCONSP (obj
))
3782 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3783 ans
= tl
= scm_cons_source (obj
,
3784 scm_copy_tree (SCM_CAR (obj
)),
3786 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3788 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3792 SCM_SETCDR (tl
, obj
);
3798 scm_eval_3 (obj
, copyp
, env
)
3803 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3804 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3806 obj
= scm_copy_tree (obj
);
3807 return SCM_XEVAL (obj
, env
);
3810 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
3813 scm_eval2 (obj
, env_thunk
)
3817 return scm_eval_3 (obj
, 1, scm_top_level_env (env_thunk
));
3820 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
3826 return scm_eval_3 (obj
,
3829 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3832 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
3838 return scm_eval_3 (obj
,
3841 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3845 /* At this point, scm_deval and scm_dapply are generated.
3848 #ifdef DEBUG_EXTENSIONS
3858 scm_init_opts (scm_evaluator_traps
,
3859 scm_evaluator_trap_table
,
3860 SCM_N_EVALUATOR_TRAPS
);
3861 scm_init_opts (scm_eval_options_interface
,
3863 SCM_N_EVAL_OPTIONS
);
3865 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3866 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3867 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3869 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3870 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3871 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3872 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3873 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3874 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3875 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3877 scm_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3878 SCM_SETCDR (scm_nil
, SCM_CAR (scm_nil
));
3879 scm_nil
= SCM_CAR (scm_nil
);
3880 scm_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3881 SCM_SETCDR (scm_t
, SCM_CAR (scm_t
));
3882 scm_t
= SCM_CAR (scm_t
);
3887 scm_top_level_lookup_closure_var
=
3888 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3889 scm_can_use_top_level_lookup_closure_var
= 1;
3891 #ifdef DEBUG_EXTENSIONS
3892 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3893 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3894 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3895 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3900 scm_add_feature ("delay");