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. */
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 "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 */
86 #include "continuations.h"
99 #include "scm_validate.h"
102 SCM (*scm_memoize_method
) (SCM
, SCM
);
106 /* The evaluator contains a plethora of EVAL symbols.
107 * This is an attempt at explanation.
109 * The following macros should be used in code which is read twice
110 * (where the choice of evaluator is hard soldered):
112 * SCM_CEVAL is the symbol used within one evaluator to call itself.
113 * Originally, it is defined to scm_ceval, but is redefined to
114 * scm_deval during the second pass.
116 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
117 * only side effects of expressions matter. All immediates are
120 * SCM_EVALIM is used when it is known that the expression is an
121 * immediate. (This macro never calls an evaluator.)
123 * EVALCAR evaluates the car of an expression.
125 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
126 * car is a lisp cell.
128 * The following macros should be used in code which is read once
129 * (where the choice of evaluator is dynamic):
131 * SCM_XEVAL takes care of immediates without calling an evaluator. It
132 * then calls scm_ceval *or* scm_deval, depending on the debugging
135 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
136 * depending on the debugging mode.
138 * The main motivation for keeping this plethora is efficiency
139 * together with maintainability (=> locality of code).
142 #define SCM_CEVAL scm_ceval
143 #define SIDEVAL(x, env) if (SCM_NIMP(x)) SCM_CEVAL((x), (env))
145 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
146 ? *scm_lookupcar(x, env, 1) \
147 : SCM_CEVAL(SCM_CAR(x), env))
149 #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
150 ? (SCM_IMP(SCM_CAR(x)) \
151 ? SCM_EVALIM(SCM_CAR(x), env) \
152 : SCM_GLOC_VAL(SCM_CAR(x))) \
153 : EVALCELLCAR(x, env))
155 #define EXTEND_ENV SCM_EXTEND_ENV
157 #ifdef MEMOIZE_LOCALS
160 scm_ilookup (iloc
, env
)
164 register int ir
= SCM_IFRAME (iloc
);
165 register SCM er
= env
;
166 for (; 0 != ir
; --ir
)
169 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
171 if (SCM_ICDRP (iloc
))
172 return SCM_CDRLOC (er
);
173 return SCM_CARLOC (SCM_CDR (er
));
179 /* The Lookup Car Race
182 Memoization of variables and special forms is done while executing
183 the code for the first time. As long as there is only one thread
184 everything is fine, but as soon as two threads execute the same
185 code concurrently `for the first time' they can come into conflict.
187 This memoization includes rewriting variable references into more
188 efficient forms and expanding macros. Furthermore, macro expansion
189 includes `compiling' special forms like `let', `cond', etc. into
190 tree-code instructions.
192 There shouldn't normally be a problem with memoizing local and
193 global variable references (into ilocs and glocs), because all
194 threads will mutate the code in *exactly* the same way and (if I
195 read the C code correctly) it is not possible to observe a half-way
196 mutated cons cell. The lookup procedure can handle this
197 transparently without any critical sections.
199 It is different with macro expansion, because macro expansion
200 happens outside of the lookup procedure and can't be
201 undone. Therefore it can't cope with it. It has to indicate
202 failure when it detects a lost race and hope that the caller can
203 handle it. Luckily, it turns out that this is the case.
205 An example to illustrate this: Suppose that the follwing form will
206 be memoized concurrently by two threads
210 Let's first examine the lookup of X in the body. The first thread
211 decides that it has to find the symbol "x" in the environment and
212 starts to scan it. Then the other thread takes over and actually
213 overtakes the first. It looks up "x" and substitutes an
214 appropriate iloc for it. Now the first thread continues and
215 completes its lookup. It comes to exactly the same conclusions as
216 the second one and could - without much ado - just overwrite the
217 iloc with the same iloc.
219 But let's see what will happen when the race occurs while looking
220 up the symbol "let" at the start of the form. It could happen that
221 the second thread interrupts the lookup of the first thread and not
222 only substitutes a gloc for it but goes right ahead and replaces it
223 with the compiled form (#@let* (x 12) x). Now, when the first
224 thread completes its lookup, it would replace the #@let* with a
225 gloc pointing to the "let" binding, effectively reverting the form
226 to (let (x 12) x). This is wrong. It has to detect that it has
227 lost the race and the evaluator has to reconsider the changed form
230 This race condition could be resolved with some kind of traffic
231 light (like mutexes) around scm_lookupcar, but I think that it is
232 best to avoid them in this case. They would serialize memoization
233 completely and because lookup involves calling arbitrary Scheme
234 code (via the lookup-thunk), threads could be blocked for an
235 arbitrary amount of time or even deadlock. But with the current
236 solution a lot of unnecessary work is potentially done. */
238 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
239 return NULL to indicate a failed lookup due to some race conditions
240 between threads. This only happens when VLOC is the first cell of
241 a special form that will eventually be memoized (like `let', etc.)
242 In that case the whole lookup is bogus and the caller has to
243 reconsider the complete special form.
245 SCM_LOOKUPCAR is still there, of course. It just calls
246 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
247 should only be called when it is known that VLOC is not the first
248 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
249 for NULL. I think I've found the only places where this
252 #endif /* USE_THREADS */
254 /* scm_lookupcar returns a pointer to this when a variable could not
255 be found and it should not throw an error. Never assign to this.
257 static scm_cell undef_cell
= { SCM_UNDEFINED
, SCM_UNDEFINED
};
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_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
279 al
= SCM_CARLOC (env
);
280 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
286 #ifdef MEMOIZE_LOCALS
288 if (SCM_CAR (vloc
) != var
)
291 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
293 return SCM_CDRLOC (*al
);
298 al
= SCM_CDRLOC (*al
);
299 if (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
321 #ifdef MEMOIZE_LOCALS
322 iloc
= (~SCM_IDSTMSK
) & (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 (vcell
== SCM_BOOL_F
)
341 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
345 /* scm_everr (vloc, genv,...) */
347 scm_misc_error (NULL
,
349 ? "Unbound variable: %S"
350 : "Damaged environment: %S",
351 scm_listify (var
, SCM_UNDEFINED
));
353 return SCM_CDRLOC (&undef_cell
);
357 if (SCM_CAR (vloc
) != var2
)
359 /* Some other thread has changed the very cell we are working
360 on. In effect, it must have done our job or messed it up
363 var
= SCM_CAR (vloc
);
365 return SCM_GLOC_VAL_LOC (var
);
366 #ifdef MEMOIZE_LOCALS
367 if ((var
& 127) == (127 & SCM_ILOC00
))
368 return scm_ilookup (var
, genv
);
370 /* We can't cope with anything else than glocs and ilocs. When
371 a special form has been memoized (i.e. `let' into `#@let') we
372 return NULL and expect the calling function to do the right
373 thing. For the evaluator, this means going back and redoing
374 the dispatch on the car of the form. */
377 #endif /* USE_THREADS */
379 SCM_SETCAR (vloc
, var
+ 1);
380 /* Except wait...what if the var is not a vcell,
381 * but syntax or something.... */
382 return SCM_CDRLOC (var
);
387 scm_lookupcar (vloc
, genv
, check
)
392 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
399 #define unmemocar scm_unmemocar
402 scm_unmemocar (form
, env
)
406 #ifdef DEBUG_EXTENSIONS
415 SCM_SETCAR (form
, SCM_CAR (c
- 1));
416 #ifdef MEMOIZE_LOCALS
417 #ifdef DEBUG_EXTENSIONS
418 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 (pair
, env
)
438 return SCM_XEVALCAR (pair
, env
);
443 * The following rewrite expressions and
444 * some memoized forms have different syntax
447 const char scm_s_expression
[] = "missing or extra expression";
448 const char scm_s_test
[] = "bad test";
449 const char scm_s_body
[] = "bad body";
450 const char scm_s_bindings
[] = "bad bindings";
451 const char scm_s_variable
[] = "bad variable";
452 const char scm_s_clauses
[] = "bad or missing clauses";
453 const char scm_s_formals
[] = "bad formals";
455 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
456 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
460 #ifdef DEBUG_EXTENSIONS
461 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
465 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
469 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, const char *what
));
472 bodycheck (xorig
, bodyloc
, what
)
477 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
480 /* Check that the body denoted by XORIG is valid and rewrite it into
481 its internal form. The internal form of a body is just the body
482 itself, but prefixed with an ISYM that denotes to what kind of
483 outer construct this body belongs. A lambda body starts with
484 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
485 etc. The one exception is a body that belongs to a letrec that has
486 been formed by rewriting internal defines: it starts with
489 /* XXX - Besides controlling the rewriting of internal defines, the
490 additional ISYM could be used for improved error messages.
491 This is not done yet. */
494 scm_m_body (op
, xorig
, what
)
499 ASRTSYNTAX (scm_ilength (xorig
) >= 1, scm_s_expression
);
501 /* Don't add another ISYM if one is present already. */
502 if (SCM_ISYMP (SCM_CAR (xorig
)))
505 /* Retain possible doc string. */
506 if (SCM_IMP (SCM_CAR(xorig
)) || SCM_NCONSP (SCM_CAR (xorig
)))
508 if (SCM_NNULLP (SCM_CDR(xorig
)))
509 return scm_cons (SCM_CAR (xorig
),
510 scm_m_body (op
, SCM_CDR(xorig
), what
));
514 return scm_cons2 (op
, SCM_CAR (xorig
), SCM_CDR(xorig
));
517 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
518 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
521 scm_m_quote (xorig
, env
)
525 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
527 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
528 xorig
, scm_s_expression
, s_quote
);
529 return scm_cons (SCM_IM_QUOTE
, x
);
534 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
535 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
538 scm_m_begin (xorig
, env
)
542 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
543 xorig
, scm_s_expression
, s_begin
);
544 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
547 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
548 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
551 scm_m_if (xorig
, env
)
555 int len
= scm_ilength (SCM_CDR (xorig
));
556 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
557 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
561 /* Will go into the RnRS module when Guile is factorized.
562 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
563 const char scm_s_set_x
[] = "set!";
564 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
567 scm_m_set_x (xorig
, env
)
571 SCM x
= SCM_CDR (xorig
);
572 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
573 SCM_ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
574 xorig
, scm_s_variable
, scm_s_set_x
);
575 return scm_cons (SCM_IM_SET_X
, x
);
582 scm_m_vref (xorig
, env
)
586 SCM x
= SCM_CDR (xorig
);
587 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
588 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
590 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
591 scm_misc_error (NULL
,
593 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
595 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
596 xorig
, scm_s_variable
, s_vref
);
597 return scm_cons (IM_VREF
, x
);
603 scm_m_vset (xorig
, env
)
607 SCM x
= SCM_CDR (xorig
);
608 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
609 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
610 || UDSCM_VARIABLEP (SCM_CAR (x
))),
611 xorig
, scm_s_variable
, s_vset
);
612 return scm_cons (IM_VSET
, x
);
617 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
618 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
621 scm_m_and (xorig
, env
)
625 int len
= scm_ilength (SCM_CDR (xorig
));
626 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
628 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
633 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
634 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
637 scm_m_or (xorig
, env
)
641 int len
= scm_ilength (SCM_CDR (xorig
));
642 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
644 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
650 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
651 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
654 scm_m_case (xorig
, env
)
658 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
659 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
660 while (SCM_NIMP (x
= SCM_CDR (x
)))
663 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
664 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
665 || scm_sym_else
== SCM_CAR (proc
),
666 xorig
, scm_s_clauses
, s_case
);
668 return scm_cons (SCM_IM_CASE
, cdrx
);
672 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
673 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
677 scm_m_cond (xorig
, env
)
681 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
682 int len
= scm_ilength (x
);
683 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
687 len
= scm_ilength (arg1
);
688 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
689 if (scm_sym_else
== SCM_CAR (arg1
))
691 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
692 xorig
, "bad ELSE clause", s_cond
);
693 SCM_SETCAR (arg1
, SCM_BOOL_T
);
695 if (len
>= 2 && scm_sym_arrow
== SCM_CAR (SCM_CDR (arg1
)))
696 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
697 xorig
, "bad recipient", s_cond
);
700 return scm_cons (SCM_IM_COND
, cdrx
);
703 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
704 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
707 scm_m_lambda (xorig
, env
)
711 SCM proc
, x
= SCM_CDR (xorig
);
712 if (scm_ilength (x
) < 2)
715 if (SCM_NULLP (proc
))
717 if (SCM_IM_LET
== proc
) /* named let */
721 if (SCM_SYMBOLP (proc
))
723 if (SCM_NCONSP (proc
))
725 while (SCM_NIMP (proc
))
727 if (SCM_NCONSP (proc
))
729 if (!SCM_SYMBOLP (proc
))
734 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
736 proc
= SCM_CDR (proc
);
738 if (SCM_NNULLP (proc
))
741 scm_wta (xorig
, scm_s_formals
, s_lambda
);
745 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
746 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
749 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
750 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
754 scm_m_letstar (xorig
, env
)
758 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
759 int len
= scm_ilength (x
);
760 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
762 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
763 while (SCM_NIMP (proc
))
765 arg1
= SCM_CAR (proc
);
766 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
767 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
768 xorig
, scm_s_variable
, s_letstar
);
769 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
770 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
771 proc
= SCM_CDR (proc
);
773 x
= scm_cons (vars
, SCM_CDR (x
));
775 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
776 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
779 /* DO gets the most radically altered syntax
780 (do ((<var1> <init1> <step1>)
786 (do_mem (varn ... var2 var1)
787 (<init1> <init2> ... <initn>)
790 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
793 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
794 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
797 scm_m_do (xorig
, env
)
801 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
802 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
803 SCM
*initloc
= &inits
, *steploc
= &steps
;
804 int len
= scm_ilength (x
);
805 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
807 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
808 while (SCM_NIMP(proc
))
810 arg1
= SCM_CAR (proc
);
811 len
= scm_ilength (arg1
);
812 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
813 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
814 xorig
, scm_s_variable
, "do");
815 /* vars reversed here, inits and steps reversed at evaluation */
816 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
817 arg1
= SCM_CDR (arg1
);
818 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
819 initloc
= SCM_CDRLOC (*initloc
);
820 arg1
= SCM_CDR (arg1
);
821 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
822 steploc
= SCM_CDRLOC (*steploc
);
823 proc
= SCM_CDR (proc
);
826 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
827 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
828 x
= scm_cons2 (vars
, inits
, x
);
829 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
830 return scm_cons (SCM_IM_DO
, x
);
833 /* evalcar is small version of inline EVALCAR when we don't care about
836 #define evalcar scm_eval_car
839 static SCM
iqq (SCM form
, SCM env
, int depth
);
841 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
842 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
845 scm_m_quasiquote (xorig
, env
)
849 SCM x
= SCM_CDR (xorig
);
850 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
851 return iqq (SCM_CAR (x
), env
, 1);
856 iqq (SCM form
,SCM env
,int depth
)
862 if (SCM_VECTORP (form
))
864 long i
= SCM_LENGTH (form
);
865 SCM
*data
= SCM_VELTS (form
);
868 tmp
= scm_cons (data
[i
], tmp
);
869 return scm_vector (iqq (tmp
, env
, depth
));
871 if (SCM_NCONSP(form
))
873 tmp
= SCM_CAR (form
);
874 if (scm_sym_quasiquote
== tmp
)
879 if (scm_sym_unquote
== tmp
)
883 form
= SCM_CDR (form
);
884 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
885 form
, SCM_ARG1
, s_quasiquote
);
887 return evalcar (form
, env
);
888 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
890 if (SCM_NIMP (tmp
) && (scm_sym_uq_splicing
== SCM_CAR (tmp
)))
894 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
896 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
899 /* Here are acros which return values rather than code. */
901 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
902 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
905 scm_m_delay (xorig
, env
)
909 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
910 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
914 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
915 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
918 scm_m_define (x
, env
)
924 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
925 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
928 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
929 { /* nested define syntax */
930 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
931 proc
= SCM_CAR (proc
);
933 SCM_ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
),
934 arg1
, scm_s_variable
, s_define
);
935 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
936 if (SCM_TOP_LEVEL (env
))
938 x
= evalcar (x
, env
);
939 #ifdef DEBUG_EXTENSIONS
940 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
944 if (SCM_CLOSUREP (arg1
)
945 /* Only the first definition determines the name. */
946 && scm_procedure_property (arg1
, scm_sym_name
) == SCM_BOOL_F
)
947 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
948 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
949 && SCM_CDR (arg1
) != arg1
)
951 arg1
= SCM_CDR (arg1
);
956 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
959 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
960 && (SCM_CDR (arg1
) != x
))
961 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
964 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
965 scm_warn ("redefining ", SCM_CHARS (proc
));
967 SCM_SETCDR (arg1
, x
);
969 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
971 return SCM_UNSPECIFIED
;
974 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
980 scm_m_letrec1 (op
, imm
, xorig
, env
)
986 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
987 char *what
= SCM_CHARS (SCM_CAR (xorig
));
988 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
989 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
992 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
995 /* vars scm_list reversed here, inits reversed at evaluation */
996 arg1
= SCM_CAR (proc
);
997 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
998 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
1000 vars
= scm_cons (SCM_CAR (arg1
), vars
);
1001 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1002 initloc
= SCM_CDRLOC (*initloc
);
1004 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1006 return scm_cons2 (op
, vars
,
1007 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
1010 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
1011 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1014 scm_m_letrec (xorig
, env
)
1018 SCM x
= SCM_CDR (xorig
);
1019 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
1021 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
1022 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
1023 scm_m_body (SCM_IM_LETREC
,
1028 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
1031 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
1032 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1035 scm_m_let (xorig
, env
)
1039 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
1040 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
1041 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
1043 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1045 if (SCM_NULLP (proc
)
1046 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
1047 && SCM_NIMP (SCM_CAR (proc
))
1048 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
1050 /* null or single binding, let* is faster */
1051 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
1052 scm_m_body (SCM_IM_LET
,
1058 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
1059 if (SCM_CONSP (proc
))
1061 /* plain let, proc is <bindings> */
1062 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1065 if (!SCM_SYMBOLP (proc
))
1066 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1067 name
= proc
; /* named let, build equiv letrec */
1069 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1070 proc
= SCM_CAR (x
); /* bindings list */
1071 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1072 while (SCM_NIMP (proc
))
1073 { /* vars and inits both in order */
1074 arg1
= SCM_CAR (proc
);
1075 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1076 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
1077 xorig
, scm_s_variable
, s_let
);
1078 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1079 varloc
= SCM_CDRLOC (*varloc
);
1080 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1081 initloc
= SCM_CDRLOC (*initloc
);
1082 proc
= SCM_CDR (proc
);
1085 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1086 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1087 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1089 scm_acons (name
, inits
, SCM_EOL
));
1090 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1094 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1095 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1096 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1099 scm_m_apply (xorig
, env
)
1103 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1104 xorig
, scm_s_expression
, s_atapply
);
1105 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1109 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1110 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1114 scm_m_cont (xorig
, env
)
1118 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1119 xorig
, scm_s_expression
, s_atcall_cc
);
1120 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1123 /* Multi-language support */
1128 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1131 scm_m_nil_cond (SCM xorig
, SCM env
)
1133 int len
= scm_ilength (SCM_CDR (xorig
));
1134 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1135 scm_s_expression
, "nil-cond");
1136 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1139 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1142 scm_m_nil_ify (SCM xorig
, SCM env
)
1144 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1145 xorig
, scm_s_expression
, "nil-ify");
1146 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1149 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1152 scm_m_t_ify (SCM xorig
, SCM env
)
1154 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1155 xorig
, scm_s_expression
, "t-ify");
1156 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1159 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1162 scm_m_0_cond (SCM xorig
, SCM env
)
1164 int len
= scm_ilength (SCM_CDR (xorig
));
1165 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1166 scm_s_expression
, "0-cond");
1167 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1170 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1173 scm_m_0_ify (SCM xorig
, SCM env
)
1175 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1176 xorig
, scm_s_expression
, "0-ify");
1177 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1180 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1183 scm_m_1_ify (SCM xorig
, SCM env
)
1185 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1186 xorig
, scm_s_expression
, "1-ify");
1187 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1190 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1193 scm_m_atfop (SCM xorig
, SCM env
)
1195 SCM x
= SCM_CDR (xorig
), vcell
;
1196 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1197 vcell
= scm_symbol_fref (SCM_CAR (x
));
1198 SCM_ASSYNT (SCM_NIMP (vcell
) && SCM_CONSP (vcell
), x
,
1199 "Symbol's function definition is void", NULL
);
1200 SCM_SETCAR (x
, vcell
+ 1);
1204 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1207 scm_m_atbind (SCM xorig
, SCM env
)
1209 SCM x
= SCM_CDR (xorig
);
1210 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1216 while (SCM_NIMP (SCM_CDR (env
)))
1217 env
= SCM_CDR (env
);
1218 env
= SCM_CAR (env
);
1219 if (SCM_CONSP (env
))
1224 while (SCM_NIMP (x
))
1226 SCM_SETCAR (x
, scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
) + 1);
1229 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1233 scm_m_expand_body (SCM xorig
, SCM env
)
1235 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1236 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1238 while (SCM_NIMP (x
))
1241 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1243 if (SCM_IMP (SCM_CAR (form
)))
1245 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1248 form
= scm_macroexp (scm_cons_source (form
,
1253 if (SCM_IM_DEFINE
== SCM_CAR (form
))
1255 defs
= scm_cons (SCM_CDR (form
), defs
);
1258 else if (SCM_NIMP(defs
))
1262 else if (SCM_IM_BEGIN
== SCM_CAR (form
))
1264 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1268 x
= scm_cons (form
, SCM_CDR(x
));
1273 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1274 if (SCM_NIMP (defs
))
1276 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1278 scm_cons2 (scm_sym_define
, defs
, x
),
1284 SCM_SETCAR (xorig
, SCM_CAR (x
));
1285 SCM_SETCDR (xorig
, SCM_CDR (x
));
1292 scm_macroexp (SCM x
, SCM env
)
1296 /* Don't bother to produce error messages here. We get them when we
1297 eventually execute the code for real. */
1300 if (SCM_IMP (SCM_CAR (x
)) || !SCM_SYMBOLP (SCM_CAR (x
)))
1305 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1306 if (proc_ptr
== NULL
)
1308 /* We have lost the race. */
1314 proc
= *scm_lookupcar (x
, env
, 0);
1317 /* Only handle memoizing macros. `Acros' and `macros' are really
1318 special forms and should not be evaluated here. */
1321 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1322 || (int) (SCM_CAR (proc
) >> 16) != 2)
1326 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1328 if (scm_ilength (res
) <= 0)
1329 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1332 SCM_SETCAR (x
, SCM_CAR (res
));
1333 SCM_SETCDR (x
, SCM_CDR (res
));
1339 /* scm_unmemocopy takes a memoized expression together with its
1340 * environment and rewrites it to its original form. Thus, it is the
1341 * inversion of the rewrite rules above. The procedure is not
1342 * optimized for speed. It's used in scm_iprin1 when printing the
1343 * code of a closure, in scm_procedure_source, in display_frame when
1344 * generating the source for a stackframe in a backtrace, and in
1345 * display_expression.
1348 /* We should introduce an anti-macro interface so that it is possible
1349 * to plug in transformers in both directions from other compilation
1350 * units. unmemocopy could then dispatch to anti-macro transformers.
1351 * (Those transformers could perhaps be written in slightly more
1352 * readable style... :)
1356 unmemocopy (SCM x
, SCM env
)
1359 #ifdef DEBUG_EXTENSIONS
1362 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1364 #ifdef DEBUG_EXTENSIONS
1365 p
= scm_whash_lookup (scm_source_whash
, x
);
1367 switch (SCM_TYP7 (x
))
1369 case (127 & SCM_IM_AND
):
1370 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1372 case (127 & SCM_IM_BEGIN
):
1373 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1375 case (127 & SCM_IM_CASE
):
1376 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1378 case (127 & SCM_IM_COND
):
1379 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1381 case (127 & SCM_IM_DO
):
1382 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1384 case (127 & SCM_IM_IF
):
1385 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1387 case (127 & SCM_IM_LET
):
1388 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1390 case (127 & SCM_IM_LETREC
):
1393 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1397 f
= v
= SCM_CAR (x
);
1399 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1401 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1402 SCM_CAR (ls
) == scm_sym_letrec
? z
: env
));
1405 s
= SCM_CAR (ls
) == scm_sym_do
1406 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1408 /* build transformed binding list */
1412 z
= scm_acons (SCM_CAR (v
),
1413 scm_cons (SCM_CAR (e
),
1414 SCM_CAR (s
) == SCM_CAR (v
)
1416 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1422 while (SCM_NIMP (v
));
1423 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1425 if (SCM_CAR (ls
) == scm_sym_do
)
1429 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1432 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1433 /* body forms are now to be found in SCM_CDR (x)
1434 (this is how *real* code look like! :) */
1438 case (127 & SCM_IM_LETSTAR
):
1446 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1449 y
= z
= scm_acons (SCM_CAR (b
),
1451 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1453 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1454 b
= SCM_CDR (SCM_CDR (b
));
1457 SCM_SETCDR (y
, SCM_EOL
);
1458 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1463 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1465 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1468 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1469 b
= SCM_CDR (SCM_CDR (b
));
1471 while (SCM_NIMP (b
));
1472 SCM_SETCDR (z
, SCM_EOL
);
1474 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1477 case (127 & SCM_IM_OR
):
1478 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1480 case (127 & SCM_IM_LAMBDA
):
1482 ls
= scm_cons (scm_sym_lambda
,
1483 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1484 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1486 case (127 & SCM_IM_QUOTE
):
1487 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1489 case (127 & SCM_IM_SET_X
):
1490 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1492 case (127 & SCM_IM_DEFINE
):
1496 ls
= scm_cons (scm_sym_define
,
1497 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1498 if (SCM_NNULLP (env
))
1499 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1502 case (127 & SCM_MAKISYM (0)):
1506 switch (SCM_ISYMNUM (z
))
1508 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1509 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1511 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1512 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1514 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1515 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1519 /* appease the Sun compiler god: */ ;
1523 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1528 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1530 if (SCM_IMP (SCM_CAR (x
)) && SCM_ISYMP (SCM_CAR (x
)))
1531 /* skip body markers */
1533 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1539 #ifdef DEBUG_EXTENSIONS
1540 if (SCM_NFALSEP (p
))
1541 scm_whash_insert (scm_source_whash
, ls
, p
);
1548 scm_unmemocopy (x
, env
)
1552 if (SCM_NNULLP (env
))
1553 /* Make a copy of the lowest frame to protect it from
1554 modifications by SCM_IM_DEFINE */
1555 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1557 return unmemocopy (x
, env
);
1560 #ifndef SCM_RECKLESS
1563 scm_badargsp (formals
, args
)
1567 while (SCM_NIMP (formals
))
1569 if (SCM_NCONSP (formals
))
1573 formals
= SCM_CDR (formals
);
1574 args
= SCM_CDR (args
);
1576 return SCM_NNULLP (args
) ? 1 : 0;
1583 scm_eval_args (l
, env
, proc
)
1588 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1589 while (SCM_NIMP (l
))
1594 else if (SCM_CONSP (l
))
1596 if (SCM_IMP (SCM_CAR (l
)))
1597 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1599 res
= EVALCELLCAR (l
, env
);
1601 else if (SCM_TYP3 (l
) == 1)
1603 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1604 res
= SCM_CAR (l
); /* struct planted in code */
1609 res
= EVALCAR (l
, env
);
1611 *lloc
= scm_cons (res
, SCM_EOL
);
1612 lloc
= SCM_CDRLOC (*lloc
);
1619 scm_wrong_num_args (proc
);
1626 scm_eval_body (SCM code
, SCM env
)
1631 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1633 if (SCM_IMP (SCM_CAR (code
)))
1635 if (SCM_ISYMP (SCM_CAR (code
)))
1637 code
= scm_m_expand_body (code
, env
);
1642 SCM_XEVAL (SCM_CAR (code
), env
);
1645 return SCM_XEVALCAR (code
, env
);
1652 /* SECTION: This code is specific for the debugging support. One
1653 * branch is read when DEVAL isn't defined, the other when DEVAL is
1659 #define SCM_APPLY scm_apply
1660 #define PREP_APPLY(proc, args)
1662 #define RETURN(x) return x;
1663 #ifdef STACK_CHECKING
1664 #ifndef NO_CEVAL_STACK_CHECKING
1665 #define EVAL_STACK_CHECKING
1672 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1674 #define SCM_APPLY scm_dapply
1676 #define PREP_APPLY(p, l) \
1677 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1679 #define ENTER_APPLY \
1681 SCM_SET_ARGSREADY (debug);\
1682 if (CHECK_APPLY && SCM_TRAPS_P)\
1683 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1685 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1686 SCM_SET_TRACED_FRAME (debug); \
1687 if (SCM_CHEAPTRAPS_P)\
1689 tmp = scm_make_debugobj (&debug);\
1690 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1694 scm_make_cont (&tmp);\
1695 if (!setjmp (SCM_JMPBUF (tmp)))\
1696 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1701 #define RETURN(e) {proc = (e); goto exit;}
1702 #ifdef STACK_CHECKING
1703 #ifndef EVAL_STACK_CHECKING
1704 #define EVAL_STACK_CHECKING
1708 /* scm_ceval_ptr points to the currently selected evaluator.
1709 * *fixme*: Although efficiency is important here, this state variable
1710 * should probably not be a global. It should be related to the
1715 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1717 /* scm_last_debug_frame contains a pointer to the last debugging
1718 * information stack frame. It is accessed very often from the
1719 * debugging evaluator, so it should probably not be indirectly
1720 * addressed. Better to save and restore it from the current root at
1725 scm_debug_frame
*scm_last_debug_frame
;
1728 /* scm_debug_eframe_size is the number of slots available for pseudo
1729 * stack frames at each real stack frame.
1732 int scm_debug_eframe_size
;
1734 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1738 scm_option scm_eval_opts
[] = {
1739 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1742 scm_option scm_debug_opts
[] = {
1743 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1744 "*Flyweight representation of the stack at traps." },
1745 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1746 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1747 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1748 "Record procedure names at definition." },
1749 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1750 "Display backtrace in anti-chronological order." },
1751 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1752 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1753 { SCM_OPTION_INTEGER
, "frames", 3,
1754 "Maximum number of tail-recursive frames in backtrace." },
1755 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1756 "Maximal number of stored backtrace frames." },
1757 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1758 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1759 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1760 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1763 scm_option scm_evaluator_trap_table
[] = {
1764 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1765 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1766 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1767 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1770 GUILE_PROC (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1773 #define FUNC_NAME s_scm_eval_options_interface
1777 ans
= scm_options (setting
,
1781 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1787 GUILE_PROC (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1790 #define FUNC_NAME s_scm_evaluator_traps
1794 ans
= scm_options (setting
,
1795 scm_evaluator_trap_table
,
1796 SCM_N_EVALUATOR_TRAPS
,
1798 SCM_RESET_DEBUG_MODE
;
1805 scm_deval_args (l
, env
, proc
, lloc
)
1806 SCM l
, env
, proc
, *lloc
;
1808 SCM
*results
= lloc
, res
;
1809 while (SCM_NIMP (l
))
1814 else if (SCM_CONSP (l
))
1816 if (SCM_IMP (SCM_CAR (l
)))
1817 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1819 res
= EVALCELLCAR (l
, env
);
1821 else if (SCM_TYP3 (l
) == 1)
1823 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1824 res
= SCM_CAR (l
); /* struct planted in code */
1829 res
= EVALCAR (l
, env
);
1831 *lloc
= scm_cons (res
, SCM_EOL
);
1832 lloc
= SCM_CDRLOC (*lloc
);
1839 scm_wrong_num_args (proc
);
1848 /* SECTION: Some local definitions for the evaluator.
1853 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1855 #define CHECK_EQVISH(A,B) ((A) == (B))
1859 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1861 /* SECTION: This is the evaluator. Like any real monster, it has
1862 * three heads. This code is compiled twice.
1868 scm_ceval (SCM x
, SCM env
)
1874 scm_deval (SCM x
, SCM env
)
1879 SCM_CEVAL (SCM x
, SCM env
)
1888 scm_debug_frame debug
;
1889 scm_debug_info
*debug_info_end
;
1890 debug
.prev
= scm_last_debug_frame
;
1891 debug
.status
= scm_debug_eframe_size
;
1893 * The debug.vect contains twice as much scm_debug_info frames as the
1894 * user has specified with (debug-set! frames <n>).
1896 * Even frames are eval frames, odd frames are apply frames.
1898 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1899 * sizeof (debug
.vect
[0]));
1900 debug
.info
= debug
.vect
;
1901 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1902 scm_last_debug_frame
= &debug
;
1904 #ifdef EVAL_STACK_CHECKING
1905 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1906 && scm_stack_checking_enabled_p
)
1909 debug
.info
->e
.exp
= x
;
1910 debug
.info
->e
.env
= env
;
1912 scm_report_stack_overflow ();
1919 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1922 SCM_CLEAR_ARGSREADY (debug
);
1923 if (SCM_OVERFLOWP (debug
))
1926 * In theory, this should be the only place where it is necessary to
1927 * check for space in debug.vect since both eval frames and
1928 * available space are even.
1930 * For this to be the case, however, it is necessary that primitive
1931 * special forms which jump back to `loop', `begin' or some similar
1932 * label call PREP_APPLY. A convenient way to do this is to jump to
1933 * `loopnoap' or `cdrxnoap'.
1935 else if (++debug
.info
>= debug_info_end
)
1937 SCM_SET_OVERFLOW (debug
);
1941 debug
.info
->e
.exp
= x
;
1942 debug
.info
->e
.env
= env
;
1943 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1944 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1946 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1947 SCM_SET_TAILREC (debug
);
1948 if (SCM_CHEAPTRAPS_P
)
1949 t
.arg1
= scm_make_debugobj (&debug
);
1952 scm_make_cont (&t
.arg1
);
1953 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1955 x
= SCM_THROW_VALUE (t
.arg1
);
1961 /* This gives the possibility for the debugger to
1962 modify the source expression before evaluation. */
1966 scm_ithrow (scm_sym_enter_frame
,
1967 scm_cons2 (t
.arg1
, tail
,
1968 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1972 #if defined (USE_THREADS) || defined (DEVAL)
1976 switch (SCM_TYP7 (x
))
1978 case scm_tcs_symbols
:
1979 /* Only happens when called at top level.
1981 x
= scm_cons (x
, SCM_UNDEFINED
);
1984 case (127 & SCM_IM_AND
):
1987 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1988 if (SCM_FALSEP (EVALCAR (x
, env
)))
1990 RETURN (SCM_BOOL_F
);
1994 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1997 case (127 & SCM_IM_BEGIN
):
1999 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2005 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2007 if (SCM_IMP (SCM_CAR (x
)))
2009 if (SCM_ISYMP (SCM_CAR (x
)))
2011 x
= scm_m_expand_body (x
, env
);
2016 SCM_CEVAL (SCM_CAR (x
), env
);
2020 carloop
: /* scm_eval car of last form in list */
2021 if (SCM_NCELLP (SCM_CAR (x
)))
2024 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
2027 if (SCM_SYMBOLP (SCM_CAR (x
)))
2030 RETURN (*scm_lookupcar (x
, env
, 1))
2034 goto loop
; /* tail recurse */
2037 case (127 & SCM_IM_CASE
):
2039 t
.arg1
= EVALCAR (x
, env
);
2040 while (SCM_NIMP (x
= SCM_CDR (x
)))
2043 if (scm_sym_else
== SCM_CAR (proc
))
2046 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2049 proc
= SCM_CAR (proc
);
2050 while (SCM_NIMP (proc
))
2052 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2054 x
= SCM_CDR (SCM_CAR (x
));
2055 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2058 proc
= SCM_CDR (proc
);
2061 RETURN (SCM_UNSPECIFIED
)
2064 case (127 & SCM_IM_COND
):
2065 while (SCM_NIMP (x
= SCM_CDR (x
)))
2068 t
.arg1
= EVALCAR (proc
, env
);
2069 if (SCM_NFALSEP (t
.arg1
))
2076 if (scm_sym_arrow
!= SCM_CAR (x
))
2078 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2082 proc
= EVALCAR (proc
, env
);
2083 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2084 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2089 RETURN (SCM_UNSPECIFIED
)
2092 case (127 & SCM_IM_DO
):
2094 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2095 t
.arg1
= SCM_EOL
; /* values */
2096 while (SCM_NIMP (proc
))
2098 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2099 proc
= SCM_CDR (proc
);
2101 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2102 x
= SCM_CDR (SCM_CDR (x
));
2103 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2105 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2107 t
.arg1
= SCM_CAR (proc
); /* body */
2108 SIDEVAL (t
.arg1
, env
);
2110 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2112 proc
= SCM_CDR (proc
))
2113 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2114 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2118 RETURN (SCM_UNSPECIFIED
);
2119 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2123 case (127 & SCM_IM_IF
):
2125 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2127 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2129 RETURN (SCM_UNSPECIFIED
);
2131 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2135 case (127 & SCM_IM_LET
):
2137 proc
= SCM_CAR (SCM_CDR (x
));
2141 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2143 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2144 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2149 case (127 & SCM_IM_LETREC
):
2151 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2157 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2159 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2160 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2164 case (127 & SCM_IM_LETSTAR
):
2169 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2174 t
.arg1
= SCM_CAR (proc
);
2175 proc
= SCM_CDR (proc
);
2176 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2178 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2181 case (127 & SCM_IM_OR
):
2184 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2186 x
= EVALCAR (x
, env
);
2187 if (SCM_NFALSEP (x
))
2193 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2197 case (127 & SCM_IM_LAMBDA
):
2198 RETURN (scm_closure (SCM_CDR (x
), env
));
2201 case (127 & SCM_IM_QUOTE
):
2202 RETURN (SCM_CAR (SCM_CDR (x
)));
2205 case (127 & SCM_IM_SET_X
):
2208 switch (7 & (int) proc
)
2211 t
.lloc
= scm_lookupcar (x
, env
, 1);
2214 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2216 #ifdef MEMOIZE_LOCALS
2218 t
.lloc
= scm_ilookup (proc
, env
);
2223 *t
.lloc
= EVALCAR (x
, env
);
2227 RETURN (SCM_UNSPECIFIED
);
2231 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
2232 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2234 /* new syntactic forms go here. */
2235 case (127 & SCM_MAKISYM (0)):
2237 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2238 switch SCM_ISYMNUM (proc
)
2241 case (SCM_ISYMNUM (IM_VREF
)):
2244 var
= SCM_CAR (SCM_CDR (x
));
2245 RETURN (SCM_CDR(var
));
2247 case (SCM_ISYMNUM (IM_VSET
)):
2248 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2249 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2250 RETURN (SCM_UNSPECIFIED
)
2253 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2255 proc
= EVALCAR (proc
, env
);
2256 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2257 if (SCM_CLOSUREP (proc
))
2260 PREP_APPLY (proc
, SCM_EOL
);
2261 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2262 t
.arg1
= EVALCAR (t
.arg1
, env
);
2264 debug
.info
->a
.args
= t
.arg1
;
2266 #ifndef SCM_RECKLESS
2267 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2271 /* Copy argument list */
2272 if (SCM_IMP (t
.arg1
))
2276 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2277 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2278 && SCM_CONSP (t
.arg1
))
2280 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2284 SCM_SETCDR (tl
, t
.arg1
);
2287 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2288 x
= SCM_CODE (proc
);
2294 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2295 scm_make_cont (&t
.arg1
);
2296 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2299 val
= SCM_THROW_VALUE (t
.arg1
);
2303 proc
= evalcar (proc
, env
);
2304 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2305 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2309 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2310 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2312 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2313 proc
= SCM_CADR (x
); /* unevaluated operands */
2314 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2316 arg2
= *scm_ilookup (proc
, env
);
2317 else if (SCM_NCONSP (proc
))
2319 if (SCM_NCELLP (proc
))
2320 arg2
= SCM_GLOC_VAL (proc
);
2322 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2326 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2327 t
.lloc
= SCM_CDRLOC (arg2
);
2328 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2330 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2331 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2336 /* The type dispatch code is duplicated here
2337 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2338 * cuts down execution time for type dispatch to 50%.
2341 int i
, n
, end
, mask
;
2342 SCM z
= SCM_CDDR (x
);
2343 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2344 proc
= SCM_CADR (z
);
2346 if (SCM_NIMP (proc
))
2348 /* Prepare for linear search */
2351 end
= SCM_LENGTH (proc
);
2355 /* Compute a hash value */
2356 int hashset
= SCM_INUM (proc
);
2358 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2359 proc
= SCM_CADR (z
);
2362 if (SCM_NIMP (t
.arg1
))
2365 i
+= (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2366 [scm_si_hashsets
+ hashset
]);
2367 t
.arg1
= SCM_CDR (t
.arg1
);
2369 while (--j
&& SCM_NIMP (t
.arg1
));
2374 /* Search for match */
2378 z
= SCM_VELTS (proc
)[i
];
2379 t
.arg1
= arg2
; /* list of arguments */
2380 if (SCM_NIMP (t
.arg1
))
2383 /* More arguments than specifiers => CLASS != ENV */
2384 if (scm_class_of (SCM_CAR (t
.arg1
)) != SCM_CAR (z
))
2386 t
.arg1
= SCM_CDR (t
.arg1
);
2389 while (--j
&& SCM_NIMP (t
.arg1
));
2390 /* Fewer arguments than specifiers => CAR != ENV */
2391 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2394 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2396 SCM_CMETHOD_ENV (z
));
2397 x
= SCM_CMETHOD_CODE (z
);
2403 z
= scm_memoize_method (x
, arg2
);
2407 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2409 t
.arg1
= EVALCAR (x
, env
);
2410 RETURN (SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CADR (x
))]);
2412 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2414 t
.arg1
= EVALCAR (x
, env
);
2417 SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CAR (x
))]
2418 = EVALCAR (proc
, env
);
2419 RETURN (SCM_UNSPECIFIED
);
2421 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2423 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2425 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2426 || t
.arg1
== scm_nil
))
2428 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2430 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2436 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2439 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2441 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2445 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2447 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_t
: scm_nil
)
2449 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2451 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2453 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2454 || t
.arg1
== SCM_INUM0
))
2456 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2458 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2464 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2467 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2469 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2473 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2475 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2479 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2482 t
.arg1
= SCM_CAR (x
);
2483 arg2
= SCM_CDAR (env
);
2484 while (SCM_NIMP (arg2
))
2486 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2487 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2488 SCM_SETCAR (arg2
, proc
);
2489 t
.arg1
= SCM_CDR (t
.arg1
);
2490 arg2
= SCM_CDR (arg2
);
2492 t
.arg1
= SCM_CAR (x
);
2493 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2495 arg2
= x
= SCM_CDR (x
);
2496 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2498 SIDEVAL (SCM_CAR (x
), env
);
2501 proc
= EVALCAR (x
, env
);
2503 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2504 arg2
= SCM_CDAR (env
);
2505 while (SCM_NIMP (arg2
))
2507 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2508 t
.arg1
= SCM_CDR (t
.arg1
);
2509 arg2
= SCM_CDR (arg2
);
2521 /* scm_everr (x, env,...) */
2522 scm_misc_error (NULL
,
2523 "Wrong type to apply: %S",
2524 scm_listify (proc
, SCM_UNDEFINED
));
2525 case scm_tc7_vector
:
2529 case scm_tc7_byvect
:
2536 #ifdef HAVE_LONG_LONGS
2537 case scm_tc7_llvect
:
2540 case scm_tc7_string
:
2541 case scm_tc7_substring
:
2543 case scm_tcs_closures
:
2551 #ifdef MEMOIZE_LOCALS
2552 case (127 & SCM_ILOC00
):
2553 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2554 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2555 #ifndef SCM_RECKLESS
2561 #endif /* ifdef MEMOIZE_LOCALS */
2564 case scm_tcs_cons_gloc
:
2565 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2567 /* This is a struct implanted in the code, not a gloc. */
2569 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2570 #ifndef SCM_RECKLESS
2578 case scm_tcs_cons_nimcar
:
2579 if (SCM_SYMBOLP (SCM_CAR (x
)))
2582 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2585 /* we have lost the race, start again. */
2590 proc
= *scm_lookupcar (x
, env
, 1);
2598 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2604 /* Set a flag during macro expansion so that macro
2605 application frames can be deleted from the backtrace. */
2606 SCM_SET_MACROEXP (debug
);
2608 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2609 scm_cons (env
, scm_listofnull
));
2612 SCM_CLEAR_MACROEXP (debug
);
2614 switch ((int) (SCM_CAR (proc
) >> 16))
2617 if (scm_ilength (t
.arg1
) <= 0)
2618 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2620 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2623 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2624 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2625 /* Prevent memoizing result of define macro */
2627 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2628 scm_set_source_properties_x (debug
.info
->e
.exp
,
2629 scm_source_properties (x
));
2633 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2634 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2638 /* Prevent memoizing of debug info expression. */
2639 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2644 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2645 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2649 if (SCM_NIMP (x
= t
.arg1
))
2657 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2658 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2659 #ifndef SCM_RECKLESS
2663 if (SCM_CLOSUREP (proc
))
2665 arg2
= SCM_CAR (SCM_CODE (proc
));
2666 t
.arg1
= SCM_CDR (x
);
2667 while (SCM_NIMP (arg2
))
2669 if (SCM_NCONSP (arg2
))
2671 if (SCM_IMP (t
.arg1
))
2672 goto umwrongnumargs
;
2673 arg2
= SCM_CDR (arg2
);
2674 t
.arg1
= SCM_CDR (t
.arg1
);
2676 if (SCM_NNULLP (t
.arg1
))
2677 goto umwrongnumargs
;
2679 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2680 goto handle_a_macro
;
2686 PREP_APPLY (proc
, SCM_EOL
);
2687 if (SCM_NULLP (SCM_CDR (x
))) {
2690 switch (SCM_TYP7 (proc
))
2691 { /* no arguments given */
2692 case scm_tc7_subr_0
:
2693 RETURN (SCM_SUBRF (proc
) ());
2694 case scm_tc7_subr_1o
:
2695 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2697 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2698 case scm_tc7_rpsubr
:
2699 RETURN (SCM_BOOL_T
);
2701 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2705 proc
= SCM_CCLO_SUBR (proc
);
2707 debug
.info
->a
.proc
= proc
;
2708 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2713 proc
= SCM_PROCEDURE (proc
);
2715 debug
.info
->a
.proc
= proc
;
2718 case scm_tcs_closures
:
2719 x
= SCM_CODE (proc
);
2720 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2722 case scm_tcs_cons_gloc
:
2723 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2725 x
= SCM_ENTITY_PROCEDURE (proc
);
2729 else if (!SCM_I_OPERATORP (proc
))
2734 proc
= (SCM_I_ENTITYP (proc
)
2735 ? SCM_ENTITY_PROCEDURE (proc
)
2736 : SCM_OPERATOR_PROCEDURE (proc
));
2738 debug
.info
->a
.proc
= proc
;
2739 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2741 if (SCM_NIMP (proc
))
2746 case scm_tc7_contin
:
2747 case scm_tc7_subr_1
:
2748 case scm_tc7_subr_2
:
2749 case scm_tc7_subr_2o
:
2751 case scm_tc7_subr_3
:
2752 case scm_tc7_lsubr_2
:
2756 /* scm_everr (x, env,...) */
2757 scm_wrong_num_args (proc
);
2759 /* handle macros here */
2764 /* must handle macros by here */
2769 else if (SCM_CONSP (x
))
2771 if (SCM_IMP (SCM_CAR (x
)))
2772 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2774 t
.arg1
= EVALCELLCAR (x
, env
);
2776 else if (SCM_TYP3 (x
) == 1)
2778 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2779 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2784 t
.arg1
= EVALCAR (x
, env
);
2787 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2794 switch (SCM_TYP7 (proc
))
2795 { /* have one argument in t.arg1 */
2796 case scm_tc7_subr_2o
:
2797 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2798 case scm_tc7_subr_1
:
2799 case scm_tc7_subr_1o
:
2800 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2803 if (SCM_SUBRF (proc
))
2805 if (SCM_INUMP (t
.arg1
))
2807 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2810 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2811 if (SCM_REALP (t
.arg1
))
2813 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2816 if (SCM_BIGP (t
.arg1
))
2818 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2822 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2823 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2826 proc
= (SCM
) SCM_SNAME (proc
);
2828 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2829 while ('c' != *--chrs
)
2831 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2832 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2833 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2837 case scm_tc7_rpsubr
:
2838 RETURN (SCM_BOOL_T
);
2840 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2843 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2845 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2851 proc
= SCM_CCLO_SUBR (proc
);
2853 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2854 debug
.info
->a
.proc
= proc
;
2859 proc
= SCM_PROCEDURE (proc
);
2861 debug
.info
->a
.proc
= proc
;
2864 case scm_tcs_closures
:
2866 x
= SCM_CODE (proc
);
2868 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2870 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2873 case scm_tc7_contin
:
2874 scm_call_continuation (proc
, t
.arg1
);
2875 case scm_tcs_cons_gloc
:
2876 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2878 x
= SCM_ENTITY_PROCEDURE (proc
);
2880 arg2
= debug
.info
->a
.args
;
2882 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2886 else if (!SCM_I_OPERATORP (proc
))
2892 proc
= (SCM_I_ENTITYP (proc
)
2893 ? SCM_ENTITY_PROCEDURE (proc
)
2894 : SCM_OPERATOR_PROCEDURE (proc
));
2896 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2897 debug
.info
->a
.proc
= proc
;
2899 if (SCM_NIMP (proc
))
2904 case scm_tc7_subr_2
:
2905 case scm_tc7_subr_0
:
2906 case scm_tc7_subr_3
:
2907 case scm_tc7_lsubr_2
:
2916 else if (SCM_CONSP (x
))
2918 if (SCM_IMP (SCM_CAR (x
)))
2919 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2921 arg2
= EVALCELLCAR (x
, env
);
2923 else if (SCM_TYP3 (x
) == 1)
2925 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2926 arg2
= SCM_CAR (x
); /* struct planted in code */
2931 arg2
= EVALCAR (x
, env
);
2933 { /* have two or more arguments */
2935 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2938 if (SCM_NULLP (x
)) {
2943 switch (SCM_TYP7 (proc
))
2944 { /* have two arguments */
2945 case scm_tc7_subr_2
:
2946 case scm_tc7_subr_2o
:
2947 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2950 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2952 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2954 case scm_tc7_lsubr_2
:
2955 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2956 case scm_tc7_rpsubr
:
2958 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2963 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2964 scm_cons (proc
, debug
.info
->a
.args
),
2967 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2968 scm_cons2 (proc
, t
.arg1
,
2975 /* case scm_tc7_cclo:
2976 x = scm_cons(arg2, scm_eval_args(x, env));
2979 proc = SCM_CCLO_SUBR(proc);
2983 proc
= SCM_PROCEDURE (proc
);
2985 debug
.info
->a
.proc
= proc
;
2988 case scm_tcs_cons_gloc
:
2989 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2991 x
= SCM_ENTITY_PROCEDURE (proc
);
2993 arg2
= debug
.info
->a
.args
;
2995 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2999 else if (!SCM_I_OPERATORP (proc
))
3005 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3006 ? SCM_ENTITY_PROCEDURE (proc
)
3007 : SCM_OPERATOR_PROCEDURE (proc
),
3008 scm_cons (proc
, debug
.info
->a
.args
),
3011 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3012 ? SCM_ENTITY_PROCEDURE (proc
)
3013 : SCM_OPERATOR_PROCEDURE (proc
),
3014 scm_cons2 (proc
, t
.arg1
,
3022 case scm_tc7_subr_0
:
3024 case scm_tc7_subr_1o
:
3025 case scm_tc7_subr_1
:
3026 case scm_tc7_subr_3
:
3027 case scm_tc7_contin
:
3031 case scm_tcs_closures
:
3034 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3038 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3039 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
3041 x
= SCM_CODE (proc
);
3046 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3050 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3051 scm_deval_args (x
, env
, proc
,
3052 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3056 switch (SCM_TYP7 (proc
))
3057 { /* have 3 or more arguments */
3059 case scm_tc7_subr_3
:
3060 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3061 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3062 SCM_CADDR (debug
.info
->a
.args
)));
3064 #ifdef BUILTIN_RPASUBR
3065 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3066 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3069 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3070 arg2
= SCM_CDR (arg2
);
3072 while (SCM_NIMP (arg2
));
3074 #endif /* BUILTIN_RPASUBR */
3075 case scm_tc7_rpsubr
:
3076 #ifdef BUILTIN_RPASUBR
3077 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3079 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3082 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3084 arg2
= SCM_CAR (t
.arg1
);
3085 t
.arg1
= SCM_CDR (t
.arg1
);
3087 while (SCM_NIMP (t
.arg1
));
3089 #else /* BUILTIN_RPASUBR */
3090 RETURN (SCM_APPLY (proc
, t
.arg1
,
3092 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3094 #endif /* BUILTIN_RPASUBR */
3095 case scm_tc7_lsubr_2
:
3096 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3097 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3099 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3105 proc
= SCM_PROCEDURE (proc
);
3106 debug
.info
->a
.proc
= proc
;
3108 case scm_tcs_closures
:
3109 SCM_SET_ARGSREADY (debug
);
3110 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3113 x
= SCM_CODE (proc
);
3116 case scm_tc7_subr_3
:
3117 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3118 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3120 #ifdef BUILTIN_RPASUBR
3121 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3124 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3127 while (SCM_NIMP (x
));
3129 #endif /* BUILTIN_RPASUBR */
3130 case scm_tc7_rpsubr
:
3131 #ifdef BUILTIN_RPASUBR
3132 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3136 t
.arg1
= EVALCAR (x
, env
);
3137 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3142 while (SCM_NIMP (x
));
3144 #else /* BUILTIN_RPASUBR */
3145 RETURN (SCM_APPLY (proc
, t
.arg1
,
3147 scm_eval_args (x
, env
, proc
),
3149 #endif /* BUILTIN_RPASUBR */
3150 case scm_tc7_lsubr_2
:
3151 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3153 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3155 scm_eval_args (x
, env
, proc
))));
3161 proc
= SCM_PROCEDURE (proc
);
3163 case scm_tcs_closures
:
3165 SCM_SET_ARGSREADY (debug
);
3167 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3170 scm_eval_args (x
, env
, proc
)),
3172 x
= SCM_CODE (proc
);
3175 case scm_tcs_cons_gloc
:
3176 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3179 arg2
= debug
.info
->a
.args
;
3181 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3183 x
= SCM_ENTITY_PROCEDURE (proc
);
3186 else if (!SCM_I_OPERATORP (proc
))
3190 case scm_tc7_subr_2
:
3191 case scm_tc7_subr_1o
:
3192 case scm_tc7_subr_2o
:
3193 case scm_tc7_subr_0
:
3195 case scm_tc7_subr_1
:
3196 case scm_tc7_contin
:
3204 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3205 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3207 SCM_CLEAR_TRACED_FRAME (debug
);
3208 if (SCM_CHEAPTRAPS_P
)
3209 t
.arg1
= scm_make_debugobj (&debug
);
3212 scm_make_cont (&t
.arg1
);
3213 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3215 proc
= SCM_THROW_VALUE (t
.arg1
);
3219 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3222 scm_last_debug_frame
= debug
.prev
;
3228 /* SECTION: This code is compiled once.
3233 /* This code processes the arguments to apply:
3235 (apply PROC ARG1 ... ARGS)
3237 Given a list (ARG1 ... ARGS), this function conses the ARG1
3238 ... arguments onto the front of ARGS, and returns the resulting
3239 list. Note that ARGS is a list; thus, the argument to this
3240 function is a list whose last element is a list.
3242 Apply calls this function, and applies PROC to the elements of the
3243 result. apply:nconc2last takes care of building the list of
3244 arguments, given (ARG1 ... ARGS).
3246 Rather than do new consing, apply:nconc2last destroys its argument.
3247 On that topic, this code came into my care with the following
3248 beautifully cryptic comment on that topic: "This will only screw
3249 you if you do (scm_apply scm_apply '( ... ))" If you know what
3250 they're referring to, send me a patch to this comment. */
3252 GUILE_PROC(scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3255 #define FUNC_NAME s_scm_nconc2last
3258 SCM_VALIDATE_LIST(1,lst
);
3260 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3261 lloc
= SCM_CDRLOC (*lloc
);
3262 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3263 *lloc
= SCM_CAR (*lloc
);
3271 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3272 * It is compiled twice.
3278 scm_apply (proc
, arg1
, args
)
3288 scm_dapply (proc
, arg1
, args
)
3296 /* Apply a function to a list of arguments.
3298 This function is exported to the Scheme level as taking two
3299 required arguments and a tail argument, as if it were:
3300 (lambda (proc arg1 . args) ...)
3301 Thus, if you just have a list of arguments to pass to a procedure,
3302 pass the list as ARG1, and '() for ARGS. If you have some fixed
3303 args, pass the first as ARG1, then cons any remaining fixed args
3304 onto the front of your argument list, and pass that as ARGS. */
3307 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3309 #ifdef DEBUG_EXTENSIONS
3311 scm_debug_frame debug
;
3312 scm_debug_info debug_vect_body
;
3313 debug
.prev
= scm_last_debug_frame
;
3314 debug
.status
= SCM_APPLYFRAME
;
3315 debug
.vect
= &debug_vect_body
;
3316 debug
.vect
[0].a
.proc
= proc
;
3317 debug
.vect
[0].a
.args
= SCM_EOL
;
3318 scm_last_debug_frame
= &debug
;
3321 return scm_dapply (proc
, arg1
, args
);
3325 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3327 /* If ARGS is the empty list, then we're calling apply with only two
3328 arguments --- ARG1 is the list of arguments for PROC. Whatever
3329 the case, futz with things so that ARG1 is the first argument to
3330 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3333 Setting the debug apply frame args this way is pretty messy.
3334 Perhaps we should store arg1 and args directly in the frame as
3335 received, and let scm_frame_arguments unpack them, because that's
3336 a relatively rare operation. This works for now; if the Guile
3337 developer archives are still around, see Mikael's post of
3339 if (SCM_NULLP (args
))
3341 if (SCM_NULLP (arg1
))
3343 arg1
= SCM_UNDEFINED
;
3345 debug
.vect
[0].a
.args
= SCM_EOL
;
3351 debug
.vect
[0].a
.args
= arg1
;
3353 args
= SCM_CDR (arg1
);
3354 arg1
= SCM_CAR (arg1
);
3359 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
3360 args
= scm_nconc2last (args
);
3362 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3366 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3369 if (SCM_CHEAPTRAPS_P
)
3370 tmp
= scm_make_debugobj (&debug
);
3373 scm_make_cont (&tmp
);
3374 if (setjmp (SCM_JMPBUF (tmp
)))
3377 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3385 switch (SCM_TYP7 (proc
))
3387 case scm_tc7_subr_2o
:
3388 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3389 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3390 case scm_tc7_subr_2
:
3391 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3393 args
= SCM_CAR (args
);
3394 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3395 case scm_tc7_subr_0
:
3396 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3397 RETURN (SCM_SUBRF (proc
) ())
3398 case scm_tc7_subr_1
:
3399 case scm_tc7_subr_1o
:
3400 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3401 RETURN (SCM_SUBRF (proc
) (arg1
))
3403 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3405 if (SCM_SUBRF (proc
))
3407 if (SCM_INUMP (arg1
))
3409 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
3411 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3412 if (SCM_REALP (arg1
))
3414 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
3417 if (SCM_BIGP (arg1
))
3418 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
3421 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3422 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3425 proc
= (SCM
) SCM_SNAME (proc
);
3427 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3428 while ('c' != *--chrs
)
3430 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
3431 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3432 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3436 case scm_tc7_subr_3
:
3437 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3440 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3442 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3444 case scm_tc7_lsubr_2
:
3445 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
3446 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3448 if (SCM_NULLP (args
))
3449 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3450 while (SCM_NIMP (args
))
3452 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3453 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3454 args
= SCM_CDR (args
);
3457 case scm_tc7_rpsubr
:
3458 if (SCM_NULLP (args
))
3459 RETURN (SCM_BOOL_T
);
3460 while (SCM_NIMP (args
))
3462 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3463 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3464 RETURN (SCM_BOOL_F
);
3465 arg1
= SCM_CAR (args
);
3466 args
= SCM_CDR (args
);
3468 RETURN (SCM_BOOL_T
);
3469 case scm_tcs_closures
:
3471 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3473 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3475 #ifndef SCM_RECKLESS
3476 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3480 /* Copy argument list */
3485 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3486 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
3487 && SCM_CONSP (arg1
))
3489 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3493 SCM_SETCDR (tl
, arg1
);
3496 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3497 proc
= SCM_CDR (SCM_CODE (proc
));
3500 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3502 if (SCM_IMP (SCM_CAR (proc
)))
3504 if (SCM_ISYMP (SCM_CAR (proc
)))
3506 proc
= scm_m_expand_body (proc
, args
);
3511 SCM_CEVAL (SCM_CAR (proc
), args
);
3514 RETURN (EVALCAR (proc
, args
));
3515 case scm_tc7_contin
:
3516 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3517 scm_call_continuation (proc
, arg1
);
3521 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3523 proc
= SCM_CCLO_SUBR (proc
);
3524 debug
.vect
[0].a
.proc
= proc
;
3525 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3527 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3529 proc
= SCM_CCLO_SUBR (proc
);
3534 proc
= SCM_PROCEDURE (proc
);
3536 debug
.vect
[0].a
.proc
= proc
;
3539 case scm_tcs_cons_gloc
:
3540 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3543 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3545 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3547 RETURN (scm_apply_generic (proc
, args
));
3549 else if (!SCM_I_OPERATORP (proc
))
3554 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3556 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3559 proc
= (SCM_I_ENTITYP (proc
)
3560 ? SCM_ENTITY_PROCEDURE (proc
)
3561 : SCM_OPERATOR_PROCEDURE (proc
));
3563 debug
.vect
[0].a
.proc
= proc
;
3564 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3566 if (SCM_NIMP (proc
))
3572 scm_wrong_num_args (proc
);
3575 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3580 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3581 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3583 SCM_CLEAR_TRACED_FRAME (debug
);
3584 if (SCM_CHEAPTRAPS_P
)
3585 arg1
= scm_make_debugobj (&debug
);
3588 scm_make_cont (&arg1
);
3589 if (setjmp (SCM_JMPBUF (arg1
)))
3591 proc
= SCM_THROW_VALUE (arg1
);
3595 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3598 scm_last_debug_frame
= debug
.prev
;
3604 /* SECTION: The rest of this file is only read once.
3609 /* Typechecking for multi-argument MAP and FOR-EACH.
3611 Verify that each element of the vector ARGV, except for the first,
3612 is a proper list whose length is LEN. Attribute errors to WHO,
3613 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3615 check_map_args (SCM argv
,
3622 SCM
*ve
= SCM_VELTS (argv
);
3625 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3627 int elt_len
= scm_ilength (ve
[i
]);
3632 scm_apply_generic (gf
, scm_cons (proc
, args
));
3634 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3638 scm_out_of_range (who
, ve
[i
]);
3641 scm_remember (&argv
);
3645 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3647 /* Note: Currently, scm_map applies PROC to the argument list(s)
3648 sequentially, starting with the first element(s). This is used in
3649 evalext.c where the Scheme procedure `serial-map', which guarantees
3650 sequential behaviour, is implemented using scm_map. If the
3651 behaviour changes, we need to update `serial-map'.
3655 scm_map (SCM proc
, SCM arg1
, SCM args
)
3660 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3662 if (SCM_NULLP (arg1
))
3664 len
= scm_ilength (arg1
);
3665 SCM_GASSERTn (len
>= 0,
3666 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3667 if (SCM_NULLP (args
))
3669 while (SCM_NIMP (arg1
))
3671 SCM_GASSERT2 (SCM_CONSP (arg1
), g_map
, proc
, arg1
, SCM_ARG2
, s_map
);
3672 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3674 pres
= SCM_CDRLOC (*pres
);
3675 arg1
= SCM_CDR (arg1
);
3679 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3680 ve
= SCM_VELTS (args
);
3681 #ifndef SCM_RECKLESS
3682 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3687 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3689 if (SCM_IMP (ve
[i
]))
3691 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3692 ve
[i
] = SCM_CDR (ve
[i
]);
3694 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3695 pres
= SCM_CDRLOC (*pres
);
3700 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3703 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3705 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3708 return SCM_UNSPECIFIED
;
3709 len
= scm_ilength (arg1
);
3710 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3711 SCM_ARG2
, s_for_each
);
3714 while SCM_NIMP (arg1
)
3716 SCM_GASSERT2 (SCM_CONSP (arg1
),
3717 g_for_each
, proc
, arg1
, SCM_ARG2
, s_for_each
);
3718 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3719 arg1
= SCM_CDR (arg1
);
3721 return SCM_UNSPECIFIED
;
3723 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3724 ve
= SCM_VELTS (args
);
3725 #ifndef SCM_RECKLESS
3726 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3731 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3734 (ve
[i
]) return SCM_UNSPECIFIED
;
3735 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3736 ve
[i
] = SCM_CDR (ve
[i
]);
3738 scm_apply (proc
, arg1
, SCM_EOL
);
3745 scm_closure (code
, env
)
3751 SCM_SETCODE (z
, code
);
3752 SCM_SETENV (z
, env
);
3757 long scm_tc16_promise
;
3763 SCM_RETURN_NEWSMOB (scm_tc16_promise
, code
);
3769 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3771 int writingp
= SCM_WRITINGP (pstate
);
3772 scm_puts ("#<promise ", port
);
3773 SCM_SET_WRITINGP (pstate
, 1);
3774 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3775 SCM_SET_WRITINGP (pstate
, writingp
);
3776 scm_putc ('>', port
);
3781 GUILE_PROC(scm_force
, "force", 1, 0, 0,
3784 #define FUNC_NAME s_scm_force
3786 SCM_VALIDATE_SMOB(1,x
,promise
);
3787 if (!((1L << 16) & SCM_CAR (x
)))
3789 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3790 if (!((1L << 16) & SCM_CAR (x
)))
3793 SCM_SETCDR (x
, ans
);
3794 SCM_SETOR_CAR (x
, (1L << 16));
3802 GUILE_PROC (scm_promise_p
, "promise?", 1, 0, 0,
3805 #define FUNC_NAME s_scm_promise_p
3807 return SCM_BOOL(SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
));
3811 GUILE_PROC (scm_cons_source
, "cons-source", 3, 0, 0,
3812 (SCM xorig
, SCM x
, SCM y
),
3814 #define FUNC_NAME s_scm_cons_source
3820 /* Copy source properties possibly associated with xorig. */
3821 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3823 scm_whash_insert (scm_source_whash
, z
, p
);
3828 GUILE_PROC (scm_copy_tree
, "copy-tree", 1, 0, 0,
3831 #define FUNC_NAME s_scm_copy_tree
3836 if (SCM_VECTORP (obj
))
3838 scm_sizet i
= SCM_LENGTH (obj
);
3839 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3841 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3844 if (SCM_NCONSP (obj
))
3846 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3847 ans
= tl
= scm_cons_source (obj
,
3848 scm_copy_tree (SCM_CAR (obj
)),
3850 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3852 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3856 SCM_SETCDR (tl
, obj
);
3863 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3865 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3866 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3868 obj
= scm_copy_tree (obj
);
3869 return SCM_XEVAL (obj
, env
);
3872 GUILE_PROC(scm_eval2
, "eval2", 2, 0, 0,
3873 (SCM obj
, SCM env_thunk
),
3875 #define FUNC_NAME s_scm_eval2
3877 return scm_eval_3 (obj
, 1, scm_top_level_env (env_thunk
));
3881 GUILE_PROC(scm_eval
, "eval", 1, 0, 0,
3884 #define FUNC_NAME s_scm_eval
3886 return scm_eval_3 (obj
,
3889 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3894 SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
3898 scm_eval_x (SCM obj
)
3900 return scm_eval_3 (obj
,
3903 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3907 /* At this point, scm_deval and scm_dapply are generated.
3910 #ifdef DEBUG_EXTENSIONS
3920 scm_init_opts (scm_evaluator_traps
,
3921 scm_evaluator_trap_table
,
3922 SCM_N_EVALUATOR_TRAPS
);
3923 scm_init_opts (scm_eval_options_interface
,
3925 SCM_N_EVAL_OPTIONS
);
3927 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3928 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3929 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3931 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3932 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3933 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3934 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3935 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3936 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3937 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3939 scm_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3940 SCM_SETCDR (scm_nil
, SCM_CAR (scm_nil
));
3941 scm_nil
= SCM_CAR (scm_nil
);
3942 scm_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3943 SCM_SETCDR (scm_t
, SCM_CAR (scm_t
));
3944 scm_t
= SCM_CAR (scm_t
);
3949 scm_top_level_lookup_closure_var
=
3950 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3951 scm_can_use_top_level_lookup_closure_var
= 1;
3953 #ifdef DEBUG_EXTENSIONS
3954 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3955 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3956 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3957 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3962 scm_add_feature ("delay");