1 /* Copyright (C) 1995,1996,1997 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"
97 /* The evaluator contains a plethora of EVAL symbols.
98 * This is an attempt at explanation.
100 * The following macros should be used in code which is read twice
101 * (where the choice of evaluator is hard soldered):
103 * SCM_CEVAL is the symbol used within one evaluator to call itself.
104 * Originally, it is defined to scm_ceval, but is redefined to
105 * scm_deval during the second pass.
107 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
108 * only side effects of expressions matter. All immediates are
111 * EVALIM is used when it is known that the expression is an
112 * immediate. (This macro never calls an evaluator.)
114 * EVALCAR evaluates the car of an expression.
116 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
117 * car is a lisp cell.
119 * The following macros should be used in code which is read once
120 * (where the choice of evaluator is dynamic):
122 * XEVAL takes care of immediates without calling an evaluator. It
123 * then calls scm_ceval *or* scm_deval, depending on the debugging
126 * XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
127 * depending on the debugging mode.
129 * The main motivation for keeping this plethora is efficiency
130 * together with maintainability (=> locality of code).
133 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
134 ? *scm_lookupcar(x, env) \
135 : SCM_CEVAL(SCM_CAR(x), env))
137 #ifdef MEMOIZE_LOCALS
138 #define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
140 #define EVALIM(x, env) x
142 #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
143 ? (SCM_IMP(SCM_CAR(x)) \
144 ? EVALIM(SCM_CAR(x), env) \
145 : SCM_GLOC_VAL(SCM_CAR(x))) \
146 : EVALCELLCAR(x, env))
147 #ifdef DEBUG_EXTENSIONS
148 #define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \
149 ? (SCM_IMP(SCM_CAR(x)) \
150 ? EVALIM(SCM_CAR(x), env) \
151 : SCM_GLOC_VAL(SCM_CAR(x))) \
152 : (SCM_SYMBOLP(SCM_CAR(x)) \
153 ? *scm_lookupcar(x, env) \
154 : (*scm_ceval_ptr) (SCM_CAR(x), env)))
156 #define XEVALCAR(x, env) EVALCAR(x, env)
159 #define EXTEND_ENV SCM_EXTEND_ENV
161 #ifdef MEMOIZE_LOCALS
164 scm_ilookup (iloc
, env
)
168 register int ir
= SCM_IFRAME (iloc
);
169 register SCM er
= env
;
170 for (; 0 != ir
; --ir
)
173 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
175 if (SCM_ICDRP (iloc
))
176 return SCM_CDRLOC (er
);
177 return SCM_CARLOC (SCM_CDR (er
));
183 /* The Lookup Car Race
186 Memoization of variables and special forms is done while executing
187 the code for the first time. As long as there is only one thread
188 everything is fine, but as soon as two threads execute the same
189 code concurrently `for the first time' they can come into conflict.
191 This memoization includes rewriting variable references into more
192 efficient forms and expanding macros. Furthermore, macro expansion
193 includes `compiling' special forms like `let', `cond', etc. into
194 tree-code instructions.
196 There shouldn't normally be a problem with memoizing local and
197 global variable references (into ilocs and glocs), because all
198 threads will mutate the code in *exactly* the same way and (if I
199 read the C code correctly) it is not possible to observe a half-way
200 mutated cons cell. The lookup procedure can handle this
201 transparently without any critical sections.
203 It is different with macro expansion, because macro expansion
204 happens outside of the lookup procedure and can't be
205 undone. Therefore it can't cope with it. It has to indicate
206 failure when it detects a lost race and hope that the caller can
207 handle it. Luckily, it turns out that this is the case.
209 An example to illustrate this: Suppose that the follwing form will
210 be memoized concurrently by two threads
214 Let's first examine the lookup of X in the body. The first thread
215 decides that it has to find the symbol "x" in the environment and
216 starts to scan it. Then the other thread takes over and actually
217 overtakes the first. It looks up "x" and substitutes an
218 appropriate iloc for it. Now the first thread continues and
219 completes its lookup. It comes to exactly the same conclusions as
220 the second one and could - without much ado - just overwrite the
221 iloc with the same iloc.
223 But let's see what will happen when the race occurs while looking
224 up the symbol "let" at the start of the form. It could happen that
225 the second thread interrupts the lookup of the first thread and not
226 only substitutes a gloc for it but goes right ahead and replaces it
227 with the compiled form (#@let* (x 12) x). Now, when the first
228 thread completes its lookup, it would replace the #@let* with a
229 gloc pointing to the "let" binding, effectively reverting the form
230 to (let (x 12) x). This is wrong. It has to detect that it has
231 lost the race and the evaluator has to reconsider the changed form
234 This race condition could be resolved with some kind of traffic
235 light (like mutexes) around scm_lookupcar, but I think that it is
236 best to avoid them in this case. They would serialize memoization
237 completely and because lookup involves calling arbitrary Scheme
238 code (via the lookup-thunk), threads could be blocked for an
239 arbitrary amount of time or even deadlock. But with the current
240 solution a lot of unnecessary work is potentially done. */
242 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
243 return NULL to indicate a failed lookup due to some race conditions
244 between threads. This only happens when VLOC is the first cell of
245 a special form that will eventually be memoized (like `let', etc.)
246 In that case the whole lookup is bogus and the caller has to
247 reconsider the complete special form.
249 SCM_LOOKUPCAR is still there, of course. It just calls
250 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
251 should only be called when it is known that VLOC is not the first
252 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
253 for NULL. I think I've found the only place where this applies. */
255 #endif /* USE_THREADS */
258 scm_lookupcar1 (SCM vloc
, SCM genv
)
261 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
263 register SCM var2
= var
;
265 #ifdef MEMOIZE_LOCALS
266 register SCM iloc
= SCM_ILOC00
;
268 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
270 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
272 al
= SCM_CARLOC (env
);
273 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
279 #ifdef MEMOIZE_LOCALS
281 if (SCM_CAR (vloc
) != var
)
284 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
286 return SCM_CDRLOC (*al
);
291 al
= SCM_CDRLOC (*al
);
292 if (SCM_CAR (fl
) == var
)
294 #ifdef MEMOIZE_LOCALS
295 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
296 if (SCM_UNBNDP (SCM_CAR (*al
)))
303 if (SCM_CAR (vloc
) != var
)
306 SCM_SETCAR (vloc
, iloc
);
308 return SCM_CARLOC (*al
);
310 #ifdef MEMOIZE_LOCALS
314 #ifdef MEMOIZE_LOCALS
315 iloc
= (~SCM_IDSTMSK
) & (iloc
+ SCM_IFRINC
);
319 SCM top_thunk
, vcell
;
322 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
326 top_thunk
= SCM_BOOL_F
;
327 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
328 if (vcell
== SCM_BOOL_F
)
334 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
338 /* scm_everr (vloc, genv,...) */
339 scm_misc_error (NULL
,
341 ? "Unbound variable: %S"
342 : "Damaged environment: %S",
343 scm_listify (var
, SCM_UNDEFINED
));
347 if (SCM_CAR (vloc
) != var2
)
349 /* Some other thread has changed the very cell we are working
350 on. In effect, it must have done our job or messed it up
353 var
= SCM_CAR (vloc
);
355 return SCM_GLOC_VAL_LOC (var
);
356 #ifdef MEMOIZE_LOCALS
357 if ((var
& 127) == (127 & SCM_ILOC00
))
358 return scm_ilookup (var
, genv
);
360 /* We can't cope with anything else than glocs and ilocs. When
361 a special form has been memoized (i.e. `let' into `#@let') we
362 return NULL and expect the calling function to do the right
363 thing. For the evaluator, this means going back and redoing
364 the dispatch on the car of the form. */
367 #endif /* USE_THREADS */
369 SCM_SETCAR (vloc
, var
+ 1);
370 /* Except wait...what if the var is not a vcell,
371 * but syntax or something.... */
372 return SCM_CDRLOC (var
);
377 scm_lookupcar (vloc
, genv
)
381 SCM
*loc
= scm_lookupcar1 (vloc
, genv
);
386 #else /* not USE_THREADS */
387 #define scm_lookupcar scm_lookupcar1
390 #define unmemocar scm_unmemocar
393 scm_unmemocar (form
, env
)
397 #ifdef DEBUG_EXTENSIONS
406 SCM_SETCAR (form
, SCM_CAR (c
- 1));
407 #ifdef MEMOIZE_LOCALS
408 #ifdef DEBUG_EXTENSIONS
409 else if (SCM_ILOCP (c
))
411 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
413 env
= SCM_CAR (SCM_CAR (env
));
414 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
416 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
425 scm_eval_car (pair
, env
)
429 return XEVALCAR (pair
, env
);
434 * The following rewrite expressions and
435 * some memoized forms have different syntax
438 static char s_expression
[] = "missing or extra expression";
439 static char s_test
[] = "bad test";
440 static char s_body
[] = "bad body";
441 static char s_bindings
[] = "bad bindings";
442 static char s_variable
[] = "bad variable";
443 static char s_clauses
[] = "bad or missing clauses";
444 static char s_formals
[] = "bad formals";
445 #define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr);
447 SCM scm_i_dot
, scm_i_quote
, scm_i_quasiquote
, scm_i_lambda
, scm_i_let
,
448 scm_i_arrow
, scm_i_else
, scm_i_unquote
, scm_i_uq_splicing
, scm_i_apply
;
449 SCM scm_i_define
, scm_i_and
, scm_i_begin
, scm_i_case
, scm_i_cond
,
450 scm_i_do
, scm_i_if
, scm_i_let
, scm_i_letrec
, scm_i_letstar
,
451 scm_i_or
, scm_i_set
, scm_i_atapply
, scm_i_atcall_cc
;
452 static char s_quasiquote
[] = "quasiquote";
453 static char s_delay
[] = "delay";
454 static char s_undefine
[] = "undefine";
455 #ifdef DEBUG_EXTENSIONS
456 SCM scm_i_enter_frame
, scm_i_apply_frame
, scm_i_exit_frame
;
460 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
464 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, char *what
));
467 bodycheck (xorig
, bodyloc
, what
)
472 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, s_expression
);
478 scm_m_quote (xorig
, env
)
482 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, xorig
, s_expression
, "quote");
483 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
489 scm_m_begin (xorig
, env
)
493 ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, xorig
, s_expression
, "begin");
494 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
500 scm_m_if (xorig
, env
)
504 int len
= scm_ilength (SCM_CDR (xorig
));
505 ASSYNT (len
>= 2 && len
<= 3, xorig
, s_expression
, "if");
506 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
512 scm_m_set (xorig
, env
)
516 SCM x
= SCM_CDR (xorig
);
517 ASSYNT (2 == scm_ilength (x
), xorig
, s_expression
, "set!");
518 ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
519 xorig
, s_variable
, "set!");
520 return scm_cons (SCM_IM_SET
, x
);
527 scm_m_vref (xorig
, env
)
531 SCM x
= SCM_CDR (xorig
);
532 ASSYNT (1 == scm_ilength (x
), xorig
, s_expression
, s_vref
);
533 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
535 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
536 scm_misc_error (NULL
,
538 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
540 ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
541 xorig
, s_variable
, s_vref
);
543 return scm_cons (IM_VREF
, x
);
549 scm_m_vset (xorig
, env
)
553 SCM x
= SCM_CDR (xorig
);
554 ASSYNT (3 == scm_ilength (x
), xorig
, s_expression
, s_vset
);
555 ASSYNT (( DEFSCM_VARIABLEP (SCM_CAR (x
))
556 || UDSCM_VARIABLEP (SCM_CAR (x
))),
557 xorig
, s_variable
, s_vset
);
558 return scm_cons (IM_VSET
, x
);
565 scm_m_and (xorig
, env
)
569 int len
= scm_ilength (SCM_CDR (xorig
));
570 ASSYNT (len
>= 0, xorig
, s_test
, "and");
572 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
580 scm_m_or (xorig
, env
)
584 int len
= scm_ilength (SCM_CDR (xorig
));
585 ASSYNT (len
>= 0, xorig
, s_test
, "or");
587 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
595 scm_m_case (xorig
, env
)
599 SCM proc
, x
= SCM_CDR (xorig
);
600 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_clauses
, "case");
601 while (SCM_NIMP (x
= SCM_CDR (x
)))
604 ASSYNT (scm_ilength (proc
) >= 2, xorig
, s_clauses
, "case");
605 ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0 || scm_i_else
== SCM_CAR (proc
),
606 xorig
, s_clauses
, "case");
608 return scm_cons (SCM_IM_CASE
, SCM_CDR (xorig
));
614 scm_m_cond (xorig
, env
)
618 SCM arg1
, x
= SCM_CDR (xorig
);
619 int len
= scm_ilength (x
);
620 ASSYNT (len
>= 1, xorig
, s_clauses
, "cond");
624 len
= scm_ilength (arg1
);
625 ASSYNT (len
>= 1, xorig
, s_clauses
, "cond");
626 if (scm_i_else
== SCM_CAR (arg1
))
628 ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2, xorig
, "bad ELSE clause", "cond");
629 SCM_SETCAR (arg1
, SCM_BOOL_T
);
631 if (len
>= 2 && scm_i_arrow
== SCM_CAR (SCM_CDR (arg1
)))
632 ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
633 xorig
, "bad recipient", "cond");
636 return scm_cons (SCM_IM_COND
, SCM_CDR (xorig
));
642 scm_m_lambda (xorig
, env
)
646 SCM proc
, x
= SCM_CDR (xorig
);
647 if (scm_ilength (x
) < 2)
650 if (SCM_NULLP (proc
))
654 if (SCM_SYMBOLP (proc
))
656 if (SCM_NCONSP (proc
))
658 while (SCM_NIMP (proc
))
660 if (SCM_NCONSP (proc
))
662 if (!SCM_SYMBOLP (proc
))
667 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
669 proc
= SCM_CDR (proc
);
673 badforms
:scm_wta (xorig
, s_formals
, "lambda");
675 bodycheck (xorig
, SCM_CDRLOC (x
), "lambda");
676 return scm_cons (SCM_IM_LAMBDA
, SCM_CDR (xorig
));
682 scm_m_letstar (xorig
, env
)
686 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
687 int len
= scm_ilength (x
);
688 ASSYNT (len
>= 2, xorig
, s_body
, "let*");
690 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "let*");
691 while SCM_NIMP (proc
)
693 arg1
= SCM_CAR (proc
);
694 ASSYNT (2 == scm_ilength (arg1
), xorig
, s_bindings
, "let*");
695 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "let*");
696 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
697 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
698 proc
= SCM_CDR (proc
);
700 x
= scm_cons (vars
, SCM_CDR (x
));
701 bodycheck (xorig
, SCM_CDRLOC (x
), "let*");
702 return scm_cons (SCM_IM_LETSTAR
, x
);
705 /* DO gets the most radically altered syntax
706 (do ((<var1> <init1> <step1>)
712 (do_mem (varn ... var2 var1)
713 (<init1> <init2> ... <initn>)
716 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
722 scm_m_do (xorig
, env
)
726 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
727 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
728 SCM
*initloc
= &inits
, *steploc
= &steps
;
729 int len
= scm_ilength (x
);
730 ASSYNT (len
>= 2, xorig
, s_test
, "do");
732 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "do");
736 arg1
= SCM_CAR (proc
);
737 len
= scm_ilength (arg1
);
738 ASSYNT (2 == len
|| 3 == len
, xorig
, s_bindings
, "do");
739 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "do");
740 /* vars reversed here, inits and steps reversed at evaluation */
741 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
742 arg1
= SCM_CDR (arg1
);
743 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
744 initloc
= SCM_CDRLOC (*initloc
);
745 arg1
= SCM_CDR (arg1
);
746 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
747 steploc
= SCM_CDRLOC (*steploc
);
748 proc
= SCM_CDR (proc
);
751 ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, s_test
, "do");
752 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
753 x
= scm_cons2 (vars
, inits
, x
);
754 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
755 return scm_cons (SCM_IM_DO
, x
);
758 /* evalcar is small version of inline EVALCAR when we don't care about
761 #define evalcar scm_eval_car
764 static SCM iqq
SCM_P ((SCM form
, SCM env
, int depth
));
767 iqq (form
, env
, depth
)
776 if (SCM_VECTORP (form
))
778 long i
= SCM_LENGTH (form
);
779 SCM
*data
= SCM_VELTS (form
);
782 tmp
= scm_cons (data
[i
], tmp
);
783 return scm_vector (iqq (tmp
, env
, depth
));
787 tmp
= SCM_CAR (form
);
788 if (scm_i_quasiquote
== tmp
)
793 if (scm_i_unquote
== tmp
)
797 form
= SCM_CDR (form
);
798 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
799 form
, SCM_ARG1
, s_quasiquote
);
801 return evalcar (form
, env
);
802 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
804 if (SCM_NIMP (tmp
) && (scm_i_uq_splicing
== SCM_CAR (tmp
)))
808 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
810 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
813 /* Here are acros which return values rather than code. */
817 scm_m_quasiquote (xorig
, env
)
821 SCM x
= SCM_CDR (xorig
);
822 ASSYNT (scm_ilength (x
) == 1, xorig
, s_expression
, s_quasiquote
);
823 return iqq (SCM_CAR (x
), env
, 1);
828 scm_m_delay (xorig
, env
)
832 ASSYNT (scm_ilength (xorig
) == 2, xorig
, s_expression
, s_delay
);
833 xorig
= SCM_CDR (xorig
);
834 return scm_makprom (scm_closure (scm_cons2 (SCM_EOL
, SCM_CAR (xorig
), SCM_CDR (xorig
)),
839 static SCM env_top_level
SCM_P ((SCM env
));
845 while (SCM_NIMP(env
))
847 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR(env
)))
856 scm_m_define (x
, env
)
862 /* ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
863 ASSYNT (scm_ilength (x
) >= 2, arg1
, s_expression
, "define");
866 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
867 { /* nested define syntax */
868 x
= scm_cons (scm_cons2 (scm_i_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
869 proc
= SCM_CAR (proc
);
871 ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
), arg1
, s_variable
, "define");
872 ASSYNT (1 == scm_ilength (x
), arg1
, s_expression
, "define");
873 if (SCM_TOP_LEVEL (env
))
875 x
= evalcar (x
, env
);
876 #ifdef DEBUG_EXTENSIONS
877 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
881 if (SCM_CLOSUREP (arg1
)
882 /* Only the first definition determines the name. */
883 && scm_procedure_property (arg1
, scm_i_name
) == SCM_BOOL_F
)
884 scm_set_procedure_property_x (arg1
, scm_i_name
, proc
);
885 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
886 && SCM_CDR (arg1
) != arg1
)
888 arg1
= SCM_CDR (arg1
);
893 arg1
= scm_sym2vcell (proc
, env_top_level (env
), SCM_BOOL_T
);
896 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
897 && (SCM_CDR (arg1
) != x
))
898 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
901 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
902 scm_warn ("redefining ", SCM_CHARS (proc
));
904 SCM_SETCDR (arg1
, x
);
906 return scm_cons2 (scm_i_quote
, SCM_CAR (arg1
), SCM_EOL
);
908 return SCM_UNSPECIFIED
;
911 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
915 scm_m_undefine (x
, env
)
920 ASSYNT (SCM_TOP_LEVEL (env
), arg1
, "bad placement ", s_undefine
);
921 ASSYNT (SCM_NIMP (x
) && SCM_CONSP (x
) && SCM_CDR (x
) == SCM_EOL
,
922 arg1
, s_expression
, s_undefine
);
924 ASSYNT (SCM_NIMP (x
) && SCM_SYMBOLP (x
), arg1
, s_variable
, s_undefine
);
925 arg1
= scm_sym2vcell (x
, env_top_level (env
), SCM_BOOL_F
);
926 ASSYNT (SCM_NFALSEP (arg1
) && !SCM_UNBNDP (SCM_CDR (arg1
)),
927 x
, "variable already unbound ", s_undefine
);
930 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == x
))
931 scm_warn ("undefining built-in ", SCM_CHARS (x
));
934 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
935 scm_warn ("redefining ", SCM_CHARS (x
));
937 SCM_SETCDR (arg1
, SCM_UNDEFINED
);
939 return SCM_CAR (arg1
);
941 return SCM_UNSPECIFIED
;
949 scm_m_letrec (xorig
, env
)
953 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
954 char *what
= SCM_CHARS (SCM_CAR (xorig
));
955 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
956 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
958 ASRTSYNTAX (scm_ilength (x
) >= 2, s_body
);
961 (proc
) return scm_m_letstar (xorig
, env
); /* null binding, let* faster */
962 ASRTSYNTAX (scm_ilength (proc
) >= 1, s_bindings
);
965 /* vars scm_list reversed here, inits reversed at evaluation */
966 arg1
= SCM_CAR (proc
);
967 ASRTSYNTAX (2 == scm_ilength (arg1
), s_bindings
);
968 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), s_variable
);
969 vars
= scm_cons (SCM_CAR (arg1
), vars
);
970 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
971 initloc
= SCM_CDRLOC (*initloc
);
974 (proc
= SCM_CDR (proc
));
975 cdrx
= scm_cons2 (vars
, inits
, SCM_CDR (x
));
976 bodycheck (xorig
, SCM_CDRLOC (SCM_CDR (cdrx
)), what
);
977 return scm_cons (SCM_IM_LETREC
, cdrx
);
982 scm_m_let (xorig
, env
)
986 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
987 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
988 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
990 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_body
, "let");
993 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
994 && SCM_NIMP (SCM_CAR (proc
)) && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
995 return scm_m_letstar (xorig
, env
); /* null or single binding, let* is faster */
996 ASSYNT (SCM_NIMP (proc
), xorig
, s_bindings
, "let");
997 if (SCM_CONSP (proc
)) /* plain let, proc is <bindings> */
998 return scm_cons (SCM_IM_LET
, SCM_CDR (scm_m_letrec (xorig
, env
)));
999 if (!SCM_SYMBOLP (proc
))
1000 scm_wta (xorig
, s_bindings
, "let"); /* bad let */
1001 name
= proc
; /* named let, build equiv letrec */
1003 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_body
, "let");
1004 proc
= SCM_CAR (x
); /* bindings scm_list */
1005 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "let");
1008 { /* vars and inits both in order */
1009 arg1
= SCM_CAR (proc
);
1010 ASSYNT (2 == scm_ilength (arg1
), xorig
, s_bindings
, "let");
1011 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "let");
1012 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1013 varloc
= SCM_CDRLOC (*varloc
);
1014 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1015 initloc
= SCM_CDRLOC (*initloc
);
1016 proc
= SCM_CDR (proc
);
1019 scm_m_letrec (scm_cons2 (scm_i_let
,
1020 scm_cons (scm_cons2 (name
, scm_cons2 (scm_i_lambda
, vars
, SCM_CDR (x
)), SCM_EOL
), SCM_EOL
),
1021 scm_acons (name
, inits
, SCM_EOL
)), /* body */
1028 scm_m_apply (xorig
, env
)
1032 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, xorig
, s_expression
, "@apply");
1033 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1036 #define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
1040 scm_m_cont (xorig
, env
)
1044 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, xorig
, s_expression
, "@call-with-current-continuation");
1045 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1048 /* scm_unmemocopy takes a memoized expression together with its
1049 * environment and rewrites it to its original form. Thus, it is the
1050 * inversion of the rewrite rules above. The procedure is not
1051 * optimized for speed. It's used in scm_iprin1 when printing the
1052 * code of a closure, in scm_procedure_source, in display_frame when
1053 * generating the source for a stackframe in a backtrace, and in
1054 * display_expression.
1057 static SCM unmemocopy
SCM_P ((SCM x
, SCM env
));
1065 #ifdef DEBUG_EXTENSIONS
1068 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1070 #ifdef DEBUG_EXTENSIONS
1071 p
= scm_whash_lookup (scm_source_whash
, x
);
1073 switch (SCM_TYP7 (x
))
1075 case (127 & SCM_IM_AND
):
1076 ls
= z
= scm_cons (scm_i_and
, SCM_UNSPECIFIED
);
1078 case (127 & SCM_IM_BEGIN
):
1079 ls
= z
= scm_cons (scm_i_begin
, SCM_UNSPECIFIED
);
1081 case (127 & SCM_IM_CASE
):
1082 ls
= z
= scm_cons (scm_i_case
, SCM_UNSPECIFIED
);
1084 case (127 & SCM_IM_COND
):
1085 ls
= z
= scm_cons (scm_i_cond
, SCM_UNSPECIFIED
);
1087 case (127 & SCM_IM_DO
):
1088 ls
= scm_cons (scm_i_do
, SCM_UNSPECIFIED
);
1090 case (127 & SCM_IM_IF
):
1091 ls
= z
= scm_cons (scm_i_if
, SCM_UNSPECIFIED
);
1093 case (127 & SCM_IM_LET
):
1094 ls
= scm_cons (scm_i_let
, SCM_UNSPECIFIED
);
1096 case (127 & SCM_IM_LETREC
):
1099 ls
= scm_cons (scm_i_letrec
, SCM_UNSPECIFIED
);
1102 f
= v
= SCM_CAR (x
);
1104 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1105 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1106 SCM_CAR (ls
) == scm_i_letrec
? z
: env
));
1108 s
= SCM_CAR (ls
) == scm_i_do
1109 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1114 z
= scm_acons (SCM_CAR (v
),
1115 scm_cons (SCM_CAR (e
),
1116 SCM_CAR (s
) == SCM_CAR (v
)
1118 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1125 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1127 if (SCM_CAR (ls
) == scm_i_do
)
1130 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1133 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1137 case (127 & SCM_IM_LETSTAR
):
1145 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1148 y
= z
= scm_acons (SCM_CAR (b
),
1150 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1152 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1153 b
= SCM_CDR (SCM_CDR (b
));
1156 SCM_SETCDR (y
, SCM_EOL
);
1157 ls
= scm_cons (scm_i_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1162 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1164 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1167 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1168 b
= SCM_CDR (SCM_CDR (b
));
1171 SCM_SETCDR (z
, SCM_EOL
);
1173 ls
= scm_cons (scm_i_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1176 case (127 & SCM_IM_OR
):
1177 ls
= z
= scm_cons (scm_i_or
, SCM_UNSPECIFIED
);
1179 case (127 & SCM_IM_LAMBDA
):
1181 ls
= scm_cons (scm_i_lambda
,
1182 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1183 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1185 case (127 & SCM_IM_QUOTE
):
1186 ls
= z
= scm_cons (scm_i_quote
, SCM_UNSPECIFIED
);
1188 case (127 & SCM_IM_SET
):
1189 ls
= z
= scm_cons (scm_i_set
, SCM_UNSPECIFIED
);
1191 case (127 & SCM_IM_DEFINE
):
1195 ls
= scm_cons (scm_i_define
,
1196 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1197 if (SCM_NNULLP (env
))
1198 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1201 case (127 & SCM_MAKISYM (0)):
1205 switch SCM_ISYMNUM (z
)
1207 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1208 ls
= z
= scm_cons (scm_i_atapply
, SCM_UNSPECIFIED
);
1210 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1211 ls
= z
= scm_cons (scm_i_atcall_cc
, SCM_UNSPECIFIED
);
1214 /* appease the Sun compiler god: */ ;
1218 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1223 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1225 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1231 #ifdef DEBUG_EXTENSIONS
1232 if (SCM_NFALSEP (p
))
1233 scm_whash_insert (scm_source_whash
, ls
, p
);
1240 scm_unmemocopy (x
, env
)
1244 if (SCM_NNULLP (env
))
1245 /* Make a copy of the lowest frame to protect it from
1246 modifications by SCM_IM_DEFINE */
1247 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1249 return unmemocopy (x
, env
);
1252 #ifndef SCM_RECKLESS
1255 scm_badargsp (formals
, args
)
1266 formals
= SCM_CDR (formals
);
1267 args
= SCM_CDR (args
);
1269 return SCM_NNULLP (args
) ? 1 : 0;
1275 long scm_tc16_macro
;
1279 scm_eval_args (l
, env
, proc
)
1284 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1285 while (SCM_NIMP (l
))
1290 else if (SCM_CONSP (l
))
1292 if (SCM_IMP (SCM_CAR (l
)))
1293 res
= EVALIM (SCM_CAR (l
), env
);
1295 res
= EVALCELLCAR (l
, env
);
1297 else if (SCM_TYP3 (l
) == 1)
1299 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1300 res
= SCM_CAR (l
); /* struct planted in code */
1305 res
= EVALCAR (l
, env
);
1307 *lloc
= scm_cons (res
, SCM_EOL
);
1308 lloc
= SCM_CDRLOC (*lloc
);
1315 scm_wrong_num_args (proc
);
1325 /* SECTION: This code is specific for the debugging support. One
1326 * branch is read when DEVAL isn't defined, the other when DEVAL is
1332 #define SCM_APPLY scm_apply
1333 #define PREP_APPLY(proc, args)
1335 #define RETURN(x) return x;
1336 #ifdef STACK_CHECKING
1337 #ifndef NO_CEVAL_STACK_CHECKING
1338 #define EVAL_STACK_CHECKING
1345 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1347 #define SCM_APPLY scm_dapply
1349 #define PREP_APPLY(p, l) \
1350 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1352 #define ENTER_APPLY \
1354 SCM_SET_ARGSREADY (debug);\
1355 if (CHECK_APPLY && SCM_TRAPS_P)\
1356 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1358 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1359 SCM_SET_TRACED_FRAME (debug); \
1360 if (SCM_CHEAPTRAPS_P)\
1362 tmp = scm_make_debugobj (&debug);\
1363 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1367 scm_make_cont (&tmp);\
1368 if (!setjmp (SCM_JMPBUF (tmp)))\
1369 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1374 #define RETURN(e) {proc = (e); goto exit;}
1375 #ifdef STACK_CHECKING
1376 #ifndef EVAL_STACK_CHECKING
1377 #define EVAL_STACK_CHECKING
1381 /* scm_ceval_ptr points to the currently selected evaluator.
1382 * *fixme*: Although efficiency is important here, this state variable
1383 * should probably not be a global. It should be related to the
1388 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1390 /* scm_last_debug_frame contains a pointer to the last debugging
1391 * information stack frame. It is accessed very often from the
1392 * debugging evaluator, so it should probably not be indirectly
1393 * addressed. Better to save and restore it from the current root at
1398 scm_debug_frame
*scm_last_debug_frame
;
1401 /* scm_debug_eframe_size is the number of slots available for pseudo
1402 * stack frames at each real stack frame.
1405 int scm_debug_eframe_size
;
1407 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1411 scm_option scm_eval_opts
[] = {
1412 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1415 scm_option scm_debug_opts
[] = {
1416 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1417 "*Flyweight representation of the stack at traps." },
1418 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1419 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1420 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1421 "Record procedure names at definition." },
1422 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1423 "Display backtrace in anti-chronological order." },
1424 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1425 { SCM_OPTION_INTEGER
, "frames", 3,
1426 "Maximum number of tail-recursive frames in backtrace." },
1427 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1428 "Maximal number of stored backtrace frames." },
1429 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1430 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1431 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1432 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1435 scm_option scm_evaluator_trap_table
[] = {
1436 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1437 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1438 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1439 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1442 SCM_PROC (s_eval_options_interface
, "eval-options-interface", 0, 1, 0, scm_eval_options_interface
);
1445 scm_eval_options_interface (SCM setting
)
1449 ans
= scm_options (setting
,
1452 s_eval_options_interface
);
1453 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1458 SCM_PROC (s_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps
);
1461 scm_evaluator_traps (setting
)
1466 ans
= scm_options (setting
,
1467 scm_evaluator_trap_table
,
1468 SCM_N_EVALUATOR_TRAPS
,
1470 SCM_RESET_DEBUG_MODE
;
1476 scm_deval_args (l
, env
, proc
, lloc
)
1477 SCM l
, env
, proc
, *lloc
;
1479 SCM
*results
= lloc
, res
;
1480 while (SCM_NIMP (l
))
1485 else if (SCM_CONSP (l
))
1487 if (SCM_IMP (SCM_CAR (l
)))
1488 res
= EVALIM (SCM_CAR (l
), env
);
1490 res
= EVALCELLCAR (l
, env
);
1492 else if (SCM_TYP3 (l
) == 1)
1494 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1495 res
= SCM_CAR (l
); /* struct planted in code */
1500 res
= EVALCAR (l
, env
);
1502 *lloc
= scm_cons (res
, SCM_EOL
);
1503 lloc
= SCM_CDRLOC (*lloc
);
1510 scm_wrong_num_args (proc
);
1519 /* SECTION: Some local definitions for the evaluator.
1524 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1526 #define CHECK_EQVISH(A,B) ((A) == (B))
1530 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1532 /* SECTION: This is the evaluator. Like any real monster, it has
1533 * three heads. This code is compiled twice.
1565 scm_debug_frame debug
;
1566 scm_debug_info
*debug_info_end
;
1567 debug
.prev
= scm_last_debug_frame
;
1568 debug
.status
= scm_debug_eframe_size
;
1569 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1570 * sizeof (debug
.vect
[0]));
1571 debug
.info
= debug
.vect
;
1572 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1573 scm_last_debug_frame
= &debug
;
1575 #ifdef EVAL_STACK_CHECKING
1576 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1577 && scm_stack_checking_enabled_p
)
1580 debug
.info
->e
.exp
= x
;
1581 debug
.info
->e
.env
= env
;
1583 scm_report_stack_overflow ();
1590 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1593 SCM_CLEAR_ARGSREADY (debug
);
1594 if (SCM_OVERFLOWP (debug
))
1596 else if (++debug
.info
>= debug_info_end
)
1598 SCM_SET_OVERFLOW (debug
);
1602 debug
.info
->e
.exp
= x
;
1603 debug
.info
->e
.env
= env
;
1604 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1605 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1607 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1608 SCM_SET_TAILREC (debug
);
1609 if (SCM_CHEAPTRAPS_P
)
1610 t
.arg1
= scm_make_debugobj (&debug
);
1613 scm_make_cont (&t
.arg1
);
1614 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1616 x
= SCM_THROW_VALUE (t
.arg1
);
1622 /* This gives the possibility for the debugger to
1623 modify the source expression before evaluation. */
1627 scm_ithrow (scm_i_enter_frame
,
1628 scm_cons2 (t
.arg1
, tail
,
1629 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1633 #if defined (USE_THREADS) || defined (DEVAL)
1637 switch (SCM_TYP7 (x
))
1639 case scm_tcs_symbols
:
1640 /* Only happens when called at top level.
1642 x
= scm_cons (x
, SCM_UNDEFINED
);
1645 case (127 & SCM_IM_AND
):
1648 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1649 if (SCM_FALSEP (EVALCAR (x
, env
)))
1651 RETURN (SCM_BOOL_F
);
1655 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1658 case (127 & SCM_IM_BEGIN
):
1660 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1666 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1668 SIDEVAL (SCM_CAR (x
), env
);
1672 carloop
: /* scm_eval car of last form in list */
1673 if (SCM_NCELLP (SCM_CAR (x
)))
1676 RETURN (SCM_IMP (x
) ? EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1679 if (SCM_SYMBOLP (SCM_CAR (x
)))
1682 RETURN (*scm_lookupcar (x
, env
))
1686 goto loop
; /* tail recurse */
1689 case (127 & SCM_IM_CASE
):
1691 t
.arg1
= EVALCAR (x
, env
);
1692 while (SCM_NIMP (x
= SCM_CDR (x
)))
1695 if (scm_i_else
== SCM_CAR (proc
))
1698 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1701 proc
= SCM_CAR (proc
);
1702 while (SCM_NIMP (proc
))
1704 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1706 x
= SCM_CDR (SCM_CAR (x
));
1707 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1710 proc
= SCM_CDR (proc
);
1713 RETURN (SCM_UNSPECIFIED
)
1716 case (127 & SCM_IM_COND
):
1717 while (SCM_NIMP (x
= SCM_CDR (x
)))
1720 t
.arg1
= EVALCAR (proc
, env
);
1721 if (SCM_NFALSEP (t
.arg1
))
1728 if (scm_i_arrow
!= SCM_CAR (x
))
1730 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1734 proc
= EVALCAR (proc
, env
);
1735 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1736 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1741 RETURN (SCM_UNSPECIFIED
)
1744 case (127 & SCM_IM_DO
):
1746 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1747 t
.arg1
= SCM_EOL
; /* values */
1748 while (SCM_NIMP (proc
))
1750 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1751 proc
= SCM_CDR (proc
);
1753 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1754 x
= SCM_CDR (SCM_CDR (x
));
1755 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
1757 for (proc
= SCM_CAR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1759 t
.arg1
= SCM_CAR (proc
); /* body */
1760 SIDEVAL (t
.arg1
, env
);
1762 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1763 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
1764 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
1768 RETURN (SCM_UNSPECIFIED
);
1769 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1773 case (127 & SCM_IM_IF
):
1775 if (SCM_NFALSEP (EVALCAR (x
, env
)))
1777 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
1779 RETURN (SCM_UNSPECIFIED
);
1781 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1785 case (127 & SCM_IM_LET
):
1787 proc
= SCM_CAR (SCM_CDR (x
));
1791 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1793 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1794 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1799 case (127 & SCM_IM_LETREC
):
1801 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
1807 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1809 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1810 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
1814 case (127 & SCM_IM_LETSTAR
):
1819 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1824 t
.arg1
= SCM_CAR (proc
);
1825 proc
= SCM_CDR (proc
);
1826 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
1828 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1831 case (127 & SCM_IM_OR
):
1834 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1836 x
= EVALCAR (x
, env
);
1837 if (SCM_NFALSEP (x
))
1843 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1847 case (127 & SCM_IM_LAMBDA
):
1848 RETURN (scm_closure (SCM_CDR (x
), env
));
1851 case (127 & SCM_IM_QUOTE
):
1852 RETURN (SCM_CAR (SCM_CDR (x
)));
1855 case (127 & SCM_IM_SET
):
1858 switch (7 & (int) proc
)
1861 t
.lloc
= scm_lookupcar (x
, env
);
1864 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
1866 #ifdef MEMOIZE_LOCALS
1868 t
.lloc
= scm_ilookup (proc
, env
);
1873 *t
.lloc
= EVALCAR (x
, env
);
1877 RETURN (SCM_UNSPECIFIED
);
1881 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
1885 x
= evalcar (x
, env
);
1886 #ifdef DEBUG_EXTENSIONS
1887 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
1891 if (SCM_CLOSUREP (t
.arg1
)
1892 /* Only the first definition determines the name. */
1893 && (scm_procedure_property (t
.arg1
, scm_i_inner_name
)
1895 scm_set_procedure_property_x (t
.arg1
, scm_i_inner_name
, proc
);
1896 else if (SCM_TYP16 (t
.arg1
) == scm_tc16_macro
1897 && SCM_CDR (t
.arg1
) != t
.arg1
)
1899 t
.arg1
= SCM_CDR (t
.arg1
);
1904 env
= SCM_CAR (env
);
1906 SCM_SETCAR (env
, scm_cons (proc
, SCM_CAR (env
)));
1907 SCM_SETCDR (env
, scm_cons (x
, SCM_CDR (env
)));
1909 RETURN (SCM_UNSPECIFIED
);
1912 /* new syntactic forms go here. */
1913 case (127 & SCM_MAKISYM (0)):
1915 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
1916 switch SCM_ISYMNUM (proc
)
1919 case (SCM_ISYMNUM (IM_VREF
)):
1922 var
= SCM_CAR (SCM_CDR (x
));
1923 RETURN (SCM_CDR(var
));
1925 case (SCM_ISYMNUM (IM_VSET
)):
1926 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
1927 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
1928 RETURN (SCM_UNSPECIFIED
)
1931 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1933 proc
= EVALCAR (proc
, env
);
1934 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1935 if (SCM_CLOSUREP (proc
))
1938 PREP_APPLY (proc
, SCM_EOL
);
1939 t
.arg1
= SCM_CDR (SCM_CDR (x
));
1940 t
.arg1
= EVALCAR (t
.arg1
, env
);
1942 debug
.info
->a
.args
= t
.arg1
;
1944 #ifndef SCM_RECKLESS
1945 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
1948 /* Copy argument list */
1949 if (SCM_IMP (t
.arg1
))
1953 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
1954 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
1955 && SCM_CONSP (t
.arg1
))
1957 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
1961 SCM_SETCDR (tl
, t
.arg1
);
1964 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
1965 x
= SCM_CODE (proc
);
1971 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1972 scm_make_cont (&t
.arg1
);
1973 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1976 val
= SCM_THROW_VALUE (t
.arg1
);
1980 proc
= evalcar (proc
, env
);
1981 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1982 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1993 /* scm_everr (x, env,...) */
1994 scm_misc_error (NULL
,
1995 "Wrong type to apply: %S",
1996 scm_listify (proc
, SCM_UNDEFINED
));
1997 case scm_tc7_vector
:
2000 case scm_tc7_byvect
:
2008 case scm_tc7_llvect
:
2010 case scm_tc7_string
:
2011 case scm_tc7_substring
:
2013 case scm_tcs_closures
:
2017 #ifdef MEMOIZE_LOCALS
2018 case (127 & SCM_ILOC00
):
2019 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2020 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2021 #ifndef SCM_RECKLESS
2027 #endif /* ifdef MEMOIZE_LOCALS */
2030 case scm_tcs_cons_gloc
:
2031 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2032 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2033 #ifndef SCM_RECKLESS
2041 case scm_tcs_cons_nimcar
:
2042 if (SCM_SYMBOLP (SCM_CAR (x
)))
2045 t
.lloc
= scm_lookupcar1 (x
, env
);
2048 /* we have lost the race, start again. */
2053 proc
= *scm_lookupcar (x
, env
);
2061 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2066 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2067 scm_cons (env
, scm_listofnull
));
2069 switch ((int) (SCM_CAR (proc
) >> 16))
2072 if (scm_ilength (t
.arg1
) <= 0)
2073 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2075 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2078 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2079 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2080 /* Prevent memoizing result of define macro */
2082 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2083 scm_set_source_properties_x (debug
.info
->e
.exp
,
2084 scm_source_properties (x
));
2088 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2089 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2093 /* Prevent memoizing of debug info expression. */
2094 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2095 scm_set_source_properties_x (debug
.info
->e
.exp
,
2096 scm_source_properties (x
));
2099 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2100 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2104 if (SCM_NIMP (x
= t
.arg1
))
2112 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2113 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2114 #ifndef SCM_RECKLESS
2118 if (SCM_CLOSUREP (proc
))
2120 arg2
= SCM_CAR (SCM_CODE (proc
));
2121 t
.arg1
= SCM_CDR (x
);
2122 while (SCM_NIMP (arg2
))
2124 if (SCM_NCONSP (arg2
))
2126 if (SCM_IMP (t
.arg1
))
2127 goto umwrongnumargs
;
2128 arg2
= SCM_CDR (arg2
);
2129 t
.arg1
= SCM_CDR (t
.arg1
);
2131 if (SCM_NNULLP (t
.arg1
))
2132 goto umwrongnumargs
;
2134 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2135 goto handle_a_macro
;
2141 PREP_APPLY (proc
, SCM_EOL
);
2142 if (SCM_NULLP (SCM_CDR (x
))) {
2144 switch (SCM_TYP7 (proc
))
2145 { /* no arguments given */
2146 case scm_tc7_subr_0
:
2147 RETURN (SCM_SUBRF (proc
) ());
2148 case scm_tc7_subr_1o
:
2149 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2151 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2152 case scm_tc7_rpsubr
:
2153 RETURN (SCM_BOOL_T
);
2155 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2159 proc
= SCM_CCLO_SUBR (proc
);
2161 debug
.info
->a
.proc
= proc
;
2162 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2166 case scm_tcs_closures
:
2167 x
= SCM_CODE (proc
);
2168 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2170 case scm_tcs_cons_gloc
:
2171 if (SCM_I_OPERATORP (proc
))
2173 x
= (SCM_I_ENTITYP (proc
)
2174 ? SCM_ENTITY_PROC_0 (proc
)
2175 : SCM_OPERATOR_PROC_0 (proc
));
2178 if (SCM_TYP7 (x
) == scm_tc7_subr_1
)
2179 RETURN (SCM_SUBRF (x
) (proc
))
2180 else if (SCM_CLOSUREP (x
))
2185 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2186 debug
.info
->a
.proc
= proc
;
2193 case scm_tc7_contin
:
2194 case scm_tc7_subr_1
:
2195 case scm_tc7_subr_2
:
2196 case scm_tc7_subr_2o
:
2198 case scm_tc7_subr_3
:
2199 case scm_tc7_lsubr_2
:
2203 /* scm_everr (x, env,...) */
2204 scm_wrong_num_args (proc
);
2206 /* handle macros here */
2211 /* must handle macros by here */
2216 else if (SCM_CONSP (x
))
2218 if (SCM_IMP (SCM_CAR (x
)))
2219 t
.arg1
= EVALIM (SCM_CAR (x
), env
);
2221 t
.arg1
= EVALCELLCAR (x
, env
);
2223 else if (SCM_TYP3 (x
) == 1)
2225 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2226 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2231 t
.arg1
= EVALCAR (x
, env
);
2234 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2241 switch (SCM_TYP7 (proc
))
2242 { /* have one argument in t.arg1 */
2243 case scm_tc7_subr_2o
:
2244 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2245 case scm_tc7_subr_1
:
2246 case scm_tc7_subr_1o
:
2247 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2250 if (SCM_SUBRF (proc
))
2252 if (SCM_INUMP (t
.arg1
))
2254 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2257 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2258 if (SCM_REALP (t
.arg1
))
2260 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2263 if (SCM_BIGP (t
.arg1
))
2265 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2269 scm_wta (t
.arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2272 proc
= (SCM
) SCM_SNAME (proc
);
2274 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2275 while ('c' != *--chrs
)
2277 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2278 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2279 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2283 case scm_tc7_rpsubr
:
2284 RETURN (SCM_BOOL_T
);
2286 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2289 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2291 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2297 proc
= SCM_CCLO_SUBR (proc
);
2299 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2300 debug
.info
->a
.proc
= proc
;
2304 case scm_tcs_closures
:
2306 x
= SCM_CODE (proc
);
2308 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2310 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2313 case scm_tc7_contin
:
2314 scm_call_continuation (proc
, t
.arg1
);
2315 case scm_tcs_cons_gloc
:
2316 if (SCM_I_OPERATORP (proc
))
2318 x
= (SCM_I_ENTITYP (proc
)
2319 ? SCM_ENTITY_PROC_1 (proc
)
2320 : SCM_OPERATOR_PROC_1 (proc
));
2323 if (SCM_TYP7 (x
) == scm_tc7_subr_2
)
2324 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
))
2325 else if (SCM_CLOSUREP (x
))
2331 debug
.info
->a
.args
= scm_cons (t
.arg1
,
2332 debug
.info
->a
.args
);
2333 debug
.info
->a
.proc
= proc
;
2340 case scm_tc7_subr_2
:
2341 case scm_tc7_subr_0
:
2342 case scm_tc7_subr_3
:
2343 case scm_tc7_lsubr_2
:
2352 else if (SCM_CONSP (x
))
2354 if (SCM_IMP (SCM_CAR (x
)))
2355 arg2
= EVALIM (SCM_CAR (x
), env
);
2357 arg2
= EVALCELLCAR (x
, env
);
2359 else if (SCM_TYP3 (x
) == 1)
2361 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2362 arg2
= SCM_CAR (x
); /* struct planted in code */
2367 arg2
= EVALCAR (x
, env
);
2369 { /* have two or more arguments */
2371 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2374 if (SCM_NULLP (x
)) {
2379 switch (SCM_TYP7 (proc
))
2380 { /* have two arguments */
2381 case scm_tc7_subr_2
:
2382 case scm_tc7_subr_2o
:
2383 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2386 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2388 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2390 case scm_tc7_lsubr_2
:
2391 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2392 case scm_tc7_rpsubr
:
2394 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2399 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2400 scm_cons (debug
.info
->a
.args
, SCM_EOL
)));
2402 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2403 scm_cons2 (t
.arg1
, arg2
,
2404 scm_cons (scm_eval_args (x
, env
, proc
),
2407 /* case scm_tc7_cclo:
2408 x = scm_cons(arg2, scm_eval_args(x, env));
2411 proc = SCM_CCLO_SUBR(proc);
2414 case scm_tcs_cons_gloc
:
2415 if (SCM_I_OPERATORP (proc
))
2417 x
= (SCM_I_ENTITYP (proc
)
2418 ? SCM_ENTITY_PROC_2 (proc
)
2419 : SCM_OPERATOR_PROC_2 (proc
));
2422 if (SCM_TYP7 (x
) == scm_tc7_subr_3
)
2423 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
, arg2
))
2424 else if (SCM_CLOSUREP (x
))
2427 SCM_SET_ARGSREADY (debug
);
2428 debug
.info
->a
.args
= scm_cons (proc
,
2429 debug
.info
->a
.args
);
2430 debug
.info
->a
.proc
= x
;
2432 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (x
)),
2433 scm_cons2 (proc
, t
.arg1
,
2434 scm_cons (arg2
, SCM_EOL
)),
2442 case scm_tc7_subr_0
:
2444 case scm_tc7_subr_1o
:
2445 case scm_tc7_subr_1
:
2446 case scm_tc7_subr_3
:
2447 case scm_tc7_contin
:
2451 case scm_tcs_closures
:
2454 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2458 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2459 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2461 x
= SCM_CODE (proc
);
2466 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2470 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2471 scm_deval_args (x
, env
, proc
,
2472 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2475 switch (SCM_TYP7 (proc
))
2476 { /* have 3 or more arguments */
2478 case scm_tc7_subr_3
:
2479 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2480 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2481 SCM_CADDR (debug
.info
->a
.args
)));
2483 #ifdef BUILTIN_RPASUBR
2484 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2485 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2488 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2489 arg2
= SCM_CDR (arg2
);
2491 while (SCM_NIMP (arg2
));
2493 #endif /* BUILTIN_RPASUBR */
2494 case scm_tc7_rpsubr
:
2495 #ifdef BUILTIN_RPASUBR
2496 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2498 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2501 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2503 arg2
= SCM_CAR (t
.arg1
);
2504 t
.arg1
= SCM_CDR (t
.arg1
);
2506 while (SCM_NIMP (t
.arg1
));
2508 #else /* BUILTIN_RPASUBR */
2509 RETURN (SCM_APPLY (proc
, t
.arg1
,
2511 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
2513 #endif /* BUILTIN_RPASUBR */
2514 case scm_tc7_lsubr_2
:
2515 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2516 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2518 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2523 case scm_tcs_closures
:
2524 SCM_SET_ARGSREADY (debug
);
2525 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2528 x
= SCM_CODE (proc
);
2531 case scm_tc7_subr_3
:
2532 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2533 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
2535 #ifdef BUILTIN_RPASUBR
2536 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
2539 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
2542 while (SCM_NIMP (x
));
2544 #endif /* BUILTIN_RPASUBR */
2545 case scm_tc7_rpsubr
:
2546 #ifdef BUILTIN_RPASUBR
2547 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2551 t
.arg1
= EVALCAR (x
, env
);
2552 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
2557 while (SCM_NIMP (x
));
2559 #else /* BUILTIN_RPASUBR */
2560 RETURN (SCM_APPLY (proc
, t
.arg1
,
2562 scm_eval_args (x
, env
, proc
),
2564 #endif /* BUILTIN_RPASUBR */
2565 case scm_tc7_lsubr_2
:
2566 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
2568 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
2570 scm_eval_args (x
, env
, proc
))));
2575 case scm_tcs_closures
:
2577 SCM_SET_ARGSREADY (debug
);
2579 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2582 scm_eval_args (x
, env
, proc
)),
2584 x
= SCM_CODE (proc
);
2587 case scm_tcs_cons_gloc
:
2588 if (SCM_I_OPERATORP (proc
))
2590 SCM p
= (SCM_I_ENTITYP (proc
)
2591 ? SCM_ENTITY_PROC_3 (proc
)
2592 : SCM_OPERATOR_PROC_3 (proc
));
2595 if (SCM_TYP7 (p
) == scm_tc7_lsubr_2
)
2597 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2598 scm_cons (arg2
, SCM_CDDR (debug
.info
->a
.args
))))
2600 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2602 scm_eval_args (x
, env
, proc
))))
2604 else if (SCM_CLOSUREP (p
))
2607 SCM_SET_ARGSREADY (debug
);
2608 debug
.info
->a
.args
= scm_cons (proc
, debug
.info
->a
.args
);
2609 debug
.info
->a
.proc
= p
;
2610 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2611 scm_cons2 (proc
, t
.arg1
,
2613 SCM_CDDDR (debug
.info
->a
.args
))),
2616 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2617 scm_cons2 (proc
, t
.arg1
,
2619 scm_eval_args (x
, env
, proc
))),
2628 case scm_tc7_subr_2
:
2629 case scm_tc7_subr_1o
:
2630 case scm_tc7_subr_2o
:
2631 case scm_tc7_subr_0
:
2633 case scm_tc7_subr_1
:
2634 case scm_tc7_contin
:
2642 if (CHECK_EXIT
&& SCM_TRAPS_P
)
2643 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2645 SCM_CLEAR_TRACED_FRAME (debug
);
2646 if (SCM_CHEAPTRAPS_P
)
2647 t
.arg1
= scm_make_debugobj (&debug
);
2650 scm_make_cont (&t
.arg1
);
2651 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2653 proc
= SCM_THROW_VALUE (t
.arg1
);
2657 scm_ithrow (scm_i_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
2660 scm_last_debug_frame
= debug
.prev
;
2666 /* SECTION: This code is compiled once.
2671 SCM_PROC(s_procedure_documentation
, "procedure-documentation", 1, 0, 0, scm_procedure_documentation
);
2674 scm_procedure_documentation (proc
)
2678 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
) && SCM_NIMP (proc
) && SCM_TYP7 (proc
) != scm_tc7_contin
,
2679 proc
, SCM_ARG1
, s_procedure_documentation
);
2680 switch (SCM_TYP7 (proc
))
2682 case scm_tcs_closures
:
2683 code
= SCM_CDR (SCM_CODE (proc
));
2684 if (SCM_IMP (SCM_CDR (code
)))
2686 code
= SCM_CAR (code
);
2689 if (SCM_STRINGP (code
))
2702 /* This code processes the arguments to apply:
2704 (apply PROC ARG1 ... ARGS)
2706 Given a list (ARG1 ... ARGS), this function conses the ARG1
2707 ... arguments onto the front of ARGS, and returns the resulting
2708 list. Note that ARGS is a list; thus, the argument to this
2709 function is a list whose last element is a list.
2711 Apply calls this function, and applies PROC to the elements of the
2712 result. apply:nconc2last takes care of building the list of
2713 arguments, given (ARG1 ... ARGS).
2715 Rather than do new consing, apply:nconc2last destroys its argument.
2716 On that topic, this code came into my care with the following
2717 beautifully cryptic comment on that topic: "This will only screw
2718 you if you do (scm_apply scm_apply '( ... ))" If you know what
2719 they're referring to, send me a patch to this comment. */
2721 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
2724 scm_nconc2last (lst
)
2728 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
2730 while (SCM_NNULLP (SCM_CDR (*lloc
)))
2731 lloc
= SCM_CDRLOC (*lloc
);
2732 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
2733 *lloc
= SCM_CAR (*lloc
);
2740 /* SECTION: When DEVAL is defined this code yields scm_dapply.
2741 * It is compiled twice.
2747 scm_apply (proc
, arg1
, args
)
2757 scm_dapply (proc
, arg1
, args
)
2765 /* Apply a function to a list of arguments.
2767 This function is exported to the Scheme level as taking two
2768 required arguments and a tail argument, as if it were:
2769 (lambda (proc arg1 . args) ...)
2770 Thus, if you just have a list of arguments to pass to a procedure,
2771 pass the list as ARG1, and '() for ARGS. If you have some fixed
2772 args, pass the first as ARG1, then cons any remaining fixed args
2773 onto the front of your argument list, and pass that as ARGS. */
2776 SCM_APPLY (proc
, arg1
, args
)
2781 #ifdef DEBUG_EXTENSIONS
2783 scm_debug_frame debug
;
2784 scm_debug_info debug_vect_body
;
2785 debug
.prev
= scm_last_debug_frame
;
2786 debug
.status
= SCM_APPLYFRAME
;
2787 debug
.vect
= &debug_vect_body
;
2788 debug
.vect
[0].a
.proc
= proc
;
2789 debug
.vect
[0].a
.args
= SCM_EOL
;
2790 scm_last_debug_frame
= &debug
;
2793 return scm_dapply (proc
, arg1
, args
);
2797 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
2799 /* If ARGS is the empty list, then we're calling apply with only two
2800 arguments --- ARG1 is the list of arguments for PROC. Whatever
2801 the case, futz with things so that ARG1 is the first argument to
2802 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
2805 Setting the debug apply frame args this way is pretty messy.
2806 Perhaps we should store arg1 and args directly in the frame as
2807 received, and let scm_frame_arguments unpack them, because that's
2808 a relatively rare operation. This works for now; if the Guile
2809 developer archives are still around, see Mikael's post of
2811 if (SCM_NULLP (args
))
2813 if (SCM_NULLP (arg1
))
2815 arg1
= SCM_UNDEFINED
;
2817 debug
.vect
[0].a
.args
= SCM_EOL
;
2823 debug
.vect
[0].a
.args
= arg1
;
2825 args
= SCM_CDR (arg1
);
2826 arg1
= SCM_CAR (arg1
);
2831 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
2832 args
= scm_nconc2last (args
);
2834 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2838 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
2841 if (SCM_CHEAPTRAPS_P
)
2842 tmp
= scm_make_debugobj (&debug
);
2845 scm_make_cont (&tmp
);
2846 if (setjmp (SCM_JMPBUF (tmp
)))
2849 scm_ithrow (scm_i_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
2857 switch (SCM_TYP7 (proc
))
2859 case scm_tc7_subr_2o
:
2860 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
2861 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2862 case scm_tc7_subr_2
:
2863 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
2865 args
= SCM_CAR (args
);
2866 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2867 case scm_tc7_subr_0
:
2868 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
2869 RETURN (SCM_SUBRF (proc
) ())
2870 case scm_tc7_subr_1
:
2871 case scm_tc7_subr_1o
:
2872 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2873 RETURN (SCM_SUBRF (proc
) (arg1
))
2875 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2877 if (SCM_SUBRF (proc
))
2879 if (SCM_INUMP (arg1
))
2881 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
2883 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
2884 if (SCM_REALP (arg1
))
2886 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
2891 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
2894 scm_wta (arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2897 proc
= (SCM
) SCM_SNAME (proc
);
2899 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2900 while ('c' != *--chrs
)
2902 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
2903 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2904 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2908 case scm_tc7_subr_3
:
2909 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
2912 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
2914 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
2916 case scm_tc7_lsubr_2
:
2917 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
2918 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
2920 if (SCM_NULLP (args
))
2921 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
2922 while (SCM_NIMP (args
))
2924 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2925 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
2926 args
= SCM_CDR (args
);
2929 case scm_tc7_rpsubr
:
2930 if (SCM_NULLP (args
))
2931 RETURN (SCM_BOOL_T
);
2932 while (SCM_NIMP (args
))
2934 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2935 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
2936 RETURN (SCM_BOOL_F
);
2937 arg1
= SCM_CAR (args
);
2938 args
= SCM_CDR (args
);
2940 RETURN (SCM_BOOL_T
);
2941 case scm_tcs_closures
:
2943 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2945 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2947 #ifndef SCM_RECKLESS
2948 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
2952 /* Copy argument list */
2957 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
2958 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
2959 && SCM_CONSP (arg1
))
2961 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
2965 SCM_SETCDR (tl
, arg1
);
2968 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
2969 proc
= SCM_CODE (proc
);
2970 while (SCM_NNULLP (proc
= SCM_CDR (proc
)))
2971 arg1
= EVALCAR (proc
, args
);
2973 case scm_tc7_contin
:
2974 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2975 scm_call_continuation (proc
, arg1
);
2979 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2981 proc
= SCM_CCLO_SUBR (proc
);
2982 debug
.vect
[0].a
.proc
= proc
;
2983 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2985 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2987 proc
= SCM_CCLO_SUBR (proc
);
2991 case scm_tcs_cons_gloc
:
2992 if (SCM_I_OPERATORP (proc
))
2995 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2997 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3000 proc
= (SCM_NULLP (args
)
3001 ? (SCM_I_ENTITYP (proc
)
3002 ? SCM_ENTITY_PROC_0 (proc
)
3003 : SCM_OPERATOR_PROC_0 (proc
))
3004 : SCM_NULLP (SCM_CDR (args
))
3005 ? (SCM_I_ENTITYP (proc
)
3006 ? SCM_ENTITY_PROC_1 (proc
)
3007 : SCM_OPERATOR_PROC_1 (proc
))
3008 : SCM_NULLP (SCM_CDDR (args
))
3009 ? (SCM_I_ENTITYP (proc
)
3010 ? SCM_ENTITY_PROC_2 (proc
)
3011 : SCM_OPERATOR_PROC_2 (proc
))
3012 : (SCM_I_ENTITYP (proc
)
3013 ? SCM_ENTITY_PROC_3 (proc
)
3014 : SCM_OPERATOR_PROC_3 (proc
)));
3016 debug
.vect
[0].a
.proc
= proc
;
3017 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3022 scm_wrong_num_args (proc
);
3025 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3030 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3031 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3033 SCM_CLEAR_TRACED_FRAME (debug
);
3034 if (SCM_CHEAPTRAPS_P
)
3035 arg1
= scm_make_debugobj (&debug
);
3038 scm_make_cont (&arg1
);
3039 if (setjmp (SCM_JMPBUF (arg1
)))
3041 proc
= SCM_THROW_VALUE (arg1
);
3045 scm_ithrow (scm_i_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3048 scm_last_debug_frame
= debug
.prev
;
3054 /* SECTION: The rest of this file is only read once.
3059 SCM_PROC(s_map
, "map", 2, 0, 1, scm_map
);
3062 scm_map (proc
, arg1
, args
)
3070 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3072 if (SCM_NULLP (arg1
))
3074 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_map
);
3075 if (SCM_NULLP (args
))
3077 while (SCM_NIMP (arg1
))
3079 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
3080 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
3081 pres
= SCM_CDRLOC (*pres
);
3082 arg1
= SCM_CDR (arg1
);
3086 args
= scm_vector (scm_cons (arg1
, args
));
3087 ve
= SCM_VELTS (args
);
3088 #ifndef SCM_RECKLESS
3089 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3090 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_map
);
3095 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3099 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3100 ve
[i
] = SCM_CDR (ve
[i
]);
3102 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3103 pres
= SCM_CDRLOC (*pres
);
3108 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
3111 scm_for_each (proc
, arg1
, args
)
3116 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3119 return SCM_UNSPECIFIED
;
3120 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3123 while SCM_NIMP (arg1
)
3125 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3126 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3127 arg1
= SCM_CDR (arg1
);
3129 return SCM_UNSPECIFIED
;
3131 args
= scm_vector (scm_cons (arg1
, args
));
3132 ve
= SCM_VELTS (args
);
3133 #ifndef SCM_RECKLESS
3134 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3135 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_for_each
);
3140 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3143 (ve
[i
]) return SCM_UNSPECIFIED
;
3144 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3145 ve
[i
] = SCM_CDR (ve
[i
]);
3147 scm_apply (proc
, arg1
, SCM_EOL
);
3154 scm_closure (code
, env
)
3160 SCM_SETCODE (z
, code
);
3161 SCM_SETENV (z
, env
);
3166 long scm_tc16_promise
;
3174 SCM_ENTER_A_SECTION
;
3175 SCM_SETCDR (z
, code
);
3176 SCM_SETCAR (z
, scm_tc16_promise
);
3183 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
3186 prinprom (exp
, port
, pstate
)
3189 scm_print_state
*pstate
;
3191 int writingp
= SCM_WRITINGP (pstate
);
3192 scm_puts ("#<promise ", port
);
3193 SCM_SET_WRITINGP (pstate
, 1);
3194 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3195 SCM_SET_WRITINGP (pstate
, writingp
);
3196 scm_putc ('>', port
);
3201 SCM_PROC(s_makacro
, "procedure->syntax", 1, 0, 0, scm_makacro
);
3209 SCM_SETCDR (z
, code
);
3210 SCM_SETCAR (z
, scm_tc16_macro
);
3215 SCM_PROC(s_makmacro
, "procedure->macro", 1, 0, 0, scm_makmacro
);
3223 SCM_SETCDR (z
, code
);
3224 SCM_SETCAR (z
, scm_tc16_macro
| (1L << 16));
3229 SCM_PROC(s_makmmacro
, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro
);
3232 scm_makmmacro (code
)
3237 SCM_SETCDR (z
, code
);
3238 SCM_SETCAR (z
, scm_tc16_macro
| (2L << 16));
3243 SCM_PROC (s_macro_p
, "macro?", 1, 0, 0, scm_macro_p
);
3249 return (SCM_NIMP (obj
) && SCM_TYP16 (obj
) == scm_tc16_macro
3255 SCM_SYMBOL (scm_sym_syntax
, "syntax");
3256 SCM_SYMBOL (scm_sym_macro
, "macro");
3257 SCM_SYMBOL (scm_sym_mmacro
, "macro!");
3259 SCM_PROC (s_macro_type
, "macro-type", 1, 0, 0, scm_macro_type
);
3265 if (!(SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
))
3267 switch ((int) (SCM_CAR (m
) >> 16))
3269 case 0: return scm_sym_syntax
;
3270 case 1: return scm_sym_macro
;
3271 case 2: return scm_sym_mmacro
;
3272 default: scm_wrong_type_arg (s_macro_type
, 1, m
);
3277 SCM_PROC (s_macro_name
, "macro-name", 1, 0, 0, scm_macro_name
);
3283 SCM_ASSERT (SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
,
3287 return scm_procedure_name (SCM_CDR (m
));
3291 SCM_PROC (s_macro_transformer
, "macro-transformer", 1, 0, 0, scm_macro_transformer
);
3294 scm_macro_transformer (m
)
3297 SCM_ASSERT (SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
,
3300 s_macro_transformer
);
3301 return SCM_CLOSUREP (SCM_CDR (m
)) ? SCM_CDR (m
) : SCM_BOOL_F
;
3306 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
3312 SCM_ASSERT (SCM_NIMP(x
) && SCM_TYP16 (x
) == scm_tc16_promise
,
3313 x
, SCM_ARG1
, s_force
);
3314 if (!((1L << 16) & SCM_CAR (x
)))
3316 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3317 if (!((1L << 16) & SCM_CAR (x
)))
3320 SCM_SETCDR (x
, ans
);
3321 SCM_SETOR_CAR (x
, (1L << 16));
3328 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
3334 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
3339 SCM_PROC(s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
3348 if (SCM_VECTORP (obj
))
3350 scm_sizet i
= SCM_LENGTH (obj
);
3351 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3353 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3358 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3359 ans
= tl
= scm_cons (scm_copy_tree (SCM_CAR (obj
)), SCM_UNSPECIFIED
);
3360 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3362 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3366 SCM_SETCDR (tl
, obj
);
3372 scm_eval_3 (obj
, copyp
, env
)
3377 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3378 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3380 obj
= scm_copy_tree (obj
);
3381 return XEVAL (obj
, env
);
3386 scm_top_level_env (thunk
)
3392 return scm_cons(thunk
, (SCM
)SCM_EOL
);
3395 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
3398 scm_eval2 (obj
, env_thunk
)
3402 return scm_eval_3 (obj
, 1, scm_top_level_env(env_thunk
));
3405 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
3412 scm_eval_3(obj
, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var
)));
3415 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
3424 scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var
)));
3427 SCM_PROC (s_definedp
, "defined?", 1, 0, 0, scm_definedp
);
3435 if (SCM_ISYMP (sym
))
3438 SCM_ASSERT (SCM_NIMP (sym
) && SCM_SYMBOLP (sym
), sym
, SCM_ARG1
, s_definedp
);
3440 vcell
= scm_sym2vcell(sym
,
3441 SCM_CDR (scm_top_level_lookup_closure_var
),
3443 return (vcell
== SCM_BOOL_F
|| SCM_UNBNDP(SCM_CDR(vcell
))) ?
3444 SCM_BOOL_F
: SCM_BOOL_T
;
3447 static scm_smobfuns promsmob
= {scm_markcdr
, scm_free0
, prinprom
};
3449 static scm_smobfuns macrosmob
= {scm_markcdr
, scm_free0
};
3452 scm_make_synt (name
, macroizer
, fcn
)
3454 SCM (*macroizer
) ();
3457 SCM symcell
= scm_sysintern (name
, SCM_UNDEFINED
);
3458 long tmp
= ((((SCM_CELLPTR
) (SCM_CAR (symcell
))) - scm_heap_org
) << 8);
3460 if ((tmp
>> 8) != ((SCM_CELLPTR
) (SCM_CAR (symcell
)) - scm_heap_org
))
3463 SCM_SUBRF (z
) = fcn
;
3464 SCM_SETCAR (z
, tmp
+ scm_tc7_subr_2
);
3465 SCM_SETCDR (symcell
, macroizer (z
));
3466 return SCM_CAR (symcell
);
3470 /* At this point, scm_deval and scm_dapply are generated.
3473 #ifdef DEBUG_EXTENSIONS
3483 scm_init_opts (scm_evaluator_traps
,
3484 scm_evaluator_trap_table
,
3485 SCM_N_EVALUATOR_TRAPS
);
3486 scm_init_opts (scm_eval_options_interface
,
3488 SCM_N_EVAL_OPTIONS
);
3490 scm_tc16_promise
= scm_newsmob (&promsmob
);
3491 scm_tc16_macro
= scm_newsmob (¯osmob
);
3492 scm_i_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3493 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3494 scm_i_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3495 scm_i_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3496 scm_i_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3497 scm_i_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3498 scm_i_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3501 scm_i_quasiquote
= scm_make_synt (s_quasiquote
, scm_makacro
, scm_m_quasiquote
);
3502 scm_make_synt (s_undefine
, scm_makacro
, scm_m_undefine
);
3503 scm_make_synt (s_delay
, scm_makacro
, scm_m_delay
);
3506 scm_top_level_lookup_closure_var
=
3507 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3508 scm_can_use_top_level_lookup_closure_var
= 1;
3510 scm_i_and
= scm_make_synt ("and", scm_makmmacro
, scm_m_and
);
3511 scm_i_begin
= scm_make_synt ("begin", scm_makmmacro
, scm_m_begin
);
3512 scm_i_case
= scm_make_synt ("case", scm_makmmacro
, scm_m_case
);
3513 scm_i_cond
= scm_make_synt ("cond", scm_makmmacro
, scm_m_cond
);
3514 scm_i_define
= scm_make_synt ("define", scm_makmmacro
, scm_m_define
);
3515 scm_i_do
= scm_make_synt ("do", scm_makmmacro
, scm_m_do
);
3516 scm_i_if
= scm_make_synt ("if", scm_makmmacro
, scm_m_if
);
3517 scm_i_lambda
= scm_make_synt ("lambda", scm_makmmacro
, scm_m_lambda
);
3518 scm_i_let
= scm_make_synt ("let", scm_makmmacro
, scm_m_let
);
3519 scm_i_letrec
= scm_make_synt ("letrec", scm_makmmacro
, scm_m_letrec
);
3520 scm_i_letstar
= scm_make_synt ("let*", scm_makmmacro
, scm_m_letstar
);
3521 scm_i_or
= scm_make_synt ("or", scm_makmmacro
, scm_m_or
);
3522 scm_i_quote
= scm_make_synt ("quote", scm_makmmacro
, scm_m_quote
);
3523 scm_i_set
= scm_make_synt ("set!", scm_makmmacro
, scm_m_set
);
3524 scm_i_atapply
= scm_make_synt ("@apply", scm_makmmacro
, scm_m_apply
);
3525 scm_i_atcall_cc
= scm_make_synt ("@call-with-current-continuation",
3526 scm_makmmacro
, scm_m_cont
);
3528 #ifdef DEBUG_EXTENSIONS
3529 scm_i_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3530 scm_i_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3531 scm_i_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3532 scm_i_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3537 scm_add_feature ("delay");