1 /* Copyright (C) 1995,1996,1997,1998 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"
98 /* The evaluator contains a plethora of EVAL symbols.
99 * This is an attempt at explanation.
101 * The following macros should be used in code which is read twice
102 * (where the choice of evaluator is hard soldered):
104 * SCM_CEVAL is the symbol used within one evaluator to call itself.
105 * Originally, it is defined to scm_ceval, but is redefined to
106 * scm_deval during the second pass.
108 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
109 * only side effects of expressions matter. All immediates are
112 * SCM_EVALIM is used when it is known that the expression is an
113 * immediate. (This macro never calls an evaluator.)
115 * EVALCAR evaluates the car of an expression.
117 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
118 * car is a lisp cell.
120 * The following macros should be used in code which is read once
121 * (where the choice of evaluator is dynamic):
123 * SCM_XEVAL takes care of immediates without calling an evaluator. It
124 * then calls scm_ceval *or* scm_deval, depending on the debugging
127 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
128 * depending on the debugging mode.
130 * The main motivation for keeping this plethora is efficiency
131 * together with maintainability (=> locality of code).
134 #define SCM_CEVAL scm_ceval
135 #define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env))
137 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
138 ? *scm_lookupcar(x, env) \
139 : SCM_CEVAL(SCM_CAR(x), env))
141 #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
142 ? (SCM_IMP(SCM_CAR(x)) \
143 ? SCM_EVALIM(SCM_CAR(x), env) \
144 : SCM_GLOC_VAL(SCM_CAR(x))) \
145 : EVALCELLCAR(x, env))
147 #define EXTEND_ENV SCM_EXTEND_ENV
149 #ifdef MEMOIZE_LOCALS
152 scm_ilookup (iloc
, env
)
156 register int ir
= SCM_IFRAME (iloc
);
157 register SCM er
= env
;
158 for (; 0 != ir
; --ir
)
161 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
163 if (SCM_ICDRP (iloc
))
164 return SCM_CDRLOC (er
);
165 return SCM_CARLOC (SCM_CDR (er
));
171 /* The Lookup Car Race
174 Memoization of variables and special forms is done while executing
175 the code for the first time. As long as there is only one thread
176 everything is fine, but as soon as two threads execute the same
177 code concurrently `for the first time' they can come into conflict.
179 This memoization includes rewriting variable references into more
180 efficient forms and expanding macros. Furthermore, macro expansion
181 includes `compiling' special forms like `let', `cond', etc. into
182 tree-code instructions.
184 There shouldn't normally be a problem with memoizing local and
185 global variable references (into ilocs and glocs), because all
186 threads will mutate the code in *exactly* the same way and (if I
187 read the C code correctly) it is not possible to observe a half-way
188 mutated cons cell. The lookup procedure can handle this
189 transparently without any critical sections.
191 It is different with macro expansion, because macro expansion
192 happens outside of the lookup procedure and can't be
193 undone. Therefore it can't cope with it. It has to indicate
194 failure when it detects a lost race and hope that the caller can
195 handle it. Luckily, it turns out that this is the case.
197 An example to illustrate this: Suppose that the follwing form will
198 be memoized concurrently by two threads
202 Let's first examine the lookup of X in the body. The first thread
203 decides that it has to find the symbol "x" in the environment and
204 starts to scan it. Then the other thread takes over and actually
205 overtakes the first. It looks up "x" and substitutes an
206 appropriate iloc for it. Now the first thread continues and
207 completes its lookup. It comes to exactly the same conclusions as
208 the second one and could - without much ado - just overwrite the
209 iloc with the same iloc.
211 But let's see what will happen when the race occurs while looking
212 up the symbol "let" at the start of the form. It could happen that
213 the second thread interrupts the lookup of the first thread and not
214 only substitutes a gloc for it but goes right ahead and replaces it
215 with the compiled form (#@let* (x 12) x). Now, when the first
216 thread completes its lookup, it would replace the #@let* with a
217 gloc pointing to the "let" binding, effectively reverting the form
218 to (let (x 12) x). This is wrong. It has to detect that it has
219 lost the race and the evaluator has to reconsider the changed form
222 This race condition could be resolved with some kind of traffic
223 light (like mutexes) around scm_lookupcar, but I think that it is
224 best to avoid them in this case. They would serialize memoization
225 completely and because lookup involves calling arbitrary Scheme
226 code (via the lookup-thunk), threads could be blocked for an
227 arbitrary amount of time or even deadlock. But with the current
228 solution a lot of unnecessary work is potentially done. */
230 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
231 return NULL to indicate a failed lookup due to some race conditions
232 between threads. This only happens when VLOC is the first cell of
233 a special form that will eventually be memoized (like `let', etc.)
234 In that case the whole lookup is bogus and the caller has to
235 reconsider the complete special form.
237 SCM_LOOKUPCAR is still there, of course. It just calls
238 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
239 should only be called when it is known that VLOC is not the first
240 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
241 for NULL. I think I've found the only place where this applies. */
243 #endif /* USE_THREADS */
247 scm_lookupcar1 (SCM vloc
, SCM genv
)
250 scm_lookupcar (SCM vloc
, SCM genv
)
254 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
256 register SCM var2
= var
;
258 #ifdef MEMOIZE_LOCALS
259 register SCM iloc
= SCM_ILOC00
;
261 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
263 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
265 al
= SCM_CARLOC (env
);
266 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
272 #ifdef MEMOIZE_LOCALS
274 if (SCM_CAR (vloc
) != var
)
277 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
279 return SCM_CDRLOC (*al
);
284 al
= SCM_CDRLOC (*al
);
285 if (SCM_CAR (fl
) == var
)
287 #ifdef MEMOIZE_LOCALS
288 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
289 if (SCM_UNBNDP (SCM_CAR (*al
)))
296 if (SCM_CAR (vloc
) != var
)
299 SCM_SETCAR (vloc
, iloc
);
301 return SCM_CARLOC (*al
);
303 #ifdef MEMOIZE_LOCALS
307 #ifdef MEMOIZE_LOCALS
308 iloc
= (~SCM_IDSTMSK
) & (iloc
+ SCM_IFRINC
);
312 SCM top_thunk
, vcell
;
315 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
319 top_thunk
= SCM_BOOL_F
;
320 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
321 if (vcell
== SCM_BOOL_F
)
327 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
331 /* scm_everr (vloc, genv,...) */
332 scm_misc_error (NULL
,
334 ? "Unbound variable: %S"
335 : "Damaged environment: %S",
336 scm_listify (var
, SCM_UNDEFINED
));
340 if (SCM_CAR (vloc
) != var2
)
342 /* Some other thread has changed the very cell we are working
343 on. In effect, it must have done our job or messed it up
346 var
= SCM_CAR (vloc
);
348 return SCM_GLOC_VAL_LOC (var
);
349 #ifdef MEMOIZE_LOCALS
350 if ((var
& 127) == (127 & SCM_ILOC00
))
351 return scm_ilookup (var
, genv
);
353 /* We can't cope with anything else than glocs and ilocs. When
354 a special form has been memoized (i.e. `let' into `#@let') we
355 return NULL and expect the calling function to do the right
356 thing. For the evaluator, this means going back and redoing
357 the dispatch on the car of the form. */
360 #endif /* USE_THREADS */
362 SCM_SETCAR (vloc
, var
+ 1);
363 /* Except wait...what if the var is not a vcell,
364 * but syntax or something.... */
365 return SCM_CDRLOC (var
);
370 scm_lookupcar (vloc
, genv
)
374 SCM
*loc
= scm_lookupcar1 (vloc
, genv
);
381 #define unmemocar scm_unmemocar
384 scm_unmemocar (form
, env
)
388 #ifdef DEBUG_EXTENSIONS
397 SCM_SETCAR (form
, SCM_CAR (c
- 1));
398 #ifdef MEMOIZE_LOCALS
399 #ifdef DEBUG_EXTENSIONS
400 else if (SCM_ILOCP (c
))
402 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
404 env
= SCM_CAR (SCM_CAR (env
));
405 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
407 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
416 scm_eval_car (pair
, env
)
420 return SCM_XEVALCAR (pair
, env
);
425 * The following rewrite expressions and
426 * some memoized forms have different syntax
429 char scm_s_expression
[] = "missing or extra expression";
430 char scm_s_test
[] = "bad test";
431 char scm_s_body
[] = "bad body";
432 char scm_s_bindings
[] = "bad bindings";
433 char scm_s_variable
[] = "bad variable";
434 char scm_s_clauses
[] = "bad or missing clauses";
435 char scm_s_formals
[] = "bad formals";
437 SCM scm_i_dot
, scm_i_quote
, scm_i_quasiquote
, scm_i_lambda
, scm_i_let
,
438 scm_i_arrow
, scm_i_else
, scm_i_unquote
, scm_i_uq_splicing
, scm_i_apply
;
439 SCM scm_i_define
, scm_i_and
, scm_i_begin
, scm_i_case
, scm_i_cond
,
440 scm_i_do
, scm_i_if
, scm_i_let
, scm_i_letrec
, scm_i_letstar
,
441 scm_i_or
, scm_i_set
, scm_i_atapply
, scm_i_atcall_cc
;
442 static char s_quasiquote
[] = "quasiquote";
443 static char s_delay
[] = "delay";
444 #ifdef DEBUG_EXTENSIONS
445 SCM scm_i_enter_frame
, scm_i_apply_frame
, scm_i_exit_frame
;
449 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
453 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, char *what
));
456 bodycheck (xorig
, bodyloc
, what
)
461 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
467 scm_m_quote (xorig
, env
)
471 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
472 xorig
, scm_s_expression
, "quote");
473 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
479 scm_m_begin (xorig
, env
)
483 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
484 xorig
, scm_s_expression
, "begin");
485 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
491 scm_m_if (xorig
, env
)
495 int len
= scm_ilength (SCM_CDR (xorig
));
496 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
497 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
503 scm_m_set (xorig
, env
)
507 SCM x
= SCM_CDR (xorig
);
508 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, "set!");
509 SCM_ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
510 xorig
, scm_s_variable
, "set!");
511 return scm_cons (SCM_IM_SET
, x
);
518 scm_m_vref (xorig
, env
)
522 SCM x
= SCM_CDR (xorig
);
523 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
524 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
526 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
527 scm_misc_error (NULL
,
529 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
531 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
532 xorig
, scm_s_variable
, s_vref
);
534 return scm_cons (IM_VREF
, x
);
540 scm_m_vset (xorig
, env
)
544 SCM x
= SCM_CDR (xorig
);
545 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
546 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
547 || UDSCM_VARIABLEP (SCM_CAR (x
))),
548 xorig
, scm_s_variable
, s_vset
);
549 return scm_cons (IM_VSET
, x
);
556 scm_m_and (xorig
, env
)
560 int len
= scm_ilength (SCM_CDR (xorig
));
561 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, "and");
563 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
571 scm_m_or (xorig
, env
)
575 int len
= scm_ilength (SCM_CDR (xorig
));
576 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, "or");
578 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
586 scm_m_case (xorig
, env
)
590 SCM proc
, x
= SCM_CDR (xorig
);
591 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, "case");
592 while (SCM_NIMP (x
= SCM_CDR (x
)))
595 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, "case");
596 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
597 || scm_i_else
== SCM_CAR (proc
),
598 xorig
, scm_s_clauses
, "case");
600 return scm_cons (SCM_IM_CASE
, SCM_CDR (xorig
));
606 scm_m_cond (xorig
, env
)
610 SCM arg1
, x
= SCM_CDR (xorig
);
611 int len
= scm_ilength (x
);
612 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, "cond");
616 len
= scm_ilength (arg1
);
617 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, "cond");
618 if (scm_i_else
== SCM_CAR (arg1
))
620 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
621 xorig
, "bad ELSE clause", "cond");
622 SCM_SETCAR (arg1
, SCM_BOOL_T
);
624 if (len
>= 2 && scm_i_arrow
== SCM_CAR (SCM_CDR (arg1
)))
625 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
626 xorig
, "bad recipient", "cond");
629 return scm_cons (SCM_IM_COND
, SCM_CDR (xorig
));
635 scm_m_lambda (xorig
, env
)
639 SCM proc
, x
= SCM_CDR (xorig
);
640 if (scm_ilength (x
) < 2)
643 if (SCM_NULLP (proc
))
647 if (SCM_SYMBOLP (proc
))
649 if (SCM_NCONSP (proc
))
651 while (SCM_NIMP (proc
))
653 if (SCM_NCONSP (proc
))
655 if (!SCM_SYMBOLP (proc
))
660 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
662 proc
= SCM_CDR (proc
);
666 badforms
:scm_wta (xorig
, scm_s_formals
, "lambda");
668 bodycheck (xorig
, SCM_CDRLOC (x
), "lambda");
669 return scm_cons (SCM_IM_LAMBDA
, SCM_CDR (xorig
));
675 scm_m_letstar (xorig
, env
)
679 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
680 int len
= scm_ilength (x
);
681 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, "let*");
683 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "let*");
684 while SCM_NIMP (proc
)
686 arg1
= SCM_CAR (proc
);
687 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, "let*");
688 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
689 xorig
, scm_s_variable
, "let*");
690 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
691 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
692 proc
= SCM_CDR (proc
);
694 x
= scm_cons (vars
, SCM_CDR (x
));
695 bodycheck (xorig
, SCM_CDRLOC (x
), "let*");
696 return scm_cons (SCM_IM_LETSTAR
, x
);
699 /* DO gets the most radically altered syntax
700 (do ((<var1> <init1> <step1>)
706 (do_mem (varn ... var2 var1)
707 (<init1> <init2> ... <initn>)
710 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
716 scm_m_do (xorig
, env
)
720 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
721 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
722 SCM
*initloc
= &inits
, *steploc
= &steps
;
723 int len
= scm_ilength (x
);
724 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
726 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
730 arg1
= SCM_CAR (proc
);
731 len
= scm_ilength (arg1
);
732 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
733 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
734 xorig
, scm_s_variable
, "do");
735 /* vars reversed here, inits and steps reversed at evaluation */
736 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
737 arg1
= SCM_CDR (arg1
);
738 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
739 initloc
= SCM_CDRLOC (*initloc
);
740 arg1
= SCM_CDR (arg1
);
741 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
742 steploc
= SCM_CDRLOC (*steploc
);
743 proc
= SCM_CDR (proc
);
746 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
747 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
748 x
= scm_cons2 (vars
, inits
, x
);
749 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
750 return scm_cons (SCM_IM_DO
, x
);
753 /* evalcar is small version of inline EVALCAR when we don't care about
756 #define evalcar scm_eval_car
759 static SCM iqq
SCM_P ((SCM form
, SCM env
, int depth
));
762 iqq (form
, env
, depth
)
771 if (SCM_VECTORP (form
))
773 long i
= SCM_LENGTH (form
);
774 SCM
*data
= SCM_VELTS (form
);
777 tmp
= scm_cons (data
[i
], tmp
);
778 return scm_vector (iqq (tmp
, env
, depth
));
782 tmp
= SCM_CAR (form
);
783 if (scm_i_quasiquote
== tmp
)
788 if (scm_i_unquote
== tmp
)
792 form
= SCM_CDR (form
);
793 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
794 form
, SCM_ARG1
, s_quasiquote
);
796 return evalcar (form
, env
);
797 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
799 if (SCM_NIMP (tmp
) && (scm_i_uq_splicing
== SCM_CAR (tmp
)))
803 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
805 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
808 /* Here are acros which return values rather than code. */
812 scm_m_quasiquote (xorig
, env
)
816 SCM x
= SCM_CDR (xorig
);
817 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
818 return iqq (SCM_CAR (x
), env
, 1);
823 scm_m_delay (xorig
, env
)
827 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
828 xorig
= SCM_CDR (xorig
);
829 return scm_makprom (scm_closure (scm_cons2 (SCM_EOL
, SCM_CAR (xorig
), SCM_CDR (xorig
)),
835 scm_env_top_level (env
)
838 while (SCM_NIMP(env
))
840 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR(env
)))
849 scm_m_define (x
, env
)
855 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
856 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, "define");
859 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
860 { /* nested define syntax */
861 x
= scm_cons (scm_cons2 (scm_i_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
862 proc
= SCM_CAR (proc
);
864 SCM_ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
),
865 arg1
, scm_s_variable
, "define");
866 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, "define");
867 if (SCM_TOP_LEVEL (env
))
869 x
= evalcar (x
, env
);
870 #ifdef DEBUG_EXTENSIONS
871 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
875 if (SCM_CLOSUREP (arg1
)
876 /* Only the first definition determines the name. */
877 && scm_procedure_property (arg1
, scm_i_name
) == SCM_BOOL_F
)
878 scm_set_procedure_property_x (arg1
, scm_i_name
, proc
);
879 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
880 && SCM_CDR (arg1
) != arg1
)
882 arg1
= SCM_CDR (arg1
);
887 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
890 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
891 && (SCM_CDR (arg1
) != x
))
892 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
895 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
896 scm_warn ("redefining ", SCM_CHARS (proc
));
898 SCM_SETCDR (arg1
, x
);
900 return scm_cons2 (scm_i_quote
, SCM_CAR (arg1
), SCM_EOL
);
902 return SCM_UNSPECIFIED
;
905 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
912 scm_m_letrec (xorig
, env
)
916 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
917 char *what
= SCM_CHARS (SCM_CAR (xorig
));
918 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
919 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
921 ASRTSYNTAX (scm_ilength (x
) >= 2, scm_s_body
);
924 (proc
) return scm_m_letstar (xorig
, env
); /* null binding, let* faster */
925 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
928 /* vars scm_list reversed here, inits reversed at evaluation */
929 arg1
= SCM_CAR (proc
);
930 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
931 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
);
932 vars
= scm_cons (SCM_CAR (arg1
), vars
);
933 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
934 initloc
= SCM_CDRLOC (*initloc
);
937 (proc
= SCM_CDR (proc
));
938 cdrx
= scm_cons2 (vars
, inits
, SCM_CDR (x
));
939 bodycheck (xorig
, SCM_CDRLOC (SCM_CDR (cdrx
)), what
);
940 return scm_cons (SCM_IM_LETREC
, cdrx
);
945 scm_m_let (xorig
, env
)
949 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
950 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
951 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
953 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, "let");
956 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
957 && SCM_NIMP (SCM_CAR (proc
)) && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
958 return scm_m_letstar (xorig
, env
); /* null or single binding, let* is faster */
959 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, "let");
960 if (SCM_CONSP (proc
)) /* plain let, proc is <bindings> */
961 return scm_cons (SCM_IM_LET
, SCM_CDR (scm_m_letrec (xorig
, env
)));
962 if (!SCM_SYMBOLP (proc
))
963 scm_wta (xorig
, scm_s_bindings
, "let"); /* bad let */
964 name
= proc
; /* named let, build equiv letrec */
966 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, "let");
967 proc
= SCM_CAR (x
); /* bindings scm_list */
968 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "let");
971 { /* vars and inits both in order */
972 arg1
= SCM_CAR (proc
);
973 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, "let");
974 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
975 xorig
, scm_s_variable
, "let");
976 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
977 varloc
= SCM_CDRLOC (*varloc
);
978 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
979 initloc
= SCM_CDRLOC (*initloc
);
980 proc
= SCM_CDR (proc
);
983 scm_m_letrec (scm_cons2 (scm_i_let
,
984 scm_cons (scm_cons2 (name
, scm_cons2 (scm_i_lambda
, vars
, SCM_CDR (x
)), SCM_EOL
), SCM_EOL
),
985 scm_acons (name
, inits
, SCM_EOL
)), /* body */
992 scm_m_apply (xorig
, env
)
996 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
997 xorig
, scm_s_expression
, "@apply");
998 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1001 #define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
1005 scm_m_cont (xorig
, env
)
1009 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1010 xorig
, scm_s_expression
, "@call-with-current-continuation");
1011 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1014 /* scm_unmemocopy takes a memoized expression together with its
1015 * environment and rewrites it to its original form. Thus, it is the
1016 * inversion of the rewrite rules above. The procedure is not
1017 * optimized for speed. It's used in scm_iprin1 when printing the
1018 * code of a closure, in scm_procedure_source, in display_frame when
1019 * generating the source for a stackframe in a backtrace, and in
1020 * display_expression.
1023 static SCM unmemocopy
SCM_P ((SCM x
, SCM env
));
1031 #ifdef DEBUG_EXTENSIONS
1034 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1036 #ifdef DEBUG_EXTENSIONS
1037 p
= scm_whash_lookup (scm_source_whash
, x
);
1039 switch (SCM_TYP7 (x
))
1041 case (127 & SCM_IM_AND
):
1042 ls
= z
= scm_cons (scm_i_and
, SCM_UNSPECIFIED
);
1044 case (127 & SCM_IM_BEGIN
):
1045 ls
= z
= scm_cons (scm_i_begin
, SCM_UNSPECIFIED
);
1047 case (127 & SCM_IM_CASE
):
1048 ls
= z
= scm_cons (scm_i_case
, SCM_UNSPECIFIED
);
1050 case (127 & SCM_IM_COND
):
1051 ls
= z
= scm_cons (scm_i_cond
, SCM_UNSPECIFIED
);
1053 case (127 & SCM_IM_DO
):
1054 ls
= scm_cons (scm_i_do
, SCM_UNSPECIFIED
);
1056 case (127 & SCM_IM_IF
):
1057 ls
= z
= scm_cons (scm_i_if
, SCM_UNSPECIFIED
);
1059 case (127 & SCM_IM_LET
):
1060 ls
= scm_cons (scm_i_let
, SCM_UNSPECIFIED
);
1062 case (127 & SCM_IM_LETREC
):
1065 ls
= scm_cons (scm_i_letrec
, SCM_UNSPECIFIED
);
1068 f
= v
= SCM_CAR (x
);
1070 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1071 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1072 SCM_CAR (ls
) == scm_i_letrec
? z
: env
));
1074 s
= SCM_CAR (ls
) == scm_i_do
1075 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1080 z
= scm_acons (SCM_CAR (v
),
1081 scm_cons (SCM_CAR (e
),
1082 SCM_CAR (s
) == SCM_CAR (v
)
1084 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1091 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1093 if (SCM_CAR (ls
) == scm_i_do
)
1096 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1099 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1103 case (127 & SCM_IM_LETSTAR
):
1111 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1114 y
= z
= scm_acons (SCM_CAR (b
),
1116 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1118 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1119 b
= SCM_CDR (SCM_CDR (b
));
1122 SCM_SETCDR (y
, SCM_EOL
);
1123 ls
= scm_cons (scm_i_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1128 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1130 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1133 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1134 b
= SCM_CDR (SCM_CDR (b
));
1137 SCM_SETCDR (z
, SCM_EOL
);
1139 ls
= scm_cons (scm_i_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1142 case (127 & SCM_IM_OR
):
1143 ls
= z
= scm_cons (scm_i_or
, SCM_UNSPECIFIED
);
1145 case (127 & SCM_IM_LAMBDA
):
1147 ls
= scm_cons (scm_i_lambda
,
1148 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1149 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1151 case (127 & SCM_IM_QUOTE
):
1152 ls
= z
= scm_cons (scm_i_quote
, SCM_UNSPECIFIED
);
1154 case (127 & SCM_IM_SET
):
1155 ls
= z
= scm_cons (scm_i_set
, SCM_UNSPECIFIED
);
1157 case (127 & SCM_IM_DEFINE
):
1161 ls
= scm_cons (scm_i_define
,
1162 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1163 if (SCM_NNULLP (env
))
1164 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1167 case (127 & SCM_MAKISYM (0)):
1171 switch SCM_ISYMNUM (z
)
1173 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1174 ls
= z
= scm_cons (scm_i_atapply
, SCM_UNSPECIFIED
);
1176 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1177 ls
= z
= scm_cons (scm_i_atcall_cc
, SCM_UNSPECIFIED
);
1180 /* appease the Sun compiler god: */ ;
1184 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1189 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1191 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1197 #ifdef DEBUG_EXTENSIONS
1198 if (SCM_NFALSEP (p
))
1199 scm_whash_insert (scm_source_whash
, ls
, p
);
1206 scm_unmemocopy (x
, env
)
1210 if (SCM_NNULLP (env
))
1211 /* Make a copy of the lowest frame to protect it from
1212 modifications by SCM_IM_DEFINE */
1213 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1215 return unmemocopy (x
, env
);
1218 #ifndef SCM_RECKLESS
1221 scm_badargsp (formals
, args
)
1232 formals
= SCM_CDR (formals
);
1233 args
= SCM_CDR (args
);
1235 return SCM_NNULLP (args
) ? 1 : 0;
1242 scm_eval_args (l
, env
, proc
)
1247 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1248 while (SCM_NIMP (l
))
1253 else if (SCM_CONSP (l
))
1255 if (SCM_IMP (SCM_CAR (l
)))
1256 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1258 res
= EVALCELLCAR (l
, env
);
1260 else if (SCM_TYP3 (l
) == 1)
1262 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1263 res
= SCM_CAR (l
); /* struct planted in code */
1268 res
= EVALCAR (l
, env
);
1270 *lloc
= scm_cons (res
, SCM_EOL
);
1271 lloc
= SCM_CDRLOC (*lloc
);
1278 scm_wrong_num_args (proc
);
1288 /* SECTION: This code is specific for the debugging support. One
1289 * branch is read when DEVAL isn't defined, the other when DEVAL is
1295 #define SCM_APPLY scm_apply
1296 #define PREP_APPLY(proc, args)
1298 #define RETURN(x) return x;
1299 #ifdef STACK_CHECKING
1300 #ifndef NO_CEVAL_STACK_CHECKING
1301 #define EVAL_STACK_CHECKING
1308 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1310 #define SCM_APPLY scm_dapply
1312 #define PREP_APPLY(p, l) \
1313 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1315 #define ENTER_APPLY \
1317 SCM_SET_ARGSREADY (debug);\
1318 if (CHECK_APPLY && SCM_TRAPS_P)\
1319 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1321 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1322 SCM_SET_TRACED_FRAME (debug); \
1323 if (SCM_CHEAPTRAPS_P)\
1325 tmp = scm_make_debugobj (&debug);\
1326 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1330 scm_make_cont (&tmp);\
1331 if (!setjmp (SCM_JMPBUF (tmp)))\
1332 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1337 #define RETURN(e) {proc = (e); goto exit;}
1338 #ifdef STACK_CHECKING
1339 #ifndef EVAL_STACK_CHECKING
1340 #define EVAL_STACK_CHECKING
1344 /* scm_ceval_ptr points to the currently selected evaluator.
1345 * *fixme*: Although efficiency is important here, this state variable
1346 * should probably not be a global. It should be related to the
1351 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1353 /* scm_last_debug_frame contains a pointer to the last debugging
1354 * information stack frame. It is accessed very often from the
1355 * debugging evaluator, so it should probably not be indirectly
1356 * addressed. Better to save and restore it from the current root at
1361 scm_debug_frame
*scm_last_debug_frame
;
1364 /* scm_debug_eframe_size is the number of slots available for pseudo
1365 * stack frames at each real stack frame.
1368 int scm_debug_eframe_size
;
1370 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1374 scm_option scm_eval_opts
[] = {
1375 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1378 scm_option scm_debug_opts
[] = {
1379 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1380 "*Flyweight representation of the stack at traps." },
1381 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1382 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1383 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1384 "Record procedure names at definition." },
1385 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1386 "Display backtrace in anti-chronological order." },
1387 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1388 { SCM_OPTION_INTEGER
, "frames", 3,
1389 "Maximum number of tail-recursive frames in backtrace." },
1390 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1391 "Maximal number of stored backtrace frames." },
1392 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1393 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1394 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1395 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1398 scm_option scm_evaluator_trap_table
[] = {
1399 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1400 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1401 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1402 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1405 SCM_PROC (s_eval_options_interface
, "eval-options-interface", 0, 1, 0, scm_eval_options_interface
);
1408 scm_eval_options_interface (SCM setting
)
1412 ans
= scm_options (setting
,
1415 s_eval_options_interface
);
1416 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1421 SCM_PROC (s_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps
);
1424 scm_evaluator_traps (setting
)
1429 ans
= scm_options (setting
,
1430 scm_evaluator_trap_table
,
1431 SCM_N_EVALUATOR_TRAPS
,
1433 SCM_RESET_DEBUG_MODE
;
1439 scm_deval_args (l
, env
, proc
, lloc
)
1440 SCM l
, env
, proc
, *lloc
;
1442 SCM
*results
= lloc
, res
;
1443 while (SCM_NIMP (l
))
1448 else if (SCM_CONSP (l
))
1450 if (SCM_IMP (SCM_CAR (l
)))
1451 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1453 res
= EVALCELLCAR (l
, env
);
1455 else if (SCM_TYP3 (l
) == 1)
1457 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1458 res
= SCM_CAR (l
); /* struct planted in code */
1463 res
= EVALCAR (l
, env
);
1465 *lloc
= scm_cons (res
, SCM_EOL
);
1466 lloc
= SCM_CDRLOC (*lloc
);
1473 scm_wrong_num_args (proc
);
1482 /* SECTION: Some local definitions for the evaluator.
1487 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1489 #define CHECK_EQVISH(A,B) ((A) == (B))
1493 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1495 /* SECTION: This is the evaluator. Like any real monster, it has
1496 * three heads. This code is compiled twice.
1528 scm_debug_frame debug
;
1529 scm_debug_info
*debug_info_end
;
1530 debug
.prev
= scm_last_debug_frame
;
1531 debug
.status
= scm_debug_eframe_size
;
1532 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1533 * sizeof (debug
.vect
[0]));
1534 debug
.info
= debug
.vect
;
1535 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1536 scm_last_debug_frame
= &debug
;
1538 #ifdef EVAL_STACK_CHECKING
1539 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1540 && scm_stack_checking_enabled_p
)
1543 debug
.info
->e
.exp
= x
;
1544 debug
.info
->e
.env
= env
;
1546 scm_report_stack_overflow ();
1553 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1556 SCM_CLEAR_ARGSREADY (debug
);
1557 if (SCM_OVERFLOWP (debug
))
1559 else if (++debug
.info
>= debug_info_end
)
1561 SCM_SET_OVERFLOW (debug
);
1565 debug
.info
->e
.exp
= x
;
1566 debug
.info
->e
.env
= env
;
1567 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1568 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1570 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1571 SCM_SET_TAILREC (debug
);
1572 if (SCM_CHEAPTRAPS_P
)
1573 t
.arg1
= scm_make_debugobj (&debug
);
1576 scm_make_cont (&t
.arg1
);
1577 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1579 x
= SCM_THROW_VALUE (t
.arg1
);
1585 /* This gives the possibility for the debugger to
1586 modify the source expression before evaluation. */
1590 scm_ithrow (scm_i_enter_frame
,
1591 scm_cons2 (t
.arg1
, tail
,
1592 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1596 #if defined (USE_THREADS) || defined (DEVAL)
1600 switch (SCM_TYP7 (x
))
1602 case scm_tcs_symbols
:
1603 /* Only happens when called at top level.
1605 x
= scm_cons (x
, SCM_UNDEFINED
);
1608 case (127 & SCM_IM_AND
):
1611 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1612 if (SCM_FALSEP (EVALCAR (x
, env
)))
1614 RETURN (SCM_BOOL_F
);
1618 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1621 case (127 & SCM_IM_BEGIN
):
1623 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1629 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1631 SIDEVAL (SCM_CAR (x
), env
);
1635 carloop
: /* scm_eval car of last form in list */
1636 if (SCM_NCELLP (SCM_CAR (x
)))
1639 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1642 if (SCM_SYMBOLP (SCM_CAR (x
)))
1645 RETURN (*scm_lookupcar (x
, env
))
1649 goto loop
; /* tail recurse */
1652 case (127 & SCM_IM_CASE
):
1654 t
.arg1
= EVALCAR (x
, env
);
1655 while (SCM_NIMP (x
= SCM_CDR (x
)))
1658 if (scm_i_else
== SCM_CAR (proc
))
1661 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1664 proc
= SCM_CAR (proc
);
1665 while (SCM_NIMP (proc
))
1667 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1669 x
= SCM_CDR (SCM_CAR (x
));
1670 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1673 proc
= SCM_CDR (proc
);
1676 RETURN (SCM_UNSPECIFIED
)
1679 case (127 & SCM_IM_COND
):
1680 while (SCM_NIMP (x
= SCM_CDR (x
)))
1683 t
.arg1
= EVALCAR (proc
, env
);
1684 if (SCM_NFALSEP (t
.arg1
))
1691 if (scm_i_arrow
!= SCM_CAR (x
))
1693 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1697 proc
= EVALCAR (proc
, env
);
1698 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1699 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1704 RETURN (SCM_UNSPECIFIED
)
1707 case (127 & SCM_IM_DO
):
1709 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1710 t
.arg1
= SCM_EOL
; /* values */
1711 while (SCM_NIMP (proc
))
1713 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1714 proc
= SCM_CDR (proc
);
1716 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1717 x
= SCM_CDR (SCM_CDR (x
));
1718 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
1720 for (proc
= SCM_CAR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1722 t
.arg1
= SCM_CAR (proc
); /* body */
1723 SIDEVAL (t
.arg1
, env
);
1725 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1726 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
1727 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
1731 RETURN (SCM_UNSPECIFIED
);
1732 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1736 case (127 & SCM_IM_IF
):
1738 if (SCM_NFALSEP (EVALCAR (x
, env
)))
1740 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
1742 RETURN (SCM_UNSPECIFIED
);
1744 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1748 case (127 & SCM_IM_LET
):
1750 proc
= SCM_CAR (SCM_CDR (x
));
1754 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1756 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1757 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1762 case (127 & SCM_IM_LETREC
):
1764 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
1770 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1772 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1773 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
1777 case (127 & SCM_IM_LETSTAR
):
1782 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1787 t
.arg1
= SCM_CAR (proc
);
1788 proc
= SCM_CDR (proc
);
1789 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
1791 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1794 case (127 & SCM_IM_OR
):
1797 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1799 x
= EVALCAR (x
, env
);
1800 if (SCM_NFALSEP (x
))
1806 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1810 case (127 & SCM_IM_LAMBDA
):
1811 RETURN (scm_closure (SCM_CDR (x
), env
));
1814 case (127 & SCM_IM_QUOTE
):
1815 RETURN (SCM_CAR (SCM_CDR (x
)));
1818 case (127 & SCM_IM_SET
):
1821 switch (7 & (int) proc
)
1824 t
.lloc
= scm_lookupcar (x
, env
);
1827 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
1829 #ifdef MEMOIZE_LOCALS
1831 t
.lloc
= scm_ilookup (proc
, env
);
1836 *t
.lloc
= EVALCAR (x
, env
);
1840 RETURN (SCM_UNSPECIFIED
);
1844 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
1848 x
= evalcar (x
, env
);
1849 #ifdef DEBUG_EXTENSIONS
1850 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
1854 if (SCM_CLOSUREP (t
.arg1
)
1855 /* Only the first definition determines the name. */
1856 && (scm_procedure_property (t
.arg1
, scm_i_inner_name
)
1858 scm_set_procedure_property_x (t
.arg1
, scm_i_inner_name
, proc
);
1859 else if (SCM_TYP16 (t
.arg1
) == scm_tc16_macro
1860 && SCM_CDR (t
.arg1
) != t
.arg1
)
1862 t
.arg1
= SCM_CDR (t
.arg1
);
1867 env
= SCM_CAR (env
);
1869 SCM_SETCAR (env
, scm_cons (proc
, SCM_CAR (env
)));
1870 SCM_SETCDR (env
, scm_cons (x
, SCM_CDR (env
)));
1872 RETURN (SCM_UNSPECIFIED
);
1875 /* new syntactic forms go here. */
1876 case (127 & SCM_MAKISYM (0)):
1878 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
1879 switch SCM_ISYMNUM (proc
)
1882 case (SCM_ISYMNUM (IM_VREF
)):
1885 var
= SCM_CAR (SCM_CDR (x
));
1886 RETURN (SCM_CDR(var
));
1888 case (SCM_ISYMNUM (IM_VSET
)):
1889 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
1890 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
1891 RETURN (SCM_UNSPECIFIED
)
1894 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1896 proc
= EVALCAR (proc
, env
);
1897 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1898 if (SCM_CLOSUREP (proc
))
1901 PREP_APPLY (proc
, SCM_EOL
);
1902 t
.arg1
= SCM_CDR (SCM_CDR (x
));
1903 t
.arg1
= EVALCAR (t
.arg1
, env
);
1905 debug
.info
->a
.args
= t
.arg1
;
1907 #ifndef SCM_RECKLESS
1908 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
1911 /* Copy argument list */
1912 if (SCM_IMP (t
.arg1
))
1916 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
1917 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
1918 && SCM_CONSP (t
.arg1
))
1920 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
1924 SCM_SETCDR (tl
, t
.arg1
);
1927 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
1928 x
= SCM_CODE (proc
);
1934 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1935 scm_make_cont (&t
.arg1
);
1936 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1939 val
= SCM_THROW_VALUE (t
.arg1
);
1943 proc
= evalcar (proc
, env
);
1944 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1945 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1956 /* scm_everr (x, env,...) */
1957 scm_misc_error (NULL
,
1958 "Wrong type to apply: %S",
1959 scm_listify (proc
, SCM_UNDEFINED
));
1960 case scm_tc7_vector
:
1963 case scm_tc7_byvect
:
1971 case scm_tc7_llvect
:
1973 case scm_tc7_string
:
1974 case scm_tc7_substring
:
1976 case scm_tcs_closures
:
1980 #ifdef MEMOIZE_LOCALS
1981 case (127 & SCM_ILOC00
):
1982 proc
= *scm_ilookup (SCM_CAR (x
), env
);
1983 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1984 #ifndef SCM_RECKLESS
1990 #endif /* ifdef MEMOIZE_LOCALS */
1993 case scm_tcs_cons_gloc
:
1994 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
1995 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1996 #ifndef SCM_RECKLESS
2004 case scm_tcs_cons_nimcar
:
2005 if (SCM_SYMBOLP (SCM_CAR (x
)))
2008 t
.lloc
= scm_lookupcar1 (x
, env
);
2011 /* we have lost the race, start again. */
2016 proc
= *scm_lookupcar (x
, env
);
2024 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2030 /* Set a flag during macro expansion so that macro
2031 application frames can be deleted from the backtrace. */
2032 SCM_SET_MACROEXP (debug
);
2034 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2035 scm_cons (env
, scm_listofnull
));
2038 SCM_CLEAR_MACROEXP (debug
);
2040 switch ((int) (SCM_CAR (proc
) >> 16))
2043 if (scm_ilength (t
.arg1
) <= 0)
2044 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2046 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2049 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2050 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2051 /* Prevent memoizing result of define macro */
2053 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2054 scm_set_source_properties_x (debug
.info
->e
.exp
,
2055 scm_source_properties (x
));
2059 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2060 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2064 /* Prevent memoizing of debug info expression. */
2065 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2066 scm_set_source_properties_x (debug
.info
->e
.exp
,
2067 scm_source_properties (x
));
2070 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2071 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2075 if (SCM_NIMP (x
= t
.arg1
))
2083 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2084 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2085 #ifndef SCM_RECKLESS
2089 if (SCM_CLOSUREP (proc
))
2091 arg2
= SCM_CAR (SCM_CODE (proc
));
2092 t
.arg1
= SCM_CDR (x
);
2093 while (SCM_NIMP (arg2
))
2095 if (SCM_NCONSP (arg2
))
2097 if (SCM_IMP (t
.arg1
))
2098 goto umwrongnumargs
;
2099 arg2
= SCM_CDR (arg2
);
2100 t
.arg1
= SCM_CDR (t
.arg1
);
2102 if (SCM_NNULLP (t
.arg1
))
2103 goto umwrongnumargs
;
2105 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2106 goto handle_a_macro
;
2112 PREP_APPLY (proc
, SCM_EOL
);
2113 if (SCM_NULLP (SCM_CDR (x
))) {
2115 switch (SCM_TYP7 (proc
))
2116 { /* no arguments given */
2117 case scm_tc7_subr_0
:
2118 RETURN (SCM_SUBRF (proc
) ());
2119 case scm_tc7_subr_1o
:
2120 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2122 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2123 case scm_tc7_rpsubr
:
2124 RETURN (SCM_BOOL_T
);
2126 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2130 proc
= SCM_CCLO_SUBR (proc
);
2132 debug
.info
->a
.proc
= proc
;
2133 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2137 case scm_tcs_closures
:
2138 x
= SCM_CODE (proc
);
2139 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2141 case scm_tcs_cons_gloc
:
2142 if (SCM_I_OPERATORP (proc
))
2144 x
= (SCM_I_ENTITYP (proc
)
2145 ? SCM_ENTITY_PROC_0 (proc
)
2146 : SCM_OPERATOR_PROC_0 (proc
));
2149 if (SCM_TYP7 (x
) == scm_tc7_subr_1
)
2150 RETURN (SCM_SUBRF (x
) (proc
))
2151 else if (SCM_CLOSUREP (x
))
2156 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2157 debug
.info
->a
.proc
= proc
;
2164 case scm_tc7_contin
:
2165 case scm_tc7_subr_1
:
2166 case scm_tc7_subr_2
:
2167 case scm_tc7_subr_2o
:
2169 case scm_tc7_subr_3
:
2170 case scm_tc7_lsubr_2
:
2174 /* scm_everr (x, env,...) */
2175 scm_wrong_num_args (proc
);
2177 /* handle macros here */
2182 /* must handle macros by here */
2187 else if (SCM_CONSP (x
))
2189 if (SCM_IMP (SCM_CAR (x
)))
2190 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2192 t
.arg1
= EVALCELLCAR (x
, env
);
2194 else if (SCM_TYP3 (x
) == 1)
2196 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2197 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2202 t
.arg1
= EVALCAR (x
, env
);
2205 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2212 switch (SCM_TYP7 (proc
))
2213 { /* have one argument in t.arg1 */
2214 case scm_tc7_subr_2o
:
2215 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2216 case scm_tc7_subr_1
:
2217 case scm_tc7_subr_1o
:
2218 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2221 if (SCM_SUBRF (proc
))
2223 if (SCM_INUMP (t
.arg1
))
2225 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2228 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2229 if (SCM_REALP (t
.arg1
))
2231 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2234 if (SCM_BIGP (t
.arg1
))
2236 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2240 scm_wta (t
.arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2243 proc
= (SCM
) SCM_SNAME (proc
);
2245 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2246 while ('c' != *--chrs
)
2248 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2249 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2250 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2254 case scm_tc7_rpsubr
:
2255 RETURN (SCM_BOOL_T
);
2257 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2260 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2262 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2268 proc
= SCM_CCLO_SUBR (proc
);
2270 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2271 debug
.info
->a
.proc
= proc
;
2275 case scm_tcs_closures
:
2277 x
= SCM_CODE (proc
);
2279 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2281 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2284 case scm_tc7_contin
:
2285 scm_call_continuation (proc
, t
.arg1
);
2286 case scm_tcs_cons_gloc
:
2287 if (SCM_I_OPERATORP (proc
))
2289 x
= (SCM_I_ENTITYP (proc
)
2290 ? SCM_ENTITY_PROC_1 (proc
)
2291 : SCM_OPERATOR_PROC_1 (proc
));
2294 if (SCM_TYP7 (x
) == scm_tc7_subr_2
)
2295 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
))
2296 else if (SCM_CLOSUREP (x
))
2302 debug
.info
->a
.args
= scm_cons (t
.arg1
,
2303 debug
.info
->a
.args
);
2304 debug
.info
->a
.proc
= proc
;
2311 case scm_tc7_subr_2
:
2312 case scm_tc7_subr_0
:
2313 case scm_tc7_subr_3
:
2314 case scm_tc7_lsubr_2
:
2323 else if (SCM_CONSP (x
))
2325 if (SCM_IMP (SCM_CAR (x
)))
2326 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2328 arg2
= EVALCELLCAR (x
, env
);
2330 else if (SCM_TYP3 (x
) == 1)
2332 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2333 arg2
= SCM_CAR (x
); /* struct planted in code */
2338 arg2
= EVALCAR (x
, env
);
2340 { /* have two or more arguments */
2342 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2345 if (SCM_NULLP (x
)) {
2350 switch (SCM_TYP7 (proc
))
2351 { /* have two arguments */
2352 case scm_tc7_subr_2
:
2353 case scm_tc7_subr_2o
:
2354 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2357 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2359 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2361 case scm_tc7_lsubr_2
:
2362 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2363 case scm_tc7_rpsubr
:
2365 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2370 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2371 scm_cons (debug
.info
->a
.args
, SCM_EOL
)));
2373 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2374 scm_cons2 (t
.arg1
, arg2
,
2375 scm_cons (scm_eval_args (x
, env
, proc
),
2378 /* case scm_tc7_cclo:
2379 x = scm_cons(arg2, scm_eval_args(x, env));
2382 proc = SCM_CCLO_SUBR(proc);
2385 case scm_tcs_cons_gloc
:
2386 if (SCM_I_OPERATORP (proc
))
2388 x
= (SCM_I_ENTITYP (proc
)
2389 ? SCM_ENTITY_PROC_2 (proc
)
2390 : SCM_OPERATOR_PROC_2 (proc
));
2393 if (SCM_TYP7 (x
) == scm_tc7_subr_3
)
2394 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
, arg2
))
2395 else if (SCM_CLOSUREP (x
))
2398 SCM_SET_ARGSREADY (debug
);
2399 debug
.info
->a
.args
= scm_cons (proc
,
2400 debug
.info
->a
.args
);
2401 debug
.info
->a
.proc
= x
;
2403 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (x
)),
2404 scm_cons2 (proc
, t
.arg1
,
2405 scm_cons (arg2
, SCM_EOL
)),
2413 case scm_tc7_subr_0
:
2415 case scm_tc7_subr_1o
:
2416 case scm_tc7_subr_1
:
2417 case scm_tc7_subr_3
:
2418 case scm_tc7_contin
:
2422 case scm_tcs_closures
:
2425 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2429 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2430 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2432 x
= SCM_CODE (proc
);
2437 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2441 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2442 scm_deval_args (x
, env
, proc
,
2443 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2446 switch (SCM_TYP7 (proc
))
2447 { /* have 3 or more arguments */
2449 case scm_tc7_subr_3
:
2450 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2451 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2452 SCM_CADDR (debug
.info
->a
.args
)));
2454 #ifdef BUILTIN_RPASUBR
2455 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2456 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2459 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2460 arg2
= SCM_CDR (arg2
);
2462 while (SCM_NIMP (arg2
));
2464 #endif /* BUILTIN_RPASUBR */
2465 case scm_tc7_rpsubr
:
2466 #ifdef BUILTIN_RPASUBR
2467 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2469 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2472 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2474 arg2
= SCM_CAR (t
.arg1
);
2475 t
.arg1
= SCM_CDR (t
.arg1
);
2477 while (SCM_NIMP (t
.arg1
));
2479 #else /* BUILTIN_RPASUBR */
2480 RETURN (SCM_APPLY (proc
, t
.arg1
,
2482 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
2484 #endif /* BUILTIN_RPASUBR */
2485 case scm_tc7_lsubr_2
:
2486 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2487 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2489 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2494 case scm_tcs_closures
:
2495 SCM_SET_ARGSREADY (debug
);
2496 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2499 x
= SCM_CODE (proc
);
2502 case scm_tc7_subr_3
:
2503 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2504 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
2506 #ifdef BUILTIN_RPASUBR
2507 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
2510 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
2513 while (SCM_NIMP (x
));
2515 #endif /* BUILTIN_RPASUBR */
2516 case scm_tc7_rpsubr
:
2517 #ifdef BUILTIN_RPASUBR
2518 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2522 t
.arg1
= EVALCAR (x
, env
);
2523 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
2528 while (SCM_NIMP (x
));
2530 #else /* BUILTIN_RPASUBR */
2531 RETURN (SCM_APPLY (proc
, t
.arg1
,
2533 scm_eval_args (x
, env
, proc
),
2535 #endif /* BUILTIN_RPASUBR */
2536 case scm_tc7_lsubr_2
:
2537 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
2539 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
2541 scm_eval_args (x
, env
, proc
))));
2546 case scm_tcs_closures
:
2548 SCM_SET_ARGSREADY (debug
);
2550 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2553 scm_eval_args (x
, env
, proc
)),
2555 x
= SCM_CODE (proc
);
2558 case scm_tcs_cons_gloc
:
2559 if (SCM_I_OPERATORP (proc
))
2561 SCM p
= (SCM_I_ENTITYP (proc
)
2562 ? SCM_ENTITY_PROC_3 (proc
)
2563 : SCM_OPERATOR_PROC_3 (proc
));
2566 if (SCM_TYP7 (p
) == scm_tc7_lsubr_2
)
2568 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2569 scm_cons (arg2
, SCM_CDDR (debug
.info
->a
.args
))))
2571 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2573 scm_eval_args (x
, env
, proc
))))
2575 else if (SCM_CLOSUREP (p
))
2578 SCM_SET_ARGSREADY (debug
);
2579 debug
.info
->a
.args
= scm_cons (proc
, debug
.info
->a
.args
);
2580 debug
.info
->a
.proc
= p
;
2581 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2582 scm_cons2 (proc
, t
.arg1
,
2584 SCM_CDDDR (debug
.info
->a
.args
))),
2587 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2588 scm_cons2 (proc
, t
.arg1
,
2590 scm_eval_args (x
, env
, proc
))),
2599 case scm_tc7_subr_2
:
2600 case scm_tc7_subr_1o
:
2601 case scm_tc7_subr_2o
:
2602 case scm_tc7_subr_0
:
2604 case scm_tc7_subr_1
:
2605 case scm_tc7_contin
:
2613 if (CHECK_EXIT
&& SCM_TRAPS_P
)
2614 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2616 SCM_CLEAR_TRACED_FRAME (debug
);
2617 if (SCM_CHEAPTRAPS_P
)
2618 t
.arg1
= scm_make_debugobj (&debug
);
2621 scm_make_cont (&t
.arg1
);
2622 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2624 proc
= SCM_THROW_VALUE (t
.arg1
);
2628 scm_ithrow (scm_i_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
2631 scm_last_debug_frame
= debug
.prev
;
2637 /* SECTION: This code is compiled once.
2642 /* This code processes the arguments to apply:
2644 (apply PROC ARG1 ... ARGS)
2646 Given a list (ARG1 ... ARGS), this function conses the ARG1
2647 ... arguments onto the front of ARGS, and returns the resulting
2648 list. Note that ARGS is a list; thus, the argument to this
2649 function is a list whose last element is a list.
2651 Apply calls this function, and applies PROC to the elements of the
2652 result. apply:nconc2last takes care of building the list of
2653 arguments, given (ARG1 ... ARGS).
2655 Rather than do new consing, apply:nconc2last destroys its argument.
2656 On that topic, this code came into my care with the following
2657 beautifully cryptic comment on that topic: "This will only screw
2658 you if you do (scm_apply scm_apply '( ... ))" If you know what
2659 they're referring to, send me a patch to this comment. */
2661 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
2664 scm_nconc2last (lst
)
2668 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
2670 while (SCM_NNULLP (SCM_CDR (*lloc
)))
2671 lloc
= SCM_CDRLOC (*lloc
);
2672 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
2673 *lloc
= SCM_CAR (*lloc
);
2680 /* SECTION: When DEVAL is defined this code yields scm_dapply.
2681 * It is compiled twice.
2687 scm_apply (proc
, arg1
, args
)
2697 scm_dapply (proc
, arg1
, args
)
2705 /* Apply a function to a list of arguments.
2707 This function is exported to the Scheme level as taking two
2708 required arguments and a tail argument, as if it were:
2709 (lambda (proc arg1 . args) ...)
2710 Thus, if you just have a list of arguments to pass to a procedure,
2711 pass the list as ARG1, and '() for ARGS. If you have some fixed
2712 args, pass the first as ARG1, then cons any remaining fixed args
2713 onto the front of your argument list, and pass that as ARGS. */
2716 SCM_APPLY (proc
, arg1
, args
)
2721 #ifdef DEBUG_EXTENSIONS
2723 scm_debug_frame debug
;
2724 scm_debug_info debug_vect_body
;
2725 debug
.prev
= scm_last_debug_frame
;
2726 debug
.status
= SCM_APPLYFRAME
;
2727 debug
.vect
= &debug_vect_body
;
2728 debug
.vect
[0].a
.proc
= proc
;
2729 debug
.vect
[0].a
.args
= SCM_EOL
;
2730 scm_last_debug_frame
= &debug
;
2733 return scm_dapply (proc
, arg1
, args
);
2737 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
2739 /* If ARGS is the empty list, then we're calling apply with only two
2740 arguments --- ARG1 is the list of arguments for PROC. Whatever
2741 the case, futz with things so that ARG1 is the first argument to
2742 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
2745 Setting the debug apply frame args this way is pretty messy.
2746 Perhaps we should store arg1 and args directly in the frame as
2747 received, and let scm_frame_arguments unpack them, because that's
2748 a relatively rare operation. This works for now; if the Guile
2749 developer archives are still around, see Mikael's post of
2751 if (SCM_NULLP (args
))
2753 if (SCM_NULLP (arg1
))
2755 arg1
= SCM_UNDEFINED
;
2757 debug
.vect
[0].a
.args
= SCM_EOL
;
2763 debug
.vect
[0].a
.args
= arg1
;
2765 args
= SCM_CDR (arg1
);
2766 arg1
= SCM_CAR (arg1
);
2771 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
2772 args
= scm_nconc2last (args
);
2774 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2778 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
2781 if (SCM_CHEAPTRAPS_P
)
2782 tmp
= scm_make_debugobj (&debug
);
2785 scm_make_cont (&tmp
);
2786 if (setjmp (SCM_JMPBUF (tmp
)))
2789 scm_ithrow (scm_i_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
2797 switch (SCM_TYP7 (proc
))
2799 case scm_tc7_subr_2o
:
2800 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
2801 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2802 case scm_tc7_subr_2
:
2803 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
2805 args
= SCM_CAR (args
);
2806 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2807 case scm_tc7_subr_0
:
2808 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
2809 RETURN (SCM_SUBRF (proc
) ())
2810 case scm_tc7_subr_1
:
2811 case scm_tc7_subr_1o
:
2812 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2813 RETURN (SCM_SUBRF (proc
) (arg1
))
2815 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2817 if (SCM_SUBRF (proc
))
2819 if (SCM_INUMP (arg1
))
2821 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
2823 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
2824 if (SCM_REALP (arg1
))
2826 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
2831 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
2834 scm_wta (arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2837 proc
= (SCM
) SCM_SNAME (proc
);
2839 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2840 while ('c' != *--chrs
)
2842 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
2843 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2844 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2848 case scm_tc7_subr_3
:
2849 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
2852 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
2854 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
2856 case scm_tc7_lsubr_2
:
2857 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
2858 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
2860 if (SCM_NULLP (args
))
2861 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
2862 while (SCM_NIMP (args
))
2864 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2865 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
2866 args
= SCM_CDR (args
);
2869 case scm_tc7_rpsubr
:
2870 if (SCM_NULLP (args
))
2871 RETURN (SCM_BOOL_T
);
2872 while (SCM_NIMP (args
))
2874 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2875 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
2876 RETURN (SCM_BOOL_F
);
2877 arg1
= SCM_CAR (args
);
2878 args
= SCM_CDR (args
);
2880 RETURN (SCM_BOOL_T
);
2881 case scm_tcs_closures
:
2883 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2885 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2887 #ifndef SCM_RECKLESS
2888 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
2892 /* Copy argument list */
2897 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
2898 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
2899 && SCM_CONSP (arg1
))
2901 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
2905 SCM_SETCDR (tl
, arg1
);
2908 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
2909 proc
= SCM_CODE (proc
);
2910 while (SCM_NNULLP (proc
= SCM_CDR (proc
)))
2911 arg1
= EVALCAR (proc
, args
);
2913 case scm_tc7_contin
:
2914 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2915 scm_call_continuation (proc
, arg1
);
2919 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2921 proc
= SCM_CCLO_SUBR (proc
);
2922 debug
.vect
[0].a
.proc
= proc
;
2923 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2925 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2927 proc
= SCM_CCLO_SUBR (proc
);
2931 case scm_tcs_cons_gloc
:
2932 if (SCM_I_OPERATORP (proc
))
2935 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2937 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2940 proc
= (SCM_NULLP (args
)
2941 ? (SCM_I_ENTITYP (proc
)
2942 ? SCM_ENTITY_PROC_0 (proc
)
2943 : SCM_OPERATOR_PROC_0 (proc
))
2944 : SCM_NULLP (SCM_CDR (args
))
2945 ? (SCM_I_ENTITYP (proc
)
2946 ? SCM_ENTITY_PROC_1 (proc
)
2947 : SCM_OPERATOR_PROC_1 (proc
))
2948 : SCM_NULLP (SCM_CDDR (args
))
2949 ? (SCM_I_ENTITYP (proc
)
2950 ? SCM_ENTITY_PROC_2 (proc
)
2951 : SCM_OPERATOR_PROC_2 (proc
))
2952 : (SCM_I_ENTITYP (proc
)
2953 ? SCM_ENTITY_PROC_3 (proc
)
2954 : SCM_OPERATOR_PROC_3 (proc
)));
2956 debug
.vect
[0].a
.proc
= proc
;
2957 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2962 scm_wrong_num_args (proc
);
2965 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
2970 if (CHECK_EXIT
&& SCM_TRAPS_P
)
2971 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2973 SCM_CLEAR_TRACED_FRAME (debug
);
2974 if (SCM_CHEAPTRAPS_P
)
2975 arg1
= scm_make_debugobj (&debug
);
2978 scm_make_cont (&arg1
);
2979 if (setjmp (SCM_JMPBUF (arg1
)))
2981 proc
= SCM_THROW_VALUE (arg1
);
2985 scm_ithrow (scm_i_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
2988 scm_last_debug_frame
= debug
.prev
;
2994 /* SECTION: The rest of this file is only read once.
2999 SCM_PROC (s_map
, "map", 2, 0, 1, scm_map
);
3001 /* Note: Currently, scm_map applies PROC to the argument list(s)
3002 sequentially, starting with the first element(s). This is used in
3003 evalext.c where the Scheme procedure `serial-map', which guarantees
3004 sequential behaviour, is implemented using scm_map. If the
3005 behaviour changes, we need to update `serial-map'.
3009 scm_map (proc
, arg1
, args
)
3017 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3019 if (SCM_NULLP (arg1
))
3021 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_map
);
3022 if (SCM_NULLP (args
))
3024 while (SCM_NIMP (arg1
))
3026 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
3027 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
3028 pres
= SCM_CDRLOC (*pres
);
3029 arg1
= SCM_CDR (arg1
);
3033 args
= scm_vector (scm_cons (arg1
, args
));
3034 ve
= SCM_VELTS (args
);
3035 #ifndef SCM_RECKLESS
3036 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3037 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_map
);
3042 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3046 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3047 ve
[i
] = SCM_CDR (ve
[i
]);
3049 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3050 pres
= SCM_CDRLOC (*pres
);
3055 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
3058 scm_for_each (proc
, arg1
, args
)
3063 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3066 return SCM_UNSPECIFIED
;
3067 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3070 while SCM_NIMP (arg1
)
3072 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3073 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3074 arg1
= SCM_CDR (arg1
);
3076 return SCM_UNSPECIFIED
;
3078 args
= scm_vector (scm_cons (arg1
, args
));
3079 ve
= SCM_VELTS (args
);
3080 #ifndef SCM_RECKLESS
3081 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3082 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_for_each
);
3087 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3090 (ve
[i
]) return SCM_UNSPECIFIED
;
3091 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3092 ve
[i
] = SCM_CDR (ve
[i
]);
3094 scm_apply (proc
, arg1
, SCM_EOL
);
3101 scm_closure (code
, env
)
3107 SCM_SETCODE (z
, code
);
3108 SCM_SETENV (z
, env
);
3113 long scm_tc16_promise
;
3121 SCM_ENTER_A_SECTION
;
3122 SCM_SETCDR (z
, code
);
3123 SCM_SETCAR (z
, scm_tc16_promise
);
3130 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
3133 prinprom (exp
, port
, pstate
)
3136 scm_print_state
*pstate
;
3138 int writingp
= SCM_WRITINGP (pstate
);
3139 scm_puts ("#<promise ", port
);
3140 SCM_SET_WRITINGP (pstate
, 1);
3141 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3142 SCM_SET_WRITINGP (pstate
, writingp
);
3143 scm_putc ('>', port
);
3148 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
3154 SCM_ASSERT (SCM_NIMP(x
) && SCM_TYP16 (x
) == scm_tc16_promise
,
3155 x
, SCM_ARG1
, s_force
);
3156 if (!((1L << 16) & SCM_CAR (x
)))
3158 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3159 if (!((1L << 16) & SCM_CAR (x
)))
3162 SCM_SETCDR (x
, ans
);
3163 SCM_SETOR_CAR (x
, (1L << 16));
3170 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
3176 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
3181 SCM_PROC(s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
3190 if (SCM_VECTORP (obj
))
3192 scm_sizet i
= SCM_LENGTH (obj
);
3193 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3195 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3200 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3201 ans
= tl
= scm_cons (scm_copy_tree (SCM_CAR (obj
)), SCM_UNSPECIFIED
);
3203 /* Copy source properties possibly associated with head pair. */
3204 SCM p
= scm_whash_lookup (scm_source_whash
, obj
);
3206 scm_whash_insert (scm_source_whash
, ans
, p
);
3208 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3210 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3214 SCM_SETCDR (tl
, obj
);
3220 scm_eval_3 (obj
, copyp
, env
)
3225 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3226 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3228 obj
= scm_copy_tree (obj
);
3229 return SCM_XEVAL (obj
, env
);
3234 scm_top_level_env (thunk
)
3240 return scm_cons(thunk
, (SCM
)SCM_EOL
);
3243 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
3246 scm_eval2 (obj
, env_thunk
)
3250 return scm_eval_3 (obj
, 1, scm_top_level_env(env_thunk
));
3253 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
3260 scm_eval_3(obj
, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var
)));
3263 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
3272 scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var
)));
3275 static scm_smobfuns promsmob
= {scm_markcdr
, scm_free0
, prinprom
};
3278 /* At this point, scm_deval and scm_dapply are generated.
3281 #ifdef DEBUG_EXTENSIONS
3291 scm_init_opts (scm_evaluator_traps
,
3292 scm_evaluator_trap_table
,
3293 SCM_N_EVALUATOR_TRAPS
);
3294 scm_init_opts (scm_eval_options_interface
,
3296 SCM_N_EVAL_OPTIONS
);
3298 scm_tc16_promise
= scm_newsmob (&promsmob
);
3299 scm_i_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3300 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3301 scm_i_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3302 scm_i_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3303 scm_i_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3304 scm_i_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3305 scm_i_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3308 scm_i_quasiquote
= scm_make_synt (s_quasiquote
, scm_makacro
, scm_m_quasiquote
);
3309 scm_make_synt (s_delay
, scm_makacro
, scm_m_delay
);
3312 scm_top_level_lookup_closure_var
=
3313 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3314 scm_can_use_top_level_lookup_closure_var
= 1;
3316 scm_i_and
= scm_make_synt ("and", scm_makmmacro
, scm_m_and
);
3317 scm_i_begin
= scm_make_synt ("begin", scm_makmmacro
, scm_m_begin
);
3318 scm_i_case
= scm_make_synt ("case", scm_makmmacro
, scm_m_case
);
3319 scm_i_cond
= scm_make_synt ("cond", scm_makmmacro
, scm_m_cond
);
3320 scm_i_define
= scm_make_synt ("define", scm_makmmacro
, scm_m_define
);
3321 scm_i_do
= scm_make_synt ("do", scm_makmmacro
, scm_m_do
);
3322 scm_i_if
= scm_make_synt ("if", scm_makmmacro
, scm_m_if
);
3323 scm_i_lambda
= scm_make_synt ("lambda", scm_makmmacro
, scm_m_lambda
);
3324 scm_i_let
= scm_make_synt ("let", scm_makmmacro
, scm_m_let
);
3325 scm_i_letrec
= scm_make_synt ("letrec", scm_makmmacro
, scm_m_letrec
);
3326 scm_i_letstar
= scm_make_synt ("let*", scm_makmmacro
, scm_m_letstar
);
3327 scm_i_or
= scm_make_synt ("or", scm_makmmacro
, scm_m_or
);
3328 scm_i_quote
= scm_make_synt ("quote", scm_makmmacro
, scm_m_quote
);
3329 scm_i_set
= scm_make_synt ("set!", scm_makmmacro
, scm_m_set
);
3330 scm_i_atapply
= scm_make_synt ("@apply", scm_makmmacro
, scm_m_apply
);
3331 scm_i_atcall_cc
= scm_make_synt ("@call-with-current-continuation",
3332 scm_makmmacro
, scm_m_cont
);
3334 #ifdef DEBUG_EXTENSIONS
3335 scm_i_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3336 scm_i_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3337 scm_i_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3338 scm_i_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3343 scm_add_feature ("delay");