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 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
);
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
);
1322 /* The SCM_CEVAL and SCM_APPLY functions use this function instead of
1323 calling setjmp directly, to make sure that local variables don't
1324 have their values clobbered by a longjmp.
1326 According to Harbison & Steele, "Automatic variables local to the
1327 function containing setjmp are guaranteed to have their correct
1328 value in ANSI C only if they have a volatile-qualified type or if
1329 their values were not changed between the original call to setjmp
1330 and the corresponding longjmp call."
1332 SCM_CEVAL and SCM_APPLY are too complex for me to see how to meet
1333 the second condition, and making x and env volatile would be a
1334 speed problem, so we'll just trivially meet the first, by having no
1335 "automatic variables local to the function containing setjmp." */
1337 /* Actually, this entire approach is bogus, because setjmp ends up
1338 capturing the stack frame of the wrapper function, which then
1339 returns, rendering the jump buffer invalid. Duh. Gotta find a
1340 better way... -JimB */
1341 #define safe_setjmp(x) setjmp (x)
1344 unsafe_setjmp (jmp_buf env
)
1346 /* I think ANSI requires us to write the function this way, instead
1347 of just saying "return setjmp (env)". Maybe I'm being silly.
1348 See Harbison & Steele, third edition, p. 353. */
1359 /* SECTION: This code is specific for the debugging support. One
1360 * branch is read when DEVAL isn't defined, the other when DEVAL is
1366 #define SCM_APPLY scm_apply
1367 #define PREP_APPLY(proc, args)
1369 #define RETURN(x) return x;
1370 #ifdef STACK_CHECKING
1371 #ifndef NO_CEVAL_STACK_CHECKING
1372 #define EVAL_STACK_CHECKING
1379 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1381 #define SCM_APPLY scm_dapply
1383 #define PREP_APPLY(p, l) \
1384 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1386 #define ENTER_APPLY \
1388 SCM_SET_ARGSREADY (debug);\
1389 if (CHECK_APPLY && SCM_TRAPS_P)\
1390 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1392 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1393 SCM_SET_TRACED_FRAME (debug); \
1394 if (SCM_CHEAPTRAPS_P)\
1396 tmp = scm_make_debugobj (&debug);\
1397 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1401 scm_make_cont (&tmp);\
1402 if (!safe_setjmp (SCM_JMPBUF (tmp)))\
1403 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1408 #define RETURN(e) {proc = (e); goto exit;}
1409 #ifdef STACK_CHECKING
1410 #ifndef EVAL_STACK_CHECKING
1411 #define EVAL_STACK_CHECKING
1415 /* scm_ceval_ptr points to the currently selected evaluator.
1416 * *fixme*: Although efficiency is important here, this state variable
1417 * should probably not be a global. It should be related to the
1422 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1424 /* scm_last_debug_frame contains a pointer to the last debugging
1425 * information stack frame. It is accessed very often from the
1426 * debugging evaluator, so it should probably not be indirectly
1427 * addressed. Better to save and restore it from the current root at
1432 scm_debug_frame
*scm_last_debug_frame
;
1435 /* scm_debug_eframe_size is the number of slots available for pseudo
1436 * stack frames at each real stack frame.
1439 int scm_debug_eframe_size
;
1441 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1445 scm_option scm_eval_opts
[] = {
1446 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1449 scm_option scm_debug_opts
[] = {
1450 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1451 "*Flyweight representation of the stack at traps." },
1452 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1453 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1454 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1455 "Record procedure names at definition." },
1456 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1457 "Display backtrace in anti-chronological order." },
1458 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1459 { SCM_OPTION_INTEGER
, "frames", 3,
1460 "Maximum number of tail-recursive frames in backtrace." },
1461 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1462 "Maximal number of stored backtrace frames." },
1463 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1464 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1465 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1466 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1469 scm_option scm_evaluator_trap_table
[] = {
1470 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1471 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1472 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1473 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1476 SCM_PROC (s_eval_options_interface
, "eval-options-interface", 0, 1, 0, scm_eval_options_interface
);
1479 scm_eval_options_interface (SCM setting
)
1483 ans
= scm_options (setting
,
1486 s_eval_options_interface
);
1487 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1492 SCM_PROC (s_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps
);
1495 scm_evaluator_traps (setting
)
1500 ans
= scm_options (setting
,
1501 scm_evaluator_trap_table
,
1502 SCM_N_EVALUATOR_TRAPS
,
1504 SCM_RESET_DEBUG_MODE
;
1510 scm_deval_args (l
, env
, proc
, lloc
)
1511 SCM l
, env
, proc
, *lloc
;
1513 SCM
*results
= lloc
, res
;
1514 while (SCM_NIMP (l
))
1519 else if (SCM_CONSP (l
))
1521 if (SCM_IMP (SCM_CAR (l
)))
1522 res
= EVALIM (SCM_CAR (l
), env
);
1524 res
= EVALCELLCAR (l
, env
);
1526 else if (SCM_TYP3 (l
) == 1)
1528 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1529 res
= SCM_CAR (l
); /* struct planted in code */
1534 res
= EVALCAR (l
, env
);
1536 *lloc
= scm_cons (res
, SCM_EOL
);
1537 lloc
= SCM_CDRLOC (*lloc
);
1544 scm_wrong_num_args (proc
);
1553 /* SECTION: Some local definitions for the evaluator.
1558 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1560 #define CHECK_EQVISH(A,B) ((A) == (B))
1564 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1566 /* SECTION: This is the evaluator. Like any real monster, it has
1567 * three heads. This code is compiled twice.
1599 scm_debug_frame debug
;
1600 scm_debug_info
*debug_info_end
;
1601 debug
.prev
= scm_last_debug_frame
;
1602 debug
.status
= scm_debug_eframe_size
;
1603 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1604 * sizeof (debug
.vect
[0]));
1605 debug
.info
= debug
.vect
;
1606 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1607 scm_last_debug_frame
= &debug
;
1609 #ifdef EVAL_STACK_CHECKING
1610 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1611 && scm_stack_checking_enabled_p
)
1614 debug
.info
->e
.exp
= x
;
1615 debug
.info
->e
.env
= env
;
1617 scm_report_stack_overflow ();
1624 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1627 SCM_CLEAR_ARGSREADY (debug
);
1628 if (SCM_OVERFLOWP (debug
))
1630 else if (++debug
.info
>= debug_info_end
)
1632 SCM_SET_OVERFLOW (debug
);
1636 debug
.info
->e
.exp
= x
;
1637 debug
.info
->e
.env
= env
;
1638 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1639 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1641 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1642 SCM_SET_TAILREC (debug
);
1643 if (SCM_CHEAPTRAPS_P
)
1644 t
.arg1
= scm_make_debugobj (&debug
);
1647 scm_make_cont (&t
.arg1
);
1648 if (safe_setjmp (SCM_JMPBUF (t
.arg1
)))
1650 x
= SCM_THROW_VALUE (t
.arg1
);
1656 /* This gives the possibility for the debugger to
1657 modify the source expression before evaluation. */
1661 scm_ithrow (scm_i_enter_frame
,
1662 scm_cons2 (t
.arg1
, tail
,
1663 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1667 #if defined (USE_THREADS) || defined (DEVAL)
1671 switch (SCM_TYP7 (x
))
1673 case scm_tcs_symbols
:
1674 /* Only happens when called at top level.
1676 x
= scm_cons (x
, SCM_UNDEFINED
);
1679 case (127 & SCM_IM_AND
):
1682 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1683 if (SCM_FALSEP (EVALCAR (x
, env
)))
1685 RETURN (SCM_BOOL_F
);
1689 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1692 case (127 & SCM_IM_BEGIN
):
1694 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1700 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1702 SIDEVAL (SCM_CAR (x
), env
);
1706 carloop
: /* scm_eval car of last form in list */
1707 if (SCM_NCELLP (SCM_CAR (x
)))
1710 RETURN (SCM_IMP (x
) ? EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1713 if (SCM_SYMBOLP (SCM_CAR (x
)))
1716 RETURN (*scm_lookupcar (x
, env
))
1720 goto loop
; /* tail recurse */
1723 case (127 & SCM_IM_CASE
):
1725 t
.arg1
= EVALCAR (x
, env
);
1726 while (SCM_NIMP (x
= SCM_CDR (x
)))
1729 if (scm_i_else
== SCM_CAR (proc
))
1732 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1735 proc
= SCM_CAR (proc
);
1736 while (SCM_NIMP (proc
))
1738 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1740 x
= SCM_CDR (SCM_CAR (x
));
1741 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1744 proc
= SCM_CDR (proc
);
1747 RETURN (SCM_UNSPECIFIED
)
1750 case (127 & SCM_IM_COND
):
1751 while (SCM_NIMP (x
= SCM_CDR (x
)))
1754 t
.arg1
= EVALCAR (proc
, env
);
1755 if (SCM_NFALSEP (t
.arg1
))
1762 if (scm_i_arrow
!= SCM_CAR (x
))
1764 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1768 proc
= EVALCAR (proc
, env
);
1769 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1770 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1775 RETURN (SCM_UNSPECIFIED
)
1778 case (127 & SCM_IM_DO
):
1780 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1781 t
.arg1
= SCM_EOL
; /* values */
1782 while (SCM_NIMP (proc
))
1784 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1785 proc
= SCM_CDR (proc
);
1787 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1788 x
= SCM_CDR (SCM_CDR (x
));
1789 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
1791 for (proc
= SCM_CAR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1793 t
.arg1
= SCM_CAR (proc
); /* body */
1794 SIDEVAL (t
.arg1
, env
);
1796 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1797 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
1798 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
1802 RETURN (SCM_UNSPECIFIED
);
1803 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1807 case (127 & SCM_IM_IF
):
1809 if (SCM_NFALSEP (EVALCAR (x
, env
)))
1811 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
1813 RETURN (SCM_UNSPECIFIED
);
1815 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1819 case (127 & SCM_IM_LET
):
1821 proc
= SCM_CAR (SCM_CDR (x
));
1825 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1827 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1828 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1833 case (127 & SCM_IM_LETREC
):
1835 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
1841 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1843 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1844 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
1848 case (127 & SCM_IM_LETSTAR
):
1853 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1858 t
.arg1
= SCM_CAR (proc
);
1859 proc
= SCM_CDR (proc
);
1860 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
1862 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1865 case (127 & SCM_IM_OR
):
1868 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1870 x
= EVALCAR (x
, env
);
1871 if (SCM_NFALSEP (x
))
1877 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1881 case (127 & SCM_IM_LAMBDA
):
1882 RETURN (scm_closure (SCM_CDR (x
), env
));
1885 case (127 & SCM_IM_QUOTE
):
1886 RETURN (SCM_CAR (SCM_CDR (x
)));
1889 case (127 & SCM_IM_SET
):
1892 switch (7 & (int) proc
)
1895 t
.lloc
= scm_lookupcar (x
, env
);
1898 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
1900 #ifdef MEMOIZE_LOCALS
1902 t
.lloc
= scm_ilookup (proc
, env
);
1907 *t
.lloc
= EVALCAR (x
, env
);
1911 RETURN (SCM_UNSPECIFIED
);
1915 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
1919 x
= evalcar (x
, env
);
1920 #ifdef DEBUG_EXTENSIONS
1921 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
1925 if (SCM_CLOSUREP (t
.arg1
)
1926 /* Only the first definition determines the name. */
1927 && (scm_procedure_property (t
.arg1
, scm_i_inner_name
)
1929 scm_set_procedure_property_x (t
.arg1
, scm_i_inner_name
, proc
);
1930 else if (SCM_TYP16 (t
.arg1
) == scm_tc16_macro
1931 && SCM_CDR (t
.arg1
) != t
.arg1
)
1933 t
.arg1
= SCM_CDR (t
.arg1
);
1938 env
= SCM_CAR (env
);
1940 SCM_SETCAR (env
, scm_cons (proc
, SCM_CAR (env
)));
1941 SCM_SETCDR (env
, scm_cons (x
, SCM_CDR (env
)));
1943 RETURN (SCM_UNSPECIFIED
);
1946 /* new syntactic forms go here. */
1947 case (127 & SCM_MAKISYM (0)):
1949 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
1950 switch SCM_ISYMNUM (proc
)
1953 case (SCM_ISYMNUM (IM_VREF
)):
1956 var
= SCM_CAR (SCM_CDR (x
));
1957 RETURN (SCM_CDR(var
));
1959 case (SCM_ISYMNUM (IM_VSET
)):
1960 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
1961 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
1962 RETURN (SCM_UNSPECIFIED
)
1965 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1967 proc
= EVALCAR (proc
, env
);
1968 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1969 if (SCM_CLOSUREP (proc
))
1972 PREP_APPLY (proc
, SCM_EOL
);
1973 t
.arg1
= SCM_CDR (SCM_CDR (x
));
1974 t
.arg1
= EVALCAR (t
.arg1
, env
);
1976 debug
.info
->a
.args
= t
.arg1
;
1979 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
1982 /* Copy argument list */
1983 if (SCM_IMP (t
.arg1
))
1987 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
1988 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
1989 && SCM_CONSP (t
.arg1
))
1991 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
1995 SCM_SETCDR (tl
, t
.arg1
);
1998 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
1999 x
= SCM_CODE (proc
);
2005 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2006 scm_make_cont (&t
.arg1
);
2007 if (safe_setjmp (SCM_JMPBUF (t
.arg1
)))
2010 val
= SCM_THROW_VALUE (t
.arg1
);
2014 proc
= evalcar (proc
, env
);
2015 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2016 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2027 /* scm_everr (x, env,...) */
2028 scm_misc_error (NULL
,
2029 "Wrong type to apply: %S",
2030 scm_listify (proc
, SCM_UNDEFINED
));
2031 case scm_tc7_vector
:
2034 case scm_tc7_byvect
:
2042 case scm_tc7_llvect
:
2044 case scm_tc7_string
:
2045 case scm_tc7_substring
:
2047 case scm_tcs_closures
:
2051 #ifdef MEMOIZE_LOCALS
2052 case (127 & SCM_ILOC00
):
2053 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2054 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2061 #endif /* ifdef MEMOIZE_LOCALS */
2064 case scm_tcs_cons_gloc
:
2065 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2066 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2075 case scm_tcs_cons_nimcar
:
2076 if (SCM_SYMBOLP (SCM_CAR (x
)))
2079 t
.lloc
= scm_lookupcar1 (x
, env
);
2082 /* we have lost the race, start again. */
2087 proc
= *scm_lookupcar (x
, env
);
2095 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2100 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2101 scm_cons (env
, scm_listofnull
));
2103 switch ((int) (SCM_CAR (proc
) >> 16))
2106 if (scm_ilength (t
.arg1
) <= 0)
2107 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2109 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2112 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2113 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2114 /* Prevent memoizing result of define macro */
2116 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2117 scm_set_source_properties_x (debug
.info
->e
.exp
,
2118 scm_source_properties (x
));
2122 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2123 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2127 /* Prevent memoizing of debug info expression. */
2128 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2129 scm_set_source_properties_x (debug
.info
->e
.exp
,
2130 scm_source_properties (x
));
2133 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2134 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2138 if (SCM_NIMP (x
= t
.arg1
))
2146 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2147 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2152 if (SCM_CLOSUREP (proc
))
2154 arg2
= SCM_CAR (SCM_CODE (proc
));
2155 t
.arg1
= SCM_CDR (x
);
2156 while (SCM_NIMP (arg2
))
2158 if (SCM_NCONSP (arg2
))
2160 if (SCM_IMP (t
.arg1
))
2161 goto umwrongnumargs
;
2162 arg2
= SCM_CDR (arg2
);
2163 t
.arg1
= SCM_CDR (t
.arg1
);
2165 if (SCM_NNULLP (t
.arg1
))
2166 goto umwrongnumargs
;
2168 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2169 goto handle_a_macro
;
2175 PREP_APPLY (proc
, SCM_EOL
);
2176 if (SCM_NULLP (SCM_CDR (x
))) {
2178 switch (SCM_TYP7 (proc
))
2179 { /* no arguments given */
2180 case scm_tc7_subr_0
:
2181 RETURN (SCM_SUBRF (proc
) ());
2182 case scm_tc7_subr_1o
:
2183 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2185 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2186 case scm_tc7_rpsubr
:
2187 RETURN (SCM_BOOL_T
);
2189 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2193 proc
= SCM_CCLO_SUBR (proc
);
2195 debug
.info
->a
.proc
= proc
;
2196 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2200 case scm_tcs_closures
:
2201 x
= SCM_CODE (proc
);
2202 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2204 case scm_tcs_cons_gloc
:
2205 if (SCM_I_OPERATORP (proc
))
2207 x
= (SCM_I_ENTITYP (proc
)
2208 ? SCM_ENTITY_PROC_0 (proc
)
2209 : SCM_OPERATOR_PROC_0 (proc
));
2212 if (SCM_TYP7 (x
) == scm_tc7_subr_1
)
2213 RETURN (SCM_SUBRF (x
) (proc
))
2214 else if (SCM_CLOSUREP (x
))
2219 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2220 debug
.info
->a
.proc
= proc
;
2227 case scm_tc7_contin
:
2228 case scm_tc7_subr_1
:
2229 case scm_tc7_subr_2
:
2230 case scm_tc7_subr_2o
:
2232 case scm_tc7_subr_3
:
2233 case scm_tc7_lsubr_2
:
2237 /* scm_everr (x, env,...) */
2238 scm_wrong_num_args (proc
);
2240 /* handle macros here */
2245 /* must handle macros by here */
2250 else if (SCM_CONSP (x
))
2252 if (SCM_IMP (SCM_CAR (x
)))
2253 t
.arg1
= EVALIM (SCM_CAR (x
), env
);
2255 t
.arg1
= EVALCELLCAR (x
, env
);
2257 else if (SCM_TYP3 (x
) == 1)
2259 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2260 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2265 t
.arg1
= EVALCAR (x
, env
);
2268 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2275 switch (SCM_TYP7 (proc
))
2276 { /* have one argument in t.arg1 */
2277 case scm_tc7_subr_2o
:
2278 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2279 case scm_tc7_subr_1
:
2280 case scm_tc7_subr_1o
:
2281 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2284 if (SCM_SUBRF (proc
))
2286 if (SCM_INUMP (t
.arg1
))
2288 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2291 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2292 if (SCM_REALP (t
.arg1
))
2294 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2297 if (SCM_BIGP (t
.arg1
))
2299 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2303 scm_wta (t
.arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2306 proc
= (SCM
) SCM_SNAME (proc
);
2308 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2309 while ('c' != *--chrs
)
2311 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2312 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2313 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2317 case scm_tc7_rpsubr
:
2318 RETURN (SCM_BOOL_T
);
2320 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2323 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2325 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2331 proc
= SCM_CCLO_SUBR (proc
);
2333 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2334 debug
.info
->a
.proc
= proc
;
2338 case scm_tcs_closures
:
2340 x
= SCM_CODE (proc
);
2342 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2344 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2347 case scm_tc7_contin
:
2348 scm_call_continuation (proc
, t
.arg1
);
2349 case scm_tcs_cons_gloc
:
2350 if (SCM_I_OPERATORP (proc
))
2352 x
= (SCM_I_ENTITYP (proc
)
2353 ? SCM_ENTITY_PROC_1 (proc
)
2354 : SCM_OPERATOR_PROC_1 (proc
));
2357 if (SCM_TYP7 (x
) == scm_tc7_subr_2
)
2358 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
))
2359 else if (SCM_CLOSUREP (x
))
2365 debug
.info
->a
.args
= scm_cons (t
.arg1
,
2366 debug
.info
->a
.args
);
2367 debug
.info
->a
.proc
= proc
;
2374 case scm_tc7_subr_2
:
2375 case scm_tc7_subr_0
:
2376 case scm_tc7_subr_3
:
2377 case scm_tc7_lsubr_2
:
2386 else if (SCM_CONSP (x
))
2388 if (SCM_IMP (SCM_CAR (x
)))
2389 arg2
= EVALIM (SCM_CAR (x
), env
);
2391 arg2
= EVALCELLCAR (x
, env
);
2393 else if (SCM_TYP3 (x
) == 1)
2395 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2396 arg2
= SCM_CAR (x
); /* struct planted in code */
2401 arg2
= EVALCAR (x
, env
);
2403 { /* have two or more arguments */
2405 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2408 if (SCM_NULLP (x
)) {
2413 switch (SCM_TYP7 (proc
))
2414 { /* have two arguments */
2415 case scm_tc7_subr_2
:
2416 case scm_tc7_subr_2o
:
2417 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2420 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2422 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2424 case scm_tc7_lsubr_2
:
2425 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2426 case scm_tc7_rpsubr
:
2428 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2433 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2434 scm_cons (debug
.info
->a
.args
, SCM_EOL
)));
2436 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2437 scm_cons2 (t
.arg1
, arg2
,
2438 scm_cons (scm_eval_args (x
, env
, proc
),
2441 /* case scm_tc7_cclo:
2442 x = scm_cons(arg2, scm_eval_args(x, env));
2445 proc = SCM_CCLO_SUBR(proc);
2448 case scm_tcs_cons_gloc
:
2449 if (SCM_I_OPERATORP (proc
))
2451 x
= (SCM_I_ENTITYP (proc
)
2452 ? SCM_ENTITY_PROC_2 (proc
)
2453 : SCM_OPERATOR_PROC_2 (proc
));
2456 if (SCM_TYP7 (x
) == scm_tc7_subr_3
)
2457 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
, arg2
))
2458 else if (SCM_CLOSUREP (x
))
2461 SCM_SET_ARGSREADY (debug
);
2462 debug
.info
->a
.args
= scm_cons (proc
,
2463 debug
.info
->a
.args
);
2464 debug
.info
->a
.proc
= x
;
2466 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (x
)),
2467 scm_cons2 (proc
, t
.arg1
,
2468 scm_cons (arg2
, SCM_EOL
)),
2476 case scm_tc7_subr_0
:
2478 case scm_tc7_subr_1o
:
2479 case scm_tc7_subr_1
:
2480 case scm_tc7_subr_3
:
2481 case scm_tc7_contin
:
2485 case scm_tcs_closures
:
2488 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2492 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2493 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2495 x
= SCM_CODE (proc
);
2500 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2504 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2505 scm_deval_args (x
, env
, proc
,
2506 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2509 switch (SCM_TYP7 (proc
))
2510 { /* have 3 or more arguments */
2512 case scm_tc7_subr_3
:
2513 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2514 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2515 SCM_CADDR (debug
.info
->a
.args
)));
2517 #ifdef BUILTIN_RPASUBR
2518 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2519 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2522 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2523 arg2
= SCM_CDR (arg2
);
2525 while (SCM_NIMP (arg2
));
2527 #endif /* BUILTIN_RPASUBR */
2528 case scm_tc7_rpsubr
:
2529 #ifdef BUILTIN_RPASUBR
2530 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2532 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2535 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2537 arg2
= SCM_CAR (t
.arg1
);
2538 t
.arg1
= SCM_CDR (t
.arg1
);
2540 while (SCM_NIMP (t
.arg1
));
2542 #else /* BUILTIN_RPASUBR */
2543 RETURN (SCM_APPLY (proc
, t
.arg1
,
2545 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
2547 #endif /* BUILTIN_RPASUBR */
2548 case scm_tc7_lsubr_2
:
2549 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2550 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2552 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2557 case scm_tcs_closures
:
2558 SCM_SET_ARGSREADY (debug
);
2559 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2562 x
= SCM_CODE (proc
);
2565 case scm_tc7_subr_3
:
2566 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2567 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
2569 #ifdef BUILTIN_RPASUBR
2570 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
2573 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
2576 while (SCM_NIMP (x
));
2578 #endif /* BUILTIN_RPASUBR */
2579 case scm_tc7_rpsubr
:
2580 #ifdef BUILTIN_RPASUBR
2581 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2585 t
.arg1
= EVALCAR (x
, env
);
2586 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
2591 while (SCM_NIMP (x
));
2593 #else /* BUILTIN_RPASUBR */
2594 RETURN (SCM_APPLY (proc
, t
.arg1
,
2596 scm_eval_args (x
, env
, proc
),
2598 #endif /* BUILTIN_RPASUBR */
2599 case scm_tc7_lsubr_2
:
2600 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
2602 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
2604 scm_eval_args (x
, env
, proc
))));
2609 case scm_tcs_closures
:
2611 SCM_SET_ARGSREADY (debug
);
2613 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2616 scm_eval_args (x
, env
, proc
)),
2618 x
= SCM_CODE (proc
);
2621 case scm_tcs_cons_gloc
:
2622 if (SCM_I_OPERATORP (proc
))
2624 SCM p
= (SCM_I_ENTITYP (proc
)
2625 ? SCM_ENTITY_PROC_3 (proc
)
2626 : SCM_OPERATOR_PROC_3 (proc
));
2629 if (SCM_TYP7 (p
) == scm_tc7_lsubr_2
)
2631 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2632 scm_cons (arg2
, SCM_CDDR (debug
.info
->a
.args
))))
2634 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2636 scm_eval_args (x
, env
, proc
))))
2638 else if (SCM_CLOSUREP (p
))
2641 SCM_SET_ARGSREADY (debug
);
2642 debug
.info
->a
.args
= scm_cons (proc
, debug
.info
->a
.args
);
2643 debug
.info
->a
.proc
= p
;
2644 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2645 scm_cons2 (proc
, t
.arg1
,
2647 SCM_CDDDR (debug
.info
->a
.args
))),
2650 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2651 scm_cons2 (proc
, t
.arg1
,
2653 scm_eval_args (x
, env
, proc
))),
2662 case scm_tc7_subr_2
:
2663 case scm_tc7_subr_1o
:
2664 case scm_tc7_subr_2o
:
2665 case scm_tc7_subr_0
:
2667 case scm_tc7_subr_1
:
2668 case scm_tc7_contin
:
2676 if (CHECK_EXIT
&& SCM_TRAPS_P
)
2677 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2679 SCM_CLEAR_TRACED_FRAME (debug
);
2680 if (SCM_CHEAPTRAPS_P
)
2681 t
.arg1
= scm_make_debugobj (&debug
);
2684 scm_make_cont (&t
.arg1
);
2685 if (safe_setjmp (SCM_JMPBUF (t
.arg1
)))
2687 proc
= SCM_THROW_VALUE (t
.arg1
);
2691 scm_ithrow (scm_i_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
2694 scm_last_debug_frame
= debug
.prev
;
2700 /* SECTION: This code is compiled once.
2705 SCM_PROC(s_procedure_documentation
, "procedure-documentation", 1, 0, 0, scm_procedure_documentation
);
2708 scm_procedure_documentation (proc
)
2712 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
) && SCM_NIMP (proc
) && SCM_TYP7 (proc
) != scm_tc7_contin
,
2713 proc
, SCM_ARG1
, s_procedure_documentation
);
2714 switch (SCM_TYP7 (proc
))
2716 case scm_tcs_closures
:
2717 code
= SCM_CDR (SCM_CODE (proc
));
2718 if (SCM_IMP (SCM_CDR (code
)))
2720 code
= SCM_CAR (code
);
2723 if (SCM_STRINGP (code
))
2736 /* This code processes the arguments to apply:
2738 (apply PROC ARG1 ... ARGS)
2740 Given a list (ARG1 ... ARGS), this function conses the ARG1
2741 ... arguments onto the front of ARGS, and returns the resulting
2742 list. Note that ARGS is a list; thus, the argument to this
2743 function is a list whose last element is a list.
2745 Apply calls this function, and applies PROC to the elements of the
2746 result. apply:nconc2last takes care of building the list of
2747 arguments, given (ARG1 ... ARGS).
2749 Rather than do new consing, apply:nconc2last destroys its argument.
2750 On that topic, this code came into my care with the following
2751 beautifully cryptic comment on that topic: "This will only screw
2752 you if you do (scm_apply scm_apply '( ... ))" If you know what
2753 they're referring to, send me a patch to this comment. */
2755 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
2758 scm_nconc2last (lst
)
2762 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
2764 while (SCM_NNULLP (SCM_CDR (*lloc
)))
2765 lloc
= SCM_CDRLOC (*lloc
);
2766 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
2767 *lloc
= SCM_CAR (*lloc
);
2774 /* SECTION: When DEVAL is defined this code yields scm_dapply.
2775 * It is compiled twice.
2781 scm_apply (proc
, arg1
, args
)
2791 scm_dapply (proc
, arg1
, args
)
2799 /* Apply a function to a list of arguments.
2801 This function is exported to the Scheme level as taking two
2802 required arguments and a tail argument, as if it were:
2803 (lambda (proc arg1 . args) ...)
2804 Thus, if you just have a list of arguments to pass to a procedure,
2805 pass the list as ARG1, and '() for ARGS. If you have some fixed
2806 args, pass the first as ARG1, then cons any remaining fixed args
2807 onto the front of your argument list, and pass that as ARGS. */
2810 SCM_APPLY (proc
, arg1
, args
)
2815 #ifdef DEBUG_EXTENSIONS
2817 scm_debug_frame debug
;
2818 scm_debug_info debug_vect_body
;
2819 debug
.prev
= scm_last_debug_frame
;
2820 debug
.status
= SCM_APPLYFRAME
;
2821 debug
.vect
= &debug_vect_body
;
2822 debug
.vect
[0].a
.proc
= proc
;
2823 debug
.vect
[0].a
.args
= SCM_EOL
;
2824 scm_last_debug_frame
= &debug
;
2827 return scm_dapply (proc
, arg1
, args
);
2831 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
2833 /* If ARGS is the empty list, then we're calling apply with only two
2834 arguments --- ARG1 is the list of arguments for PROC. Whatever
2835 the case, futz with things so that ARG1 is the first argument to
2836 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
2839 Setting the debug apply frame args this way is pretty messy.
2840 Perhaps we should store arg1 and args directly in the frame as
2841 received, and let scm_frame_arguments unpack them, because that's
2842 a relatively rare operation. This works for now; if the Guile
2843 developer archives are still around, see Mikael's post of
2845 if (SCM_NULLP (args
))
2847 if (SCM_NULLP (arg1
))
2849 arg1
= SCM_UNDEFINED
;
2851 debug
.vect
[0].a
.args
= SCM_EOL
;
2857 debug
.vect
[0].a
.args
= arg1
;
2859 args
= SCM_CDR (arg1
);
2860 arg1
= SCM_CAR (arg1
);
2865 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
2866 args
= scm_nconc2last (args
);
2868 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2872 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
2875 if (SCM_CHEAPTRAPS_P
)
2876 tmp
= scm_make_debugobj (&debug
);
2879 scm_make_cont (&tmp
);
2880 if (safe_setjmp (SCM_JMPBUF (tmp
)))
2883 scm_ithrow (scm_i_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
2891 switch (SCM_TYP7 (proc
))
2893 case scm_tc7_subr_2o
:
2894 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
2895 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2896 case scm_tc7_subr_2
:
2897 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
2899 args
= SCM_CAR (args
);
2900 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2901 case scm_tc7_subr_0
:
2902 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
2903 RETURN (SCM_SUBRF (proc
) ())
2904 case scm_tc7_subr_1
:
2905 case scm_tc7_subr_1o
:
2906 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2907 RETURN (SCM_SUBRF (proc
) (arg1
))
2909 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2911 if (SCM_SUBRF (proc
))
2913 if (SCM_INUMP (arg1
))
2915 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
2917 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
2918 if (SCM_REALP (arg1
))
2920 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
2925 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
2928 scm_wta (arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2931 proc
= (SCM
) SCM_SNAME (proc
);
2933 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2934 while ('c' != *--chrs
)
2936 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
2937 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2938 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2942 case scm_tc7_subr_3
:
2943 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
2946 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
2948 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
2950 case scm_tc7_lsubr_2
:
2951 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
2952 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
2954 if (SCM_NULLP (args
))
2955 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
2956 while (SCM_NIMP (args
))
2958 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2959 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
2960 args
= SCM_CDR (args
);
2963 case scm_tc7_rpsubr
:
2964 if (SCM_NULLP (args
))
2965 RETURN (SCM_BOOL_T
);
2966 while (SCM_NIMP (args
))
2968 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2969 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
2970 RETURN (SCM_BOOL_F
);
2971 arg1
= SCM_CAR (args
);
2972 args
= SCM_CDR (args
);
2974 RETURN (SCM_BOOL_T
);
2975 case scm_tcs_closures
:
2977 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2979 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2982 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
2986 /* Copy argument list */
2991 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
2992 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
2993 && SCM_CONSP (arg1
))
2995 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
2999 SCM_SETCDR (tl
, arg1
);
3002 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3003 proc
= SCM_CODE (proc
);
3004 while (SCM_NNULLP (proc
= SCM_CDR (proc
)))
3005 arg1
= EVALCAR (proc
, args
);
3007 case scm_tc7_contin
:
3008 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3009 scm_call_continuation (proc
, arg1
);
3013 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3015 proc
= SCM_CCLO_SUBR (proc
);
3016 debug
.vect
[0].a
.proc
= proc
;
3017 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3019 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3021 proc
= SCM_CCLO_SUBR (proc
);
3025 case scm_tcs_cons_gloc
:
3026 if (SCM_I_OPERATORP (proc
))
3029 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3031 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3034 proc
= (SCM_NULLP (args
)
3035 ? (SCM_I_ENTITYP (proc
)
3036 ? SCM_ENTITY_PROC_0 (proc
)
3037 : SCM_OPERATOR_PROC_0 (proc
))
3038 : SCM_NULLP (SCM_CDR (args
))
3039 ? (SCM_I_ENTITYP (proc
)
3040 ? SCM_ENTITY_PROC_1 (proc
)
3041 : SCM_OPERATOR_PROC_1 (proc
))
3042 : SCM_NULLP (SCM_CDDR (args
))
3043 ? (SCM_I_ENTITYP (proc
)
3044 ? SCM_ENTITY_PROC_2 (proc
)
3045 : SCM_OPERATOR_PROC_2 (proc
))
3046 : (SCM_I_ENTITYP (proc
)
3047 ? SCM_ENTITY_PROC_3 (proc
)
3048 : SCM_OPERATOR_PROC_3 (proc
)));
3050 debug
.vect
[0].a
.proc
= proc
;
3051 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3056 scm_wrong_num_args (proc
);
3059 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3064 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3065 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3067 SCM_CLEAR_TRACED_FRAME (debug
);
3068 if (SCM_CHEAPTRAPS_P
)
3069 arg1
= scm_make_debugobj (&debug
);
3072 scm_make_cont (&arg1
);
3073 if (safe_setjmp (SCM_JMPBUF (arg1
)))
3075 proc
= SCM_THROW_VALUE (arg1
);
3079 scm_ithrow (scm_i_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3082 scm_last_debug_frame
= debug
.prev
;
3088 /* SECTION: The rest of this file is only read once.
3093 SCM_PROC(s_map
, "map", 2, 0, 1, scm_map
);
3096 scm_map (proc
, arg1
, args
)
3104 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3106 if (SCM_NULLP (arg1
))
3108 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_map
);
3109 if (SCM_NULLP (args
))
3111 while (SCM_NIMP (arg1
))
3113 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
3114 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
3115 pres
= SCM_CDRLOC (*pres
);
3116 arg1
= SCM_CDR (arg1
);
3120 args
= scm_vector (scm_cons (arg1
, args
));
3121 ve
= SCM_VELTS (args
);
3123 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3124 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_map
);
3129 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3133 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3134 ve
[i
] = SCM_CDR (ve
[i
]);
3136 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3137 pres
= SCM_CDRLOC (*pres
);
3142 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
3145 scm_for_each (proc
, arg1
, args
)
3150 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3153 return SCM_UNSPECIFIED
;
3154 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3157 while SCM_NIMP (arg1
)
3159 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3160 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3161 arg1
= SCM_CDR (arg1
);
3163 return SCM_UNSPECIFIED
;
3165 args
= scm_vector (scm_cons (arg1
, args
));
3166 ve
= SCM_VELTS (args
);
3168 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3169 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_for_each
);
3174 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3177 (ve
[i
]) return SCM_UNSPECIFIED
;
3178 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3179 ve
[i
] = SCM_CDR (ve
[i
]);
3181 scm_apply (proc
, arg1
, SCM_EOL
);
3188 scm_closure (code
, env
)
3194 SCM_SETCODE (z
, code
);
3195 SCM_SETENV (z
, env
);
3200 long scm_tc16_promise
;
3208 SCM_ENTER_A_SECTION
;
3209 SCM_SETCDR (z
, code
);
3210 SCM_SETCAR (z
, scm_tc16_promise
);
3217 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
3220 prinprom (exp
, port
, pstate
)
3223 scm_print_state
*pstate
;
3225 int writingp
= SCM_WRITINGP (pstate
);
3226 scm_puts ("#<promise ", port
);
3227 SCM_SET_WRITINGP (pstate
, 1);
3228 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3229 SCM_SET_WRITINGP (pstate
, writingp
);
3230 scm_putc ('>', port
);
3235 SCM_PROC(s_makacro
, "procedure->syntax", 1, 0, 0, scm_makacro
);
3243 SCM_SETCDR (z
, code
);
3244 SCM_SETCAR (z
, scm_tc16_macro
);
3249 SCM_PROC(s_makmacro
, "procedure->macro", 1, 0, 0, scm_makmacro
);
3257 SCM_SETCDR (z
, code
);
3258 SCM_SETCAR (z
, scm_tc16_macro
| (1L << 16));
3263 SCM_PROC(s_makmmacro
, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro
);
3266 scm_makmmacro (code
)
3271 SCM_SETCDR (z
, code
);
3272 SCM_SETCAR (z
, scm_tc16_macro
| (2L << 16));
3277 SCM_PROC (s_macro_p
, "macro?", 1, 0, 0, scm_macro_p
);
3283 return (SCM_NIMP (obj
) && SCM_TYP16 (obj
) == scm_tc16_macro
3289 SCM_SYMBOL (scm_sym_syntax
, "syntax");
3290 SCM_SYMBOL (scm_sym_macro
, "macro");
3291 SCM_SYMBOL (scm_sym_mmacro
, "macro!");
3293 SCM_PROC (s_macro_type
, "macro-type", 1, 0, 0, scm_macro_type
);
3299 if (!(SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
))
3301 switch ((int) (SCM_CAR (m
) >> 16))
3303 case 0: return scm_sym_syntax
;
3304 case 1: return scm_sym_macro
;
3305 case 2: return scm_sym_mmacro
;
3306 default: scm_wrong_type_arg (s_macro_type
, 1, m
);
3311 SCM_PROC (s_macro_name
, "macro-name", 1, 0, 0, scm_macro_name
);
3317 SCM_ASSERT (SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
,
3321 return scm_procedure_name (SCM_CDR (m
));
3325 SCM_PROC (s_macro_transformer
, "macro-transformer", 1, 0, 0, scm_macro_transformer
);
3328 scm_macro_transformer (m
)
3331 SCM_ASSERT (SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
,
3334 s_macro_transformer
);
3335 return SCM_CLOSUREP (SCM_CDR (m
)) ? SCM_CDR (m
) : SCM_BOOL_F
;
3340 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
3346 SCM_ASSERT (SCM_NIMP(x
) && SCM_TYP16 (x
) == scm_tc16_promise
,
3347 x
, SCM_ARG1
, s_force
);
3348 if (!((1L << 16) & SCM_CAR (x
)))
3350 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3351 if (!((1L << 16) & SCM_CAR (x
)))
3354 SCM_SETCDR (x
, ans
);
3355 SCM_SETOR_CAR (x
, (1L << 16));
3362 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
3368 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
3373 SCM_PROC(s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
3382 if (SCM_VECTORP (obj
))
3384 scm_sizet i
= SCM_LENGTH (obj
);
3385 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3387 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3392 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3393 ans
= tl
= scm_cons (scm_copy_tree (SCM_CAR (obj
)), SCM_UNSPECIFIED
);
3394 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3396 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3400 SCM_SETCDR (tl
, obj
);
3406 scm_eval_3 (obj
, copyp
, env
)
3411 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3412 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3414 obj
= scm_copy_tree (obj
);
3415 return XEVAL (obj
, env
);
3420 scm_top_level_env (thunk
)
3426 return scm_cons(thunk
, (SCM
)SCM_EOL
);
3429 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
3432 scm_eval2 (obj
, env_thunk
)
3436 return scm_eval_3 (obj
, 1, scm_top_level_env(env_thunk
));
3439 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
3446 scm_eval_3(obj
, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var
)));
3449 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
3458 scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var
)));
3461 SCM_PROC (s_definedp
, "defined?", 1, 0, 0, scm_definedp
);
3469 if (SCM_ISYMP (sym
))
3472 SCM_ASSERT (SCM_NIMP (sym
) && SCM_SYMBOLP (sym
), sym
, SCM_ARG1
, s_definedp
);
3474 vcell
= scm_sym2vcell(sym
,
3475 SCM_CDR (scm_top_level_lookup_closure_var
),
3477 return (vcell
== SCM_BOOL_F
|| SCM_UNBNDP(SCM_CDR(vcell
))) ?
3478 SCM_BOOL_F
: SCM_BOOL_T
;
3481 static scm_smobfuns promsmob
= {scm_markcdr
, scm_free0
, prinprom
};
3483 static scm_smobfuns macrosmob
= {scm_markcdr
, scm_free0
};
3486 scm_make_synt (name
, macroizer
, fcn
)
3488 SCM (*macroizer
) ();
3491 SCM symcell
= scm_sysintern (name
, SCM_UNDEFINED
);
3492 long tmp
= ((((SCM_CELLPTR
) (SCM_CAR (symcell
))) - scm_heap_org
) << 8);
3494 if ((tmp
>> 8) != ((SCM_CELLPTR
) (SCM_CAR (symcell
)) - scm_heap_org
))
3497 SCM_SUBRF (z
) = fcn
;
3498 SCM_SETCAR (z
, tmp
+ scm_tc7_subr_2
);
3499 SCM_SETCDR (symcell
, macroizer (z
));
3500 return SCM_CAR (symcell
);
3504 /* At this point, scm_deval and scm_dapply are generated.
3507 #ifdef DEBUG_EXTENSIONS
3517 scm_init_opts (scm_evaluator_traps
,
3518 scm_evaluator_trap_table
,
3519 SCM_N_EVALUATOR_TRAPS
);
3520 scm_init_opts (scm_eval_options_interface
,
3522 SCM_N_EVAL_OPTIONS
);
3524 scm_tc16_promise
= scm_newsmob (&promsmob
);
3525 scm_tc16_macro
= scm_newsmob (¯osmob
);
3526 scm_i_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3527 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3528 scm_i_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3529 scm_i_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3530 scm_i_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3531 scm_i_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3532 scm_i_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3535 scm_i_quasiquote
= scm_make_synt (s_quasiquote
, scm_makacro
, scm_m_quasiquote
);
3536 scm_make_synt (s_undefine
, scm_makacro
, scm_m_undefine
);
3537 scm_make_synt (s_delay
, scm_makacro
, scm_m_delay
);
3540 scm_top_level_lookup_closure_var
=
3541 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3542 scm_can_use_top_level_lookup_closure_var
= 1;
3544 scm_i_and
= scm_make_synt ("and", scm_makmmacro
, scm_m_and
);
3545 scm_i_begin
= scm_make_synt ("begin", scm_makmmacro
, scm_m_begin
);
3546 scm_i_case
= scm_make_synt ("case", scm_makmmacro
, scm_m_case
);
3547 scm_i_cond
= scm_make_synt ("cond", scm_makmmacro
, scm_m_cond
);
3548 scm_i_define
= scm_make_synt ("define", scm_makmmacro
, scm_m_define
);
3549 scm_i_do
= scm_make_synt ("do", scm_makmmacro
, scm_m_do
);
3550 scm_i_if
= scm_make_synt ("if", scm_makmmacro
, scm_m_if
);
3551 scm_i_lambda
= scm_make_synt ("lambda", scm_makmmacro
, scm_m_lambda
);
3552 scm_i_let
= scm_make_synt ("let", scm_makmmacro
, scm_m_let
);
3553 scm_i_letrec
= scm_make_synt ("letrec", scm_makmmacro
, scm_m_letrec
);
3554 scm_i_letstar
= scm_make_synt ("let*", scm_makmmacro
, scm_m_letstar
);
3555 scm_i_or
= scm_make_synt ("or", scm_makmmacro
, scm_m_or
);
3556 scm_i_quote
= scm_make_synt ("quote", scm_makmmacro
, scm_m_quote
);
3557 scm_i_set
= scm_make_synt ("set!", scm_makmmacro
, scm_m_set
);
3558 scm_i_atapply
= scm_make_synt ("@apply", scm_makmmacro
, scm_m_apply
);
3559 scm_i_atcall_cc
= scm_make_synt ("@call-with-current-continuation",
3560 scm_makmmacro
, scm_m_cont
);
3562 #ifdef DEBUG_EXTENSIONS
3563 scm_i_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3564 scm_i_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3565 scm_i_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3566 scm_i_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3571 scm_add_feature ("delay");