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 (vloc
, genv
)
263 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
265 register SCM var2
= var
;
267 #ifdef MEMOIZE_LOCALS
268 register SCM iloc
= SCM_ILOC00
;
270 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
272 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
274 al
= SCM_CARLOC (env
);
275 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
281 #ifdef MEMOIZE_LOCALS
283 if (SCM_CAR (vloc
) != var
)
286 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
288 return SCM_CDRLOC (*al
);
293 al
= SCM_CDRLOC (*al
);
294 if (SCM_CAR (fl
) == var
)
296 #ifdef MEMOIZE_LOCALS
297 #ifndef RECKLESS /* letrec inits to SCM_UNDEFINED */
298 if (SCM_UNBNDP (SCM_CAR (*al
)))
305 if (SCM_CAR (vloc
) != var
)
308 SCM_SETCAR (vloc
, iloc
);
310 return SCM_CARLOC (*al
);
312 #ifdef MEMOIZE_LOCALS
316 #ifdef MEMOIZE_LOCALS
317 iloc
= (~SCM_IDSTMSK
) & (iloc
+ SCM_IFRINC
);
321 SCM top_thunk
, vcell
;
324 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
328 top_thunk
= SCM_BOOL_F
;
329 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
330 if (vcell
== SCM_BOOL_F
)
336 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
340 /* scm_everr (vloc, genv,...) */
341 scm_misc_error (NULL
,
343 ? "Unbound variable: %S"
344 : "Damaged environment: %S",
345 scm_listify (var
, SCM_UNDEFINED
));
349 if (SCM_CAR (vloc
) != var2
)
351 /* Some other thread has changed the very cell we are working
352 on. In effect, it must have done our job or messed it up
355 var
= SCM_CAR (vloc
);
357 return SCM_GLOC_VAL_LOC (var
);
358 #ifdef MEMOIZE_LOCALS
359 if ((var
& 127) == (127 & SCM_ILOC00
))
360 return scm_ilookup (var
, genv
);
362 /* We can't cope with anything else than glocs and ilocs. When
363 a special form has been memoized (i.e. `let' into `#@let') we
364 return NULL and expect the calling function to do the right
365 thing. For the evaluator, this means going back and redoing
366 the dispatch on the car of the form. */
369 #endif /* USE_THREADS */
371 SCM_SETCAR (vloc
, var
+ 1);
372 /* Except wait...what if the var is not a vcell,
373 * but syntax or something.... */
374 return SCM_CDRLOC (var
);
379 scm_lookupcar (vloc
, genv
)
383 SCM
*loc
= scm_lookupcar1 (vloc
, genv
);
388 #else /* not USE_THREADS */
389 #define scm_lookupcar scm_lookupcar1
392 #define unmemocar scm_unmemocar
395 scm_unmemocar (form
, env
)
399 #ifdef DEBUG_EXTENSIONS
408 SCM_SETCAR (form
, SCM_CAR (c
- 1));
409 #ifdef MEMOIZE_LOCALS
410 #ifdef DEBUG_EXTENSIONS
411 else if (SCM_ILOCP (c
))
413 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
415 env
= SCM_CAR (SCM_CAR (env
));
416 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
418 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
427 scm_eval_car (pair
, env
)
431 return XEVALCAR (pair
, env
);
436 * The following rewrite expressions and
437 * some memoized forms have different syntax
440 static char s_expression
[] = "missing or extra expression";
441 static char s_test
[] = "bad test";
442 static char s_body
[] = "bad body";
443 static char s_bindings
[] = "bad bindings";
444 static char s_variable
[] = "bad variable";
445 static char s_clauses
[] = "bad or missing clauses";
446 static char s_formals
[] = "bad formals";
447 #define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr);
449 SCM scm_i_dot
, scm_i_quote
, scm_i_quasiquote
, scm_i_lambda
, scm_i_let
,
450 scm_i_arrow
, scm_i_else
, scm_i_unquote
, scm_i_uq_splicing
, scm_i_apply
;
451 SCM scm_i_define
, scm_i_and
, scm_i_begin
, scm_i_case
, scm_i_cond
,
452 scm_i_do
, scm_i_if
, scm_i_let
, scm_i_letrec
, scm_i_letstar
,
453 scm_i_or
, scm_i_set
, scm_i_atapply
, scm_i_atcall_cc
;
454 static char s_quasiquote
[] = "quasiquote";
455 static char s_delay
[] = "delay";
456 static char s_undefine
[] = "undefine";
457 #ifdef DEBUG_EXTENSIONS
458 SCM scm_i_enter_frame
, scm_i_apply_frame
, scm_i_exit_frame
;
462 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
466 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, char *what
));
469 bodycheck (xorig
, bodyloc
, what
)
474 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, s_expression
);
480 scm_m_quote (xorig
, env
)
484 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, xorig
, s_expression
, "quote");
485 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
491 scm_m_begin (xorig
, env
)
495 ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, xorig
, s_expression
, "begin");
496 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
502 scm_m_if (xorig
, env
)
506 int len
= scm_ilength (SCM_CDR (xorig
));
507 ASSYNT (len
>= 2 && len
<= 3, xorig
, s_expression
, "if");
508 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
514 scm_m_set (xorig
, env
)
518 SCM x
= SCM_CDR (xorig
);
519 ASSYNT (2 == scm_ilength (x
), xorig
, s_expression
, "set!");
520 ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
521 xorig
, s_variable
, "set!");
522 return scm_cons (SCM_IM_SET
, x
);
529 scm_m_vref (xorig
, env
)
533 SCM x
= SCM_CDR (xorig
);
534 ASSYNT (1 == scm_ilength (x
), xorig
, s_expression
, s_vref
);
535 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
537 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
538 scm_misc_error (NULL
,
540 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
542 ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
543 xorig
, s_variable
, s_vref
);
545 return scm_cons (IM_VREF
, x
);
551 scm_m_vset (xorig
, env
)
555 SCM x
= SCM_CDR (xorig
);
556 ASSYNT (3 == scm_ilength (x
), xorig
, s_expression
, s_vset
);
557 ASSYNT (( DEFSCM_VARIABLEP (SCM_CAR (x
))
558 || UDSCM_VARIABLEP (SCM_CAR (x
))),
559 xorig
, s_variable
, s_vset
);
560 return scm_cons (IM_VSET
, x
);
567 scm_m_and (xorig
, env
)
571 int len
= scm_ilength (SCM_CDR (xorig
));
572 ASSYNT (len
>= 0, xorig
, s_test
, "and");
574 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
582 scm_m_or (xorig
, env
)
586 int len
= scm_ilength (SCM_CDR (xorig
));
587 ASSYNT (len
>= 0, xorig
, s_test
, "or");
589 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
597 scm_m_case (xorig
, env
)
601 SCM proc
, x
= SCM_CDR (xorig
);
602 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_clauses
, "case");
603 while (SCM_NIMP (x
= SCM_CDR (x
)))
606 ASSYNT (scm_ilength (proc
) >= 2, xorig
, s_clauses
, "case");
607 ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0 || scm_i_else
== SCM_CAR (proc
),
608 xorig
, s_clauses
, "case");
610 return scm_cons (SCM_IM_CASE
, SCM_CDR (xorig
));
616 scm_m_cond (xorig
, env
)
620 SCM arg1
, x
= SCM_CDR (xorig
);
621 int len
= scm_ilength (x
);
622 ASSYNT (len
>= 1, xorig
, s_clauses
, "cond");
626 len
= scm_ilength (arg1
);
627 ASSYNT (len
>= 1, xorig
, s_clauses
, "cond");
628 if (scm_i_else
== SCM_CAR (arg1
))
630 ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2, xorig
, "bad ELSE clause", "cond");
631 SCM_SETCAR (arg1
, SCM_BOOL_T
);
633 if (len
>= 2 && scm_i_arrow
== SCM_CAR (SCM_CDR (arg1
)))
634 ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
635 xorig
, "bad recipient", "cond");
638 return scm_cons (SCM_IM_COND
, SCM_CDR (xorig
));
644 scm_m_lambda (xorig
, env
)
648 SCM proc
, x
= SCM_CDR (xorig
);
649 if (scm_ilength (x
) < 2)
652 if (SCM_NULLP (proc
))
656 if (SCM_SYMBOLP (proc
))
658 if (SCM_NCONSP (proc
))
660 while (SCM_NIMP (proc
))
662 if (SCM_NCONSP (proc
))
664 if (!SCM_SYMBOLP (proc
))
669 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
671 proc
= SCM_CDR (proc
);
675 badforms
:scm_wta (xorig
, s_formals
, "lambda");
677 bodycheck (xorig
, SCM_CDRLOC (x
), "lambda");
678 return scm_cons (SCM_IM_LAMBDA
, SCM_CDR (xorig
));
684 scm_m_letstar (xorig
, env
)
688 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
689 int len
= scm_ilength (x
);
690 ASSYNT (len
>= 2, xorig
, s_body
, "let*");
692 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "let*");
693 while SCM_NIMP (proc
)
695 arg1
= SCM_CAR (proc
);
696 ASSYNT (2 == scm_ilength (arg1
), xorig
, s_bindings
, "let*");
697 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "let*");
698 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
699 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
700 proc
= SCM_CDR (proc
);
702 x
= scm_cons (vars
, SCM_CDR (x
));
703 bodycheck (xorig
, SCM_CDRLOC (x
), "let*");
704 return scm_cons (SCM_IM_LETSTAR
, x
);
707 /* DO gets the most radically altered syntax
708 (do ((<var1> <init1> <step1>)
714 (do_mem (varn ... var2 var1)
715 (<init1> <init2> ... <initn>)
718 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
724 scm_m_do (xorig
, env
)
728 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
729 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
730 SCM
*initloc
= &inits
, *steploc
= &steps
;
731 int len
= scm_ilength (x
);
732 ASSYNT (len
>= 2, xorig
, s_test
, "do");
734 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "do");
738 arg1
= SCM_CAR (proc
);
739 len
= scm_ilength (arg1
);
740 ASSYNT (2 == len
|| 3 == len
, xorig
, s_bindings
, "do");
741 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "do");
742 /* vars reversed here, inits and steps reversed at evaluation */
743 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
744 arg1
= SCM_CDR (arg1
);
745 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
746 initloc
= SCM_CDRLOC (*initloc
);
747 arg1
= SCM_CDR (arg1
);
748 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
749 steploc
= SCM_CDRLOC (*steploc
);
750 proc
= SCM_CDR (proc
);
753 ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, s_test
, "do");
754 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
755 x
= scm_cons2 (vars
, inits
, x
);
756 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
757 return scm_cons (SCM_IM_DO
, x
);
760 /* evalcar is small version of inline EVALCAR when we don't care about
763 #define evalcar scm_eval_car
766 static SCM iqq
SCM_P ((SCM form
, SCM env
, int depth
));
769 iqq (form
, env
, depth
)
778 if (SCM_VECTORP (form
))
780 long i
= SCM_LENGTH (form
);
781 SCM
*data
= SCM_VELTS (form
);
784 tmp
= scm_cons (data
[i
], tmp
);
785 return scm_vector (iqq (tmp
, env
, depth
));
789 tmp
= SCM_CAR (form
);
790 if (scm_i_quasiquote
== tmp
)
795 if (scm_i_unquote
== tmp
)
799 form
= SCM_CDR (form
);
800 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
801 form
, SCM_ARG1
, s_quasiquote
);
803 return evalcar (form
, env
);
804 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
806 if (SCM_NIMP (tmp
) && (scm_i_uq_splicing
== SCM_CAR (tmp
)))
810 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
812 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
815 /* Here are acros which return values rather than code. */
819 scm_m_quasiquote (xorig
, env
)
823 SCM x
= SCM_CDR (xorig
);
824 ASSYNT (scm_ilength (x
) == 1, xorig
, s_expression
, s_quasiquote
);
825 return iqq (SCM_CAR (x
), env
, 1);
830 scm_m_delay (xorig
, env
)
834 ASSYNT (scm_ilength (xorig
) == 2, xorig
, s_expression
, s_delay
);
835 xorig
= SCM_CDR (xorig
);
836 return scm_makprom (scm_closure (scm_cons2 (SCM_EOL
, SCM_CAR (xorig
), SCM_CDR (xorig
)),
841 static SCM env_top_level
SCM_P ((SCM env
));
847 while (SCM_NIMP(env
))
849 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR(env
)))
858 scm_m_define (x
, env
)
864 /* ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
865 ASSYNT (scm_ilength (x
) >= 2, arg1
, s_expression
, "define");
868 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
869 { /* nested define syntax */
870 x
= scm_cons (scm_cons2 (scm_i_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
871 proc
= SCM_CAR (proc
);
873 ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
), arg1
, s_variable
, "define");
874 ASSYNT (1 == scm_ilength (x
), arg1
, s_expression
, "define");
875 if (SCM_TOP_LEVEL (env
))
877 x
= evalcar (x
, env
);
878 #ifdef DEBUG_EXTENSIONS
879 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
883 if (SCM_CLOSUREP (arg1
)
884 /* Only the first definition determines the name. */
885 && scm_procedure_property (arg1
, scm_i_name
) == SCM_BOOL_F
)
886 scm_set_procedure_property_x (arg1
, scm_i_name
, proc
);
887 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
888 && SCM_CDR (arg1
) != arg1
)
890 arg1
= SCM_CDR (arg1
);
895 arg1
= scm_sym2vcell (proc
, env_top_level (env
), SCM_BOOL_T
);
898 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
899 && (SCM_CDR (arg1
) != x
))
900 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
903 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
904 scm_warn ("redefining ", SCM_CHARS (proc
));
906 SCM_SETCDR (arg1
, x
);
908 return scm_cons2 (scm_i_quote
, SCM_CAR (arg1
), SCM_EOL
);
910 return SCM_UNSPECIFIED
;
913 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
917 scm_m_undefine (x
, env
)
922 ASSYNT (SCM_TOP_LEVEL (env
), arg1
, "bad placement ", s_undefine
);
923 ASSYNT (SCM_NIMP (x
) && SCM_CONSP (x
) && SCM_CDR (x
) == SCM_EOL
,
924 arg1
, s_expression
, s_undefine
);
926 ASSYNT (SCM_NIMP (x
) && SCM_SYMBOLP (x
), arg1
, s_variable
, s_undefine
);
927 arg1
= scm_sym2vcell (x
, env_top_level (env
), SCM_BOOL_F
);
928 ASSYNT (SCM_NFALSEP (arg1
) && !SCM_UNBNDP (SCM_CDR (arg1
)),
929 x
, "variable already unbound ", s_undefine
);
932 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == x
))
933 scm_warn ("undefining built-in ", SCM_CHARS (x
));
936 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
937 scm_warn ("redefining ", SCM_CHARS (x
));
939 SCM_SETCDR (arg1
, SCM_UNDEFINED
);
941 return SCM_CAR (arg1
);
943 return SCM_UNSPECIFIED
;
951 scm_m_letrec (xorig
, env
)
955 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
956 char *what
= SCM_CHARS (SCM_CAR (xorig
));
957 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
958 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
960 ASRTSYNTAX (scm_ilength (x
) >= 2, s_body
);
963 (proc
) return scm_m_letstar (xorig
, env
); /* null binding, let* faster */
964 ASRTSYNTAX (scm_ilength (proc
) >= 1, s_bindings
);
967 /* vars scm_list reversed here, inits reversed at evaluation */
968 arg1
= SCM_CAR (proc
);
969 ASRTSYNTAX (2 == scm_ilength (arg1
), s_bindings
);
970 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), s_variable
);
971 vars
= scm_cons (SCM_CAR (arg1
), vars
);
972 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
973 initloc
= SCM_CDRLOC (*initloc
);
976 (proc
= SCM_CDR (proc
));
977 cdrx
= scm_cons2 (vars
, inits
, SCM_CDR (x
));
978 bodycheck (xorig
, SCM_CDRLOC (SCM_CDR (cdrx
)), what
);
979 return scm_cons (SCM_IM_LETREC
, cdrx
);
984 scm_m_let (xorig
, env
)
988 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
989 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
990 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
992 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_body
, "let");
995 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
996 && SCM_NIMP (SCM_CAR (proc
)) && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
997 return scm_m_letstar (xorig
, env
); /* null or single binding, let* is faster */
998 ASSYNT (SCM_NIMP (proc
), xorig
, s_bindings
, "let");
999 if (SCM_CONSP (proc
)) /* plain let, proc is <bindings> */
1000 return scm_cons (SCM_IM_LET
, SCM_CDR (scm_m_letrec (xorig
, env
)));
1001 if (!SCM_SYMBOLP (proc
))
1002 scm_wta (xorig
, s_bindings
, "let"); /* bad let */
1003 name
= proc
; /* named let, build equiv letrec */
1005 ASSYNT (scm_ilength (x
) >= 2, xorig
, s_body
, "let");
1006 proc
= SCM_CAR (x
); /* bindings scm_list */
1007 ASSYNT (scm_ilength (proc
) >= 0, xorig
, s_bindings
, "let");
1010 { /* vars and inits both in order */
1011 arg1
= SCM_CAR (proc
);
1012 ASSYNT (2 == scm_ilength (arg1
), xorig
, s_bindings
, "let");
1013 ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, s_variable
, "let");
1014 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1015 varloc
= SCM_CDRLOC (*varloc
);
1016 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1017 initloc
= SCM_CDRLOC (*initloc
);
1018 proc
= SCM_CDR (proc
);
1021 scm_m_letrec (scm_cons2 (scm_i_let
,
1022 scm_cons (scm_cons2 (name
, scm_cons2 (scm_i_lambda
, vars
, SCM_CDR (x
)), SCM_EOL
), SCM_EOL
),
1023 scm_acons (name
, inits
, SCM_EOL
)), /* body */
1030 scm_m_apply (xorig
, env
)
1034 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, xorig
, s_expression
, "@apply");
1035 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1038 #define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
1042 scm_m_cont (xorig
, env
)
1046 ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, xorig
, s_expression
, "@call-with-current-continuation");
1047 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1050 /* scm_unmemocopy takes a memoized expression together with its
1051 * environment and rewrites it to its original form. Thus, it is the
1052 * inversion of the rewrite rules above. The procedure is not
1053 * optimized for speed. It's used in scm_iprin1 when printing the
1054 * code of a closure, in scm_procedure_source, in display_frame when
1055 * generating the source for a stackframe in a backtrace, and in
1056 * display_expression.
1059 static SCM unmemocopy
SCM_P ((SCM x
, SCM env
));
1067 #ifdef DEBUG_EXTENSIONS
1070 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1072 #ifdef DEBUG_EXTENSIONS
1073 p
= scm_whash_lookup (scm_source_whash
, x
);
1075 switch (SCM_TYP7 (x
))
1077 case (127 & SCM_IM_AND
):
1078 ls
= z
= scm_cons (scm_i_and
, SCM_UNSPECIFIED
);
1080 case (127 & SCM_IM_BEGIN
):
1081 ls
= z
= scm_cons (scm_i_begin
, SCM_UNSPECIFIED
);
1083 case (127 & SCM_IM_CASE
):
1084 ls
= z
= scm_cons (scm_i_case
, SCM_UNSPECIFIED
);
1086 case (127 & SCM_IM_COND
):
1087 ls
= z
= scm_cons (scm_i_cond
, SCM_UNSPECIFIED
);
1089 case (127 & SCM_IM_DO
):
1090 ls
= scm_cons (scm_i_do
, SCM_UNSPECIFIED
);
1092 case (127 & SCM_IM_IF
):
1093 ls
= z
= scm_cons (scm_i_if
, SCM_UNSPECIFIED
);
1095 case (127 & SCM_IM_LET
):
1096 ls
= scm_cons (scm_i_let
, SCM_UNSPECIFIED
);
1098 case (127 & SCM_IM_LETREC
):
1101 ls
= scm_cons (scm_i_letrec
, SCM_UNSPECIFIED
);
1104 f
= v
= SCM_CAR (x
);
1106 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1107 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1108 SCM_CAR (ls
) == scm_i_letrec
? z
: env
));
1110 s
= SCM_CAR (ls
) == scm_i_do
1111 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1116 z
= scm_acons (SCM_CAR (v
),
1117 scm_cons (SCM_CAR (e
),
1118 SCM_CAR (s
) == SCM_CAR (v
)
1120 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1127 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1129 if (SCM_CAR (ls
) == scm_i_do
)
1132 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1135 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1139 case (127 & SCM_IM_LETSTAR
):
1147 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1150 y
= z
= scm_acons (SCM_CAR (b
),
1152 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1154 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1155 b
= SCM_CDR (SCM_CDR (b
));
1158 SCM_SETCDR (y
, SCM_EOL
);
1159 ls
= scm_cons (scm_i_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1164 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1166 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1169 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1170 b
= SCM_CDR (SCM_CDR (b
));
1173 SCM_SETCDR (z
, SCM_EOL
);
1175 ls
= scm_cons (scm_i_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1178 case (127 & SCM_IM_OR
):
1179 ls
= z
= scm_cons (scm_i_or
, SCM_UNSPECIFIED
);
1181 case (127 & SCM_IM_LAMBDA
):
1183 ls
= scm_cons (scm_i_lambda
,
1184 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1185 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1187 case (127 & SCM_IM_QUOTE
):
1188 ls
= z
= scm_cons (scm_i_quote
, SCM_UNSPECIFIED
);
1190 case (127 & SCM_IM_SET
):
1191 ls
= z
= scm_cons (scm_i_set
, SCM_UNSPECIFIED
);
1193 case (127 & SCM_IM_DEFINE
):
1197 ls
= scm_cons (scm_i_define
,
1198 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1199 if (SCM_NNULLP (env
))
1200 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1203 case (127 & SCM_MAKISYM (0)):
1207 switch SCM_ISYMNUM (z
)
1209 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1210 ls
= z
= scm_cons (scm_i_atapply
, SCM_UNSPECIFIED
);
1212 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1213 ls
= z
= scm_cons (scm_i_atcall_cc
, SCM_UNSPECIFIED
);
1216 /* appease the Sun compiler god: */ ;
1220 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1225 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1227 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1233 #ifdef DEBUG_EXTENSIONS
1234 if (SCM_NFALSEP (p
))
1235 scm_whash_insert (scm_source_whash
, ls
, p
);
1242 scm_unmemocopy (x
, env
)
1246 if (SCM_NNULLP (env
))
1247 /* Make a copy of the lowest frame to protect it from
1248 modifications by SCM_IM_DEFINE */
1249 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1251 return unmemocopy (x
, env
);
1257 scm_badargsp (formals
, args
)
1268 formals
= SCM_CDR (formals
);
1269 args
= SCM_CDR (args
);
1271 return SCM_NNULLP (args
) ? 1 : 0;
1277 long scm_tc16_macro
;
1281 scm_eval_args (l
, env
, proc
)
1286 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1287 while (SCM_NIMP (l
))
1292 else if (SCM_CONSP (l
))
1294 if (SCM_IMP (SCM_CAR (l
)))
1295 res
= EVALIM (SCM_CAR (l
), env
);
1297 res
= EVALCELLCAR (l
, env
);
1299 else if (SCM_TYP3 (l
) == 1)
1301 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1302 res
= SCM_CAR (l
); /* struct planted in code */
1307 res
= EVALCAR (l
, env
);
1309 *lloc
= scm_cons (res
, SCM_EOL
);
1310 lloc
= SCM_CDRLOC (*lloc
);
1317 scm_wrong_num_args (proc
);
1324 /* The SCM_CEVAL and SCM_APPLY functions use this function instead of
1325 calling setjmp directly, to make sure that local variables don't
1326 have their values clobbered by a longjmp.
1328 According to Harbison & Steele, "Automatic variables local to the
1329 function containing setjmp are guaranteed to have their correct
1330 value in ANSI C only if they have a volatile-qualified type or if
1331 their values were not changed between the original call to setjmp
1332 and the corresponding longjmp call."
1334 SCM_CEVAL and SCM_APPLY are too complex for me to see how to meet
1335 the second condition, and making x and env volatile would be a
1336 speed problem, so we'll just trivially meet the first, by having no
1337 "automatic variables local to the function containing setjmp." */
1339 /* Actually, this entire approach is bogus, because setjmp ends up
1340 capturing the stack frame of the wrapper function, which then
1341 returns, rendering the jump buffer invalid. Duh. Gotta find a
1342 better way... -JimB */
1343 #define safe_setjmp(x) setjmp (x)
1346 unsafe_setjmp (jmp_buf env
)
1348 /* I think ANSI requires us to write the function this way, instead
1349 of just saying "return setjmp (env)". Maybe I'm being silly.
1350 See Harbison & Steele, third edition, p. 353. */
1361 /* SECTION: This code is specific for the debugging support. One
1362 * branch is read when DEVAL isn't defined, the other when DEVAL is
1368 #define SCM_APPLY scm_apply
1369 #define PREP_APPLY(proc, args)
1371 #define RETURN(x) return x;
1372 #ifdef STACK_CHECKING
1373 #ifndef NO_CEVAL_STACK_CHECKING
1374 #define EVAL_STACK_CHECKING
1381 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1383 #define SCM_APPLY scm_dapply
1385 #define PREP_APPLY(p, l) \
1386 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1388 #define ENTER_APPLY \
1390 SCM_SET_ARGSREADY (debug);\
1392 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1394 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1395 SCM_SET_TRACED_FRAME (debug); \
1396 SCM_APPLY_FRAME_P = 0; \
1398 SCM_RESET_DEBUG_MODE; \
1399 if (SCM_CHEAPTRAPS_P)\
1401 tmp = scm_make_debugobj (&debug);\
1402 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1406 scm_make_cont (&tmp);\
1407 if (!safe_setjmp (SCM_JMPBUF (tmp)))\
1408 scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1413 #define RETURN(e) {proc = (e); goto exit;}
1414 #ifdef STACK_CHECKING
1415 #ifndef EVAL_STACK_CHECKING
1416 #define EVAL_STACK_CHECKING
1420 /* scm_ceval_ptr points to the currently selected evaluator.
1421 * *fixme*: Although efficiency is important here, this state variable
1422 * should probably not be a global. It should be related to the
1427 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1429 /* scm_last_debug_frame contains a pointer to the last debugging
1430 * information stack frame. It is accessed very often from the
1431 * debugging evaluator, so it should probably not be indirectly
1432 * addressed. Better to save and restore it from the current root at
1437 scm_debug_frame
*scm_last_debug_frame
;
1440 /* scm_debug_eframe_size is the number of slots available for pseudo
1441 * stack frames at each real stack frame.
1444 int scm_debug_eframe_size
;
1446 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1450 scm_option scm_eval_opts
[] = {
1451 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1454 scm_option scm_debug_opts
[] = {
1455 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1456 "*Flyweight representation of the stack at traps." },
1457 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1458 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1459 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1460 "Record procedure names at definition." },
1461 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1462 "Display backtrace in anti-chronological order." },
1463 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1464 { SCM_OPTION_INTEGER
, "frames", 3,
1465 "Maximum number of tail-recursive frames in backtrace." },
1466 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1467 "Maximal number of stored backtrace frames." },
1468 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1469 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1470 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1471 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1474 scm_option scm_evaluator_trap_table
[] = {
1475 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1476 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1477 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1480 SCM_PROC (s_eval_options_interface
, "eval-options-interface", 0, 1, 0, scm_eval_options_interface
);
1483 scm_eval_options_interface (setting
)
1488 ans
= scm_options (setting
,
1491 s_eval_options_interface
);
1492 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1497 SCM_PROC (s_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps
);
1500 scm_evaluator_traps (setting
)
1505 ans
= scm_options (setting
,
1506 scm_evaluator_trap_table
,
1507 SCM_N_EVALUATOR_TRAPS
,
1509 SCM_RESET_DEBUG_MODE
;
1515 scm_deval_args (l
, env
, proc
, lloc
)
1516 SCM l
, env
, proc
, *lloc
;
1518 SCM
*results
= lloc
, res
;
1519 while (SCM_NIMP (l
))
1524 else if (SCM_CONSP (l
))
1526 if (SCM_IMP (SCM_CAR (l
)))
1527 res
= EVALIM (SCM_CAR (l
), env
);
1529 res
= EVALCELLCAR (l
, env
);
1531 else if (SCM_TYP3 (l
) == 1)
1533 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1534 res
= SCM_CAR (l
); /* struct planted in code */
1539 res
= EVALCAR (l
, env
);
1541 *lloc
= scm_cons (res
, SCM_EOL
);
1542 lloc
= SCM_CDRLOC (*lloc
);
1549 scm_wrong_num_args (proc
);
1558 /* SECTION: Some local definitions for the evaluator.
1563 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1565 #define CHECK_EQVISH(A,B) ((A) == (B))
1569 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1571 /* SECTION: This is the evaluator. Like any real monster, it has
1572 * three heads. This code is compiled twice.
1604 scm_debug_frame debug
;
1605 scm_debug_info
*debug_info_end
;
1606 debug
.prev
= scm_last_debug_frame
;
1607 debug
.status
= scm_debug_eframe_size
;
1608 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1609 * sizeof (debug
.vect
[0]));
1610 debug
.info
= debug
.vect
;
1611 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1612 scm_last_debug_frame
= &debug
;
1614 #ifdef EVAL_STACK_CHECKING
1615 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1616 && scm_stack_checking_enabled_p
)
1619 debug
.info
->e
.exp
= x
;
1620 debug
.info
->e
.env
= env
;
1622 scm_report_stack_overflow ();
1629 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1632 SCM_CLEAR_ARGSREADY (debug
);
1633 if (SCM_OVERFLOWP (debug
))
1635 else if (++debug
.info
>= debug_info_end
)
1637 SCM_SET_OVERFLOW (debug
);
1641 debug
.info
->e
.exp
= x
;
1642 debug
.info
->e
.env
= env
;
1644 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1646 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1647 SCM_SET_TAILREC (debug
);
1648 SCM_ENTER_FRAME_P
= 0;
1649 SCM_RESET_DEBUG_MODE
;
1650 if (SCM_CHEAPTRAPS_P
)
1651 t
.arg1
= scm_make_debugobj (&debug
);
1654 scm_make_cont (&t
.arg1
);
1655 if (safe_setjmp (SCM_JMPBUF (t
.arg1
)))
1657 x
= SCM_THROW_VALUE (t
.arg1
);
1663 /* This gives the possibility for the debugger to
1664 modify the source expression before evaluation. */
1668 scm_ithrow (scm_i_enter_frame
,
1669 scm_cons2 (t
.arg1
, tail
,
1670 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1674 #if defined (USE_THREADS) || defined (DEVAL)
1678 switch (SCM_TYP7 (x
))
1680 case scm_tcs_symbols
:
1681 /* Only happens when called at top level.
1683 x
= scm_cons (x
, SCM_UNDEFINED
);
1686 case (127 & SCM_IM_AND
):
1689 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1690 if (SCM_FALSEP (EVALCAR (x
, env
)))
1692 RETURN (SCM_BOOL_F
);
1696 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1699 case (127 & SCM_IM_BEGIN
):
1701 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1707 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1709 SIDEVAL (SCM_CAR (x
), env
);
1713 carloop
: /* scm_eval car of last form in list */
1714 if (SCM_NCELLP (SCM_CAR (x
)))
1717 RETURN (SCM_IMP (x
) ? EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1720 if (SCM_SYMBOLP (SCM_CAR (x
)))
1723 RETURN (*scm_lookupcar (x
, env
))
1727 goto loop
; /* tail recurse */
1730 case (127 & SCM_IM_CASE
):
1732 t
.arg1
= EVALCAR (x
, env
);
1733 while (SCM_NIMP (x
= SCM_CDR (x
)))
1736 if (scm_i_else
== SCM_CAR (proc
))
1739 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1742 proc
= SCM_CAR (proc
);
1743 while (SCM_NIMP (proc
))
1745 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1747 x
= SCM_CDR (SCM_CAR (x
));
1748 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1751 proc
= SCM_CDR (proc
);
1754 RETURN (SCM_UNSPECIFIED
)
1757 case (127 & SCM_IM_COND
):
1758 while (SCM_NIMP (x
= SCM_CDR (x
)))
1761 t
.arg1
= EVALCAR (proc
, env
);
1762 if (SCM_NFALSEP (t
.arg1
))
1769 if (scm_i_arrow
!= SCM_CAR (x
))
1771 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1775 proc
= EVALCAR (proc
, env
);
1776 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1777 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
1782 RETURN (SCM_UNSPECIFIED
)
1785 case (127 & SCM_IM_DO
):
1787 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
1788 t
.arg1
= SCM_EOL
; /* values */
1789 while (SCM_NIMP (proc
))
1791 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1792 proc
= SCM_CDR (proc
);
1794 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1795 x
= SCM_CDR (SCM_CDR (x
));
1796 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
1798 for (proc
= SCM_CAR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1800 t
.arg1
= SCM_CAR (proc
); /* body */
1801 SIDEVAL (t
.arg1
, env
);
1803 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDR (SCM_CDR (x
)); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
1804 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
1805 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
1809 RETURN (SCM_UNSPECIFIED
);
1810 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1814 case (127 & SCM_IM_IF
):
1816 if (SCM_NFALSEP (EVALCAR (x
, env
)))
1818 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
1820 RETURN (SCM_UNSPECIFIED
);
1822 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1826 case (127 & SCM_IM_LET
):
1828 proc
= SCM_CAR (SCM_CDR (x
));
1832 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1834 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1835 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
1840 case (127 & SCM_IM_LETREC
):
1842 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
1848 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
1850 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1851 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
1855 case (127 & SCM_IM_LETSTAR
):
1860 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1865 t
.arg1
= SCM_CAR (proc
);
1866 proc
= SCM_CDR (proc
);
1867 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
1869 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1872 case (127 & SCM_IM_OR
):
1875 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1877 x
= EVALCAR (x
, env
);
1878 if (SCM_NFALSEP (x
))
1884 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1888 case (127 & SCM_IM_LAMBDA
):
1889 RETURN (scm_closure (SCM_CDR (x
), env
));
1892 case (127 & SCM_IM_QUOTE
):
1893 RETURN (SCM_CAR (SCM_CDR (x
)));
1896 case (127 & SCM_IM_SET
):
1899 switch (7 & (int) proc
)
1902 t
.lloc
= scm_lookupcar (x
, env
);
1905 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
1907 #ifdef MEMOIZE_LOCALS
1909 t
.lloc
= scm_ilookup (proc
, env
);
1914 *t
.lloc
= EVALCAR (x
, env
);
1918 RETURN (SCM_UNSPECIFIED
);
1922 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
1926 x
= evalcar (x
, env
);
1927 #ifdef DEBUG_EXTENSIONS
1928 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
1932 if (SCM_CLOSUREP (t
.arg1
)
1933 /* Only the first definition determines the name. */
1934 && (scm_procedure_property (t
.arg1
, scm_i_inner_name
)
1936 scm_set_procedure_property_x (t
.arg1
, scm_i_inner_name
, proc
);
1937 else if (SCM_TYP16 (t
.arg1
) == scm_tc16_macro
1938 && SCM_CDR (t
.arg1
) != t
.arg1
)
1940 t
.arg1
= SCM_CDR (t
.arg1
);
1945 env
= SCM_CAR (env
);
1947 SCM_SETCAR (env
, scm_cons (proc
, SCM_CAR (env
)));
1948 SCM_SETCDR (env
, scm_cons (x
, SCM_CDR (env
)));
1950 RETURN (SCM_UNSPECIFIED
);
1953 /* new syntactic forms go here. */
1954 case (127 & SCM_MAKISYM (0)):
1956 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
1957 switch SCM_ISYMNUM (proc
)
1960 case (SCM_ISYMNUM (IM_VREF
)):
1963 var
= SCM_CAR (SCM_CDR (x
));
1964 RETURN (SCM_CDR(var
));
1966 case (SCM_ISYMNUM (IM_VSET
)):
1967 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
1968 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
1969 RETURN (SCM_UNSPECIFIED
)
1972 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1974 proc
= EVALCAR (proc
, env
);
1975 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
1976 if (SCM_CLOSUREP (proc
))
1979 PREP_APPLY (proc
, SCM_EOL
);
1980 t
.arg1
= SCM_CDR (SCM_CDR (x
));
1981 t
.arg1
= EVALCAR (t
.arg1
, env
);
1983 debug
.info
->a
.args
= t
.arg1
;
1986 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
1989 /* Copy argument list */
1990 if (SCM_IMP (t
.arg1
))
1994 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
1995 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
1996 && SCM_CONSP (t
.arg1
))
1998 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2002 SCM_SETCDR (tl
, t
.arg1
);
2005 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2006 x
= SCM_CODE (proc
);
2012 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2013 scm_make_cont (&t
.arg1
);
2014 if (safe_setjmp (SCM_JMPBUF (t
.arg1
)))
2017 val
= SCM_THROW_VALUE (t
.arg1
);
2021 proc
= evalcar (proc
, env
);
2022 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2023 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2034 /* scm_everr (x, env,...) */
2035 scm_misc_error (NULL
,
2036 "Wrong type to apply: %S",
2037 scm_listify (proc
, SCM_UNDEFINED
));
2038 case scm_tc7_vector
:
2041 case scm_tc7_byvect
:
2049 case scm_tc7_llvect
:
2051 case scm_tc7_string
:
2052 case scm_tc7_substring
:
2054 case scm_tcs_closures
:
2058 #ifdef MEMOIZE_LOCALS
2059 case (127 & SCM_ILOC00
):
2060 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2061 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2068 #endif /* ifdef MEMOIZE_LOCALS */
2071 case scm_tcs_cons_gloc
:
2072 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2073 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2082 case scm_tcs_cons_nimcar
:
2083 if (SCM_SYMBOLP (SCM_CAR (x
)))
2086 t
.lloc
= scm_lookupcar1 (x
, env
);
2089 /* we have lost the race, start again. */
2094 proc
= *scm_lookupcar (x
, env
);
2102 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2107 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2108 scm_cons (env
, scm_listofnull
));
2110 switch ((int) (SCM_CAR (proc
) >> 16))
2113 if (scm_ilength (t
.arg1
) <= 0)
2114 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2116 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2119 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2120 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2121 /* Prevent memoizing result of define macro */
2123 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2124 scm_set_source_properties_x (debug
.info
->e
.exp
,
2125 scm_source_properties (x
));
2129 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2130 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2134 /* Prevent memoizing of debug info expression. */
2135 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2136 scm_set_source_properties_x (debug
.info
->e
.exp
,
2137 scm_source_properties (x
));
2140 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2141 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2145 if (SCM_NIMP (x
= t
.arg1
))
2153 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2154 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2159 if (SCM_CLOSUREP (proc
))
2161 arg2
= SCM_CAR (SCM_CODE (proc
));
2162 t
.arg1
= SCM_CDR (x
);
2163 while (SCM_NIMP (arg2
))
2165 if (SCM_NCONSP (arg2
))
2167 if (SCM_IMP (t
.arg1
))
2168 goto umwrongnumargs
;
2169 arg2
= SCM_CDR (arg2
);
2170 t
.arg1
= SCM_CDR (t
.arg1
);
2172 if (SCM_NNULLP (t
.arg1
))
2173 goto umwrongnumargs
;
2175 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2176 goto handle_a_macro
;
2182 PREP_APPLY (proc
, SCM_EOL
);
2183 if (SCM_NULLP (SCM_CDR (x
))) {
2185 switch (SCM_TYP7 (proc
))
2186 { /* no arguments given */
2187 case scm_tc7_subr_0
:
2188 RETURN (SCM_SUBRF (proc
) ());
2189 case scm_tc7_subr_1o
:
2190 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2192 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2193 case scm_tc7_rpsubr
:
2194 RETURN (SCM_BOOL_T
);
2196 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2200 proc
= SCM_CCLO_SUBR (proc
);
2202 debug
.info
->a
.proc
= proc
;
2203 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2207 case scm_tcs_closures
:
2208 x
= SCM_CODE (proc
);
2209 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2211 case scm_tcs_cons_gloc
:
2212 if (SCM_I_OPERATORP (proc
))
2214 x
= (SCM_I_ENTITYP (proc
)
2215 ? SCM_ENTITY_PROC_0 (proc
)
2216 : SCM_OPERATOR_PROC_0 (proc
));
2219 if (SCM_TYP7 (x
) == scm_tc7_subr_1
)
2220 RETURN (SCM_SUBRF (x
) (proc
))
2221 else if (SCM_CLOSUREP (x
))
2226 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2227 debug
.info
->a
.proc
= proc
;
2234 case scm_tc7_contin
:
2235 case scm_tc7_subr_1
:
2236 case scm_tc7_subr_2
:
2237 case scm_tc7_subr_2o
:
2239 case scm_tc7_subr_3
:
2240 case scm_tc7_lsubr_2
:
2244 /* scm_everr (x, env,...) */
2245 scm_wrong_num_args (proc
);
2247 /* handle macros here */
2252 /* must handle macros by here */
2257 else if (SCM_CONSP (x
))
2259 if (SCM_IMP (SCM_CAR (x
)))
2260 t
.arg1
= EVALIM (SCM_CAR (x
), env
);
2262 t
.arg1
= EVALCELLCAR (x
, env
);
2264 else if (SCM_TYP3 (x
) == 1)
2266 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2267 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2272 t
.arg1
= EVALCAR (x
, env
);
2275 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2282 switch (SCM_TYP7 (proc
))
2283 { /* have one argument in t.arg1 */
2284 case scm_tc7_subr_2o
:
2285 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2286 case scm_tc7_subr_1
:
2287 case scm_tc7_subr_1o
:
2288 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2291 if (SCM_SUBRF (proc
))
2293 if (SCM_INUMP (t
.arg1
))
2295 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2298 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2299 if (SCM_REALP (t
.arg1
))
2301 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2304 if (SCM_BIGP (t
.arg1
))
2306 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2310 scm_wta (t
.arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2313 proc
= (SCM
) SCM_SNAME (proc
);
2315 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2316 while ('c' != *--chrs
)
2318 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2319 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2320 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2324 case scm_tc7_rpsubr
:
2325 RETURN (SCM_BOOL_T
);
2327 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2330 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2332 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2338 proc
= SCM_CCLO_SUBR (proc
);
2340 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2341 debug
.info
->a
.proc
= proc
;
2345 case scm_tcs_closures
:
2347 x
= SCM_CODE (proc
);
2349 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2351 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2354 case scm_tc7_contin
:
2355 scm_call_continuation (proc
, t
.arg1
);
2356 case scm_tcs_cons_gloc
:
2357 if (SCM_I_OPERATORP (proc
))
2359 x
= (SCM_I_ENTITYP (proc
)
2360 ? SCM_ENTITY_PROC_1 (proc
)
2361 : SCM_OPERATOR_PROC_1 (proc
));
2364 if (SCM_TYP7 (x
) == scm_tc7_subr_2
)
2365 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
))
2366 else if (SCM_CLOSUREP (x
))
2372 debug
.info
->a
.args
= scm_cons (t
.arg1
,
2373 debug
.info
->a
.args
);
2374 debug
.info
->a
.proc
= proc
;
2381 case scm_tc7_subr_2
:
2382 case scm_tc7_subr_0
:
2383 case scm_tc7_subr_3
:
2384 case scm_tc7_lsubr_2
:
2393 else if (SCM_CONSP (x
))
2395 if (SCM_IMP (SCM_CAR (x
)))
2396 arg2
= EVALIM (SCM_CAR (x
), env
);
2398 arg2
= EVALCELLCAR (x
, env
);
2400 else if (SCM_TYP3 (x
) == 1)
2402 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2403 arg2
= SCM_CAR (x
); /* struct planted in code */
2408 arg2
= EVALCAR (x
, env
);
2410 { /* have two or more arguments */
2412 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2415 if (SCM_NULLP (x
)) {
2420 switch (SCM_TYP7 (proc
))
2421 { /* have two arguments */
2422 case scm_tc7_subr_2
:
2423 case scm_tc7_subr_2o
:
2424 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2427 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2429 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2431 case scm_tc7_lsubr_2
:
2432 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2433 case scm_tc7_rpsubr
:
2435 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2440 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2441 scm_cons (debug
.info
->a
.args
, SCM_EOL
)));
2443 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
), proc
,
2444 scm_cons2 (t
.arg1
, arg2
,
2445 scm_cons (scm_eval_args (x
, env
, proc
),
2448 /* case scm_tc7_cclo:
2449 x = scm_cons(arg2, scm_eval_args(x, env));
2452 proc = SCM_CCLO_SUBR(proc);
2455 case scm_tcs_cons_gloc
:
2456 if (SCM_I_OPERATORP (proc
))
2458 x
= (SCM_I_ENTITYP (proc
)
2459 ? SCM_ENTITY_PROC_2 (proc
)
2460 : SCM_OPERATOR_PROC_2 (proc
));
2463 if (SCM_TYP7 (x
) == scm_tc7_subr_3
)
2464 RETURN (SCM_SUBRF (x
) (proc
, t
.arg1
, arg2
))
2465 else if (SCM_CLOSUREP (x
))
2468 SCM_SET_ARGSREADY (debug
);
2469 debug
.info
->a
.args
= scm_cons (proc
,
2470 debug
.info
->a
.args
);
2471 debug
.info
->a
.proc
= x
;
2473 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (x
)),
2474 scm_cons2 (proc
, t
.arg1
,
2475 scm_cons (arg2
, SCM_EOL
)),
2483 case scm_tc7_subr_0
:
2485 case scm_tc7_subr_1o
:
2486 case scm_tc7_subr_1
:
2487 case scm_tc7_subr_3
:
2488 case scm_tc7_contin
:
2492 case scm_tcs_closures
:
2495 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2499 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2500 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2502 x
= SCM_CODE (proc
);
2507 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2511 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2512 scm_deval_args (x
, env
, proc
,
2513 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2516 switch (SCM_TYP7 (proc
))
2517 { /* have 3 or more arguments */
2519 case scm_tc7_subr_3
:
2520 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2521 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2522 SCM_CADDR (debug
.info
->a
.args
)));
2524 #ifdef BUILTIN_RPASUBR
2525 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
2526 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2529 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
2530 arg2
= SCM_CDR (arg2
);
2532 while (SCM_NIMP (arg2
));
2534 #endif /* BUILTIN_RPASUBR */
2535 case scm_tc7_rpsubr
:
2536 #ifdef BUILTIN_RPASUBR
2537 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2539 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
2542 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
2544 arg2
= SCM_CAR (t
.arg1
);
2545 t
.arg1
= SCM_CDR (t
.arg1
);
2547 while (SCM_NIMP (t
.arg1
));
2549 #else /* BUILTIN_RPASUBR */
2550 RETURN (SCM_APPLY (proc
, t
.arg1
,
2552 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
2554 #endif /* BUILTIN_RPASUBR */
2555 case scm_tc7_lsubr_2
:
2556 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2557 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
2559 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2564 case scm_tcs_closures
:
2565 SCM_SET_ARGSREADY (debug
);
2566 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2569 x
= SCM_CODE (proc
);
2572 case scm_tc7_subr_3
:
2573 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2574 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
2576 #ifdef BUILTIN_RPASUBR
2577 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
2580 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
2583 while (SCM_NIMP (x
));
2585 #endif /* BUILTIN_RPASUBR */
2586 case scm_tc7_rpsubr
:
2587 #ifdef BUILTIN_RPASUBR
2588 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
2592 t
.arg1
= EVALCAR (x
, env
);
2593 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
2598 while (SCM_NIMP (x
));
2600 #else /* BUILTIN_RPASUBR */
2601 RETURN (SCM_APPLY (proc
, t
.arg1
,
2603 scm_eval_args (x
, env
, proc
),
2605 #endif /* BUILTIN_RPASUBR */
2606 case scm_tc7_lsubr_2
:
2607 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
2609 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
2611 scm_eval_args (x
, env
, proc
))));
2616 case scm_tcs_closures
:
2618 SCM_SET_ARGSREADY (debug
);
2620 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2623 scm_eval_args (x
, env
, proc
)),
2625 x
= SCM_CODE (proc
);
2628 case scm_tcs_cons_gloc
:
2629 if (SCM_I_OPERATORP (proc
))
2631 SCM p
= (SCM_I_ENTITYP (proc
)
2632 ? SCM_ENTITY_PROC_3 (proc
)
2633 : SCM_OPERATOR_PROC_3 (proc
));
2636 if (SCM_TYP7 (p
) == scm_tc7_lsubr_2
)
2638 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2639 scm_cons (arg2
, SCM_CDDR (debug
.info
->a
.args
))))
2641 RETURN (SCM_SUBRF (p
) (proc
, t
.arg1
,
2643 scm_eval_args (x
, env
, proc
))))
2645 else if (SCM_CLOSUREP (p
))
2648 SCM_SET_ARGSREADY (debug
);
2649 debug
.info
->a
.args
= scm_cons (proc
, debug
.info
->a
.args
);
2650 debug
.info
->a
.proc
= p
;
2651 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2652 scm_cons2 (proc
, t
.arg1
,
2654 SCM_CDDDR (debug
.info
->a
.args
))),
2657 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (p
)),
2658 scm_cons2 (proc
, t
.arg1
,
2660 scm_eval_args (x
, env
, proc
))),
2669 case scm_tc7_subr_2
:
2670 case scm_tc7_subr_1o
:
2671 case scm_tc7_subr_2o
:
2672 case scm_tc7_subr_0
:
2674 case scm_tc7_subr_1
:
2675 case scm_tc7_contin
:
2684 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
2686 SCM_EXIT_FRAME_P
= 0;
2688 SCM_RESET_DEBUG_MODE
;
2689 SCM_CLEAR_TRACED_FRAME (debug
);
2690 if (SCM_CHEAPTRAPS_P
)
2691 t
.arg1
= scm_make_debugobj (&debug
);
2694 scm_make_cont (&t
.arg1
);
2695 if (safe_setjmp (SCM_JMPBUF (t
.arg1
)))
2697 proc
= SCM_THROW_VALUE (t
.arg1
);
2701 scm_ithrow (scm_i_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
2704 scm_last_debug_frame
= debug
.prev
;
2710 /* SECTION: This code is compiled once.
2715 SCM_PROC(s_procedure_documentation
, "procedure-documentation", 1, 0, 0, scm_procedure_documentation
);
2718 scm_procedure_documentation (proc
)
2722 SCM_ASSERT (SCM_BOOL_T
== scm_procedure_p (proc
) && SCM_NIMP (proc
) && SCM_TYP7 (proc
) != scm_tc7_contin
,
2723 proc
, SCM_ARG1
, s_procedure_documentation
);
2724 switch (SCM_TYP7 (proc
))
2726 case scm_tcs_closures
:
2727 code
= SCM_CDR (SCM_CODE (proc
));
2728 if (SCM_IMP (SCM_CDR (code
)))
2730 code
= SCM_CAR (code
);
2733 if (SCM_STRINGP (code
))
2746 /* This code processes the arguments to apply:
2748 (apply PROC ARG1 ... ARGS)
2750 Given a list (ARG1 ... ARGS), this function conses the ARG1
2751 ... arguments onto the front of ARGS, and returns the resulting
2752 list. Note that ARGS is a list; thus, the argument to this
2753 function is a list whose last element is a list.
2755 Apply calls this function, and applies PROC to the elements of the
2756 result. apply:nconc2last takes care of building the list of
2757 arguments, given (ARG1 ... ARGS).
2759 Rather than do new consing, apply:nconc2last destroys its argument.
2760 On that topic, this code came into my care with the following
2761 beautifully cryptic comment on that topic: "This will only screw
2762 you if you do (scm_apply scm_apply '( ... ))" If you know what
2763 they're referring to, send me a patch to this comment. */
2765 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
2768 scm_nconc2last (lst
)
2772 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
2774 while (SCM_NNULLP (SCM_CDR (*lloc
)))
2775 lloc
= SCM_CDRLOC (*lloc
);
2776 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
2777 *lloc
= SCM_CAR (*lloc
);
2784 /* SECTION: When DEVAL is defined this code yields scm_dapply.
2785 * It is compiled twice.
2791 scm_apply (proc
, arg1
, args
)
2801 scm_dapply (proc
, arg1
, args
)
2809 /* Apply a function to a list of arguments.
2811 This function is exported to the Scheme level as taking two
2812 required arguments and a tail argument, as if it were:
2813 (lambda (proc arg1 . args) ...)
2814 Thus, if you just have a list of arguments to pass to a procedure,
2815 pass the list as ARG1, and '() for ARGS. If you have some fixed
2816 args, pass the first as ARG1, then cons any remaining fixed args
2817 onto the front of your argument list, and pass that as ARGS. */
2820 SCM_APPLY (proc
, arg1
, args
)
2825 #ifdef DEBUG_EXTENSIONS
2827 scm_debug_frame debug
;
2828 scm_debug_info debug_vect_body
;
2829 debug
.prev
= scm_last_debug_frame
;
2830 debug
.status
= SCM_APPLYFRAME
;
2831 debug
.vect
= &debug_vect_body
;
2832 debug
.vect
[0].a
.proc
= proc
;
2833 debug
.vect
[0].a
.args
= SCM_EOL
;
2834 scm_last_debug_frame
= &debug
;
2837 return scm_dapply (proc
, arg1
, args
);
2841 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
2843 /* If ARGS is the empty list, then we're calling apply with only two
2844 arguments --- ARG1 is the list of arguments for PROC. Whatever
2845 the case, futz with things so that ARG1 is the first argument to
2846 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
2849 Setting the debug apply frame args this way is pretty messy.
2850 Perhaps we should store arg1 and args directly in the frame as
2851 received, and let scm_frame_arguments unpack them, because that's
2852 a relatively rare operation. This works for now; if the Guile
2853 developer archives are still around, see Mikael's post of
2855 if (SCM_NULLP (args
))
2857 if (SCM_NULLP (arg1
))
2859 arg1
= SCM_UNDEFINED
;
2861 debug
.vect
[0].a
.args
= SCM_EOL
;
2867 debug
.vect
[0].a
.args
= arg1
;
2869 args
= SCM_CDR (arg1
);
2870 arg1
= SCM_CAR (arg1
);
2875 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
2876 args
= scm_nconc2last (args
);
2878 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
2882 if (SCM_ENTER_FRAME_P
)
2885 SCM_ENTER_FRAME_P
= 0;
2886 SCM_RESET_DEBUG_MODE
;
2887 if (SCM_CHEAPTRAPS_P
)
2888 tmp
= scm_make_debugobj (&debug
);
2891 scm_make_cont (&tmp
);
2892 if (safe_setjmp (SCM_JMPBUF (tmp
)))
2895 scm_ithrow (scm_i_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
2903 switch (SCM_TYP7 (proc
))
2905 case scm_tc7_subr_2o
:
2906 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
2907 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2908 case scm_tc7_subr_2
:
2909 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
2911 args
= SCM_CAR (args
);
2912 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
2913 case scm_tc7_subr_0
:
2914 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
2915 RETURN (SCM_SUBRF (proc
) ())
2916 case scm_tc7_subr_1
:
2917 case scm_tc7_subr_1o
:
2918 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2919 RETURN (SCM_SUBRF (proc
) (arg1
))
2921 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
2923 if (SCM_SUBRF (proc
))
2925 if (SCM_INUMP (arg1
))
2927 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
2929 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
2930 if (SCM_REALP (arg1
))
2932 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
2937 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
2940 scm_wta (arg1
, (char *) SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2943 proc
= (SCM
) SCM_SNAME (proc
);
2945 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2946 while ('c' != *--chrs
)
2948 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
2949 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2950 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2954 case scm_tc7_subr_3
:
2955 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
2958 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
2960 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
2962 case scm_tc7_lsubr_2
:
2963 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
2964 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
2966 if (SCM_NULLP (args
))
2967 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
2968 while (SCM_NIMP (args
))
2970 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2971 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
2972 args
= SCM_CDR (args
);
2975 case scm_tc7_rpsubr
:
2976 if (SCM_NULLP (args
))
2977 RETURN (SCM_BOOL_T
);
2978 while (SCM_NIMP (args
))
2980 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
2981 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
2982 RETURN (SCM_BOOL_F
);
2983 arg1
= SCM_CAR (args
);
2984 args
= SCM_CDR (args
);
2986 RETURN (SCM_BOOL_T
);
2987 case scm_tcs_closures
:
2989 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
2991 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
2994 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
2998 /* Copy argument list */
3003 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3004 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
3005 && SCM_CONSP (arg1
))
3007 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3011 SCM_SETCDR (tl
, arg1
);
3014 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3015 proc
= SCM_CODE (proc
);
3016 while (SCM_NNULLP (proc
= SCM_CDR (proc
)))
3017 arg1
= EVALCAR (proc
, args
);
3019 case scm_tc7_contin
:
3020 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3021 scm_call_continuation (proc
, arg1
);
3025 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3027 proc
= SCM_CCLO_SUBR (proc
);
3028 debug
.vect
[0].a
.proc
= proc
;
3029 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3031 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3033 proc
= SCM_CCLO_SUBR (proc
);
3037 case scm_tcs_cons_gloc
:
3038 if (SCM_I_OPERATORP (proc
))
3041 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3043 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3046 proc
= (SCM_NULLP (args
)
3047 ? (SCM_I_ENTITYP (proc
)
3048 ? SCM_ENTITY_PROC_0 (proc
)
3049 : SCM_OPERATOR_PROC_0 (proc
))
3050 : SCM_NULLP (SCM_CDR (args
))
3051 ? (SCM_I_ENTITYP (proc
)
3052 ? SCM_ENTITY_PROC_1 (proc
)
3053 : SCM_OPERATOR_PROC_1 (proc
))
3054 : SCM_NULLP (SCM_CDDR (args
))
3055 ? (SCM_I_ENTITYP (proc
)
3056 ? SCM_ENTITY_PROC_2 (proc
)
3057 : SCM_OPERATOR_PROC_2 (proc
))
3058 : (SCM_I_ENTITYP (proc
)
3059 ? SCM_ENTITY_PROC_3 (proc
)
3060 : SCM_OPERATOR_PROC_3 (proc
)));
3062 debug
.vect
[0].a
.proc
= proc
;
3063 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3068 scm_wrong_num_args (proc
);
3071 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3077 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3079 SCM_EXIT_FRAME_P
= 0;
3080 SCM_RESET_DEBUG_MODE
;
3081 SCM_CLEAR_TRACED_FRAME (debug
);
3082 if (SCM_CHEAPTRAPS_P
)
3083 arg1
= scm_make_debugobj (&debug
);
3086 scm_make_cont (&arg1
);
3087 if (safe_setjmp (SCM_JMPBUF (arg1
)))
3089 proc
= SCM_THROW_VALUE (arg1
);
3093 scm_ithrow (scm_i_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3096 scm_last_debug_frame
= debug
.prev
;
3102 /* SECTION: The rest of this file is only read once.
3107 SCM_PROC(s_map
, "map", 2, 0, 1, scm_map
);
3110 scm_map (proc
, arg1
, args
)
3118 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3120 if (SCM_NULLP (arg1
))
3122 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_map
);
3123 if (SCM_NULLP (args
))
3125 while (SCM_NIMP (arg1
))
3127 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_map
);
3128 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
), SCM_EOL
);
3129 pres
= SCM_CDRLOC (*pres
);
3130 arg1
= SCM_CDR (arg1
);
3134 args
= scm_vector (scm_cons (arg1
, args
));
3135 ve
= SCM_VELTS (args
);
3137 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3138 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_map
);
3143 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3147 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3148 ve
[i
] = SCM_CDR (ve
[i
]);
3150 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3151 pres
= SCM_CDRLOC (*pres
);
3156 SCM_PROC(s_for_each
, "for-each", 2, 0, 1, scm_for_each
);
3159 scm_for_each (proc
, arg1
, args
)
3164 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3167 return SCM_UNSPECIFIED
;
3168 SCM_ASSERT (SCM_NIMP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3171 while SCM_NIMP (arg1
)
3173 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG2
, s_for_each
);
3174 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3175 arg1
= SCM_CDR (arg1
);
3177 return SCM_UNSPECIFIED
;
3179 args
= scm_vector (scm_cons (arg1
, args
));
3180 ve
= SCM_VELTS (args
);
3182 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3183 SCM_ASSERT (SCM_NIMP (ve
[i
]) && SCM_CONSP (ve
[i
]), args
, SCM_ARG2
, s_for_each
);
3188 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3191 (ve
[i
]) return SCM_UNSPECIFIED
;
3192 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3193 ve
[i
] = SCM_CDR (ve
[i
]);
3195 scm_apply (proc
, arg1
, SCM_EOL
);
3202 scm_closure (code
, env
)
3208 SCM_SETCODE (z
, code
);
3209 SCM_SETENV (z
, env
);
3214 long scm_tc16_promise
;
3222 SCM_ENTER_A_SECTION
;
3223 SCM_SETCDR (z
, code
);
3224 SCM_SETCAR (z
, scm_tc16_promise
);
3231 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
3234 prinprom (exp
, port
, pstate
)
3237 scm_print_state
*pstate
;
3239 int writingp
= SCM_WRITINGP (pstate
);
3240 scm_puts ("#<promise ", port
);
3241 SCM_SET_WRITINGP (pstate
, 1);
3242 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3243 SCM_SET_WRITINGP (pstate
, writingp
);
3244 scm_putc ('>', port
);
3249 SCM_PROC(s_makacro
, "procedure->syntax", 1, 0, 0, scm_makacro
);
3257 SCM_SETCDR (z
, code
);
3258 SCM_SETCAR (z
, scm_tc16_macro
);
3263 SCM_PROC(s_makmacro
, "procedure->macro", 1, 0, 0, scm_makmacro
);
3271 SCM_SETCDR (z
, code
);
3272 SCM_SETCAR (z
, scm_tc16_macro
| (1L << 16));
3277 SCM_PROC(s_makmmacro
, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro
);
3280 scm_makmmacro (code
)
3285 SCM_SETCDR (z
, code
);
3286 SCM_SETCAR (z
, scm_tc16_macro
| (2L << 16));
3291 SCM_PROC (s_macro_p
, "macro?", 1, 0, 0, scm_macro_p
);
3297 return (SCM_NIMP (obj
) && SCM_TYP16 (obj
) == scm_tc16_macro
3303 SCM_SYMBOL (scm_sym_syntax
, "syntax");
3304 SCM_SYMBOL (scm_sym_macro
, "macro");
3305 SCM_SYMBOL (scm_sym_mmacro
, "macro!");
3307 SCM_PROC (s_macro_type
, "macro-type", 1, 0, 0, scm_macro_type
);
3313 if (!(SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
))
3315 switch ((int) (SCM_CAR (m
) >> 16))
3317 case 0: return scm_sym_syntax
;
3318 case 1: return scm_sym_macro
;
3319 case 2: return scm_sym_mmacro
;
3320 default: scm_wrong_type_arg (s_macro_type
, 1, m
);
3325 SCM_PROC (s_macro_name
, "macro-name", 1, 0, 0, scm_macro_name
);
3331 SCM_ASSERT (SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
,
3335 return scm_procedure_name (SCM_CDR (m
));
3339 SCM_PROC (s_macro_transformer
, "macro-transformer", 1, 0, 0, scm_macro_transformer
);
3342 scm_macro_transformer (m
)
3345 SCM_ASSERT (SCM_NIMP (m
) && SCM_TYP16 (m
) == scm_tc16_macro
,
3348 s_macro_transformer
);
3349 return SCM_CLOSUREP (SCM_CDR (m
)) ? SCM_CDR (m
) : SCM_BOOL_F
;
3354 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
3360 SCM_ASSERT ((SCM_TYP16 (x
) == scm_tc16_promise
), x
, SCM_ARG1
, s_force
);
3361 if (!((1L << 16) & SCM_CAR (x
)))
3363 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3364 if (!((1L << 16) & SCM_CAR (x
)))
3367 SCM_SETCDR (x
, ans
);
3368 SCM_SETOR_CAR (x
, (1L << 16));
3375 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
3381 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
3386 SCM_PROC(s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
3395 if (SCM_VECTORP (obj
))
3397 scm_sizet i
= SCM_LENGTH (obj
);
3398 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
, SCM_UNDEFINED
);
3400 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3405 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3406 ans
= tl
= scm_cons (scm_copy_tree (SCM_CAR (obj
)), SCM_UNSPECIFIED
);
3407 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3409 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3413 SCM_SETCDR (tl
, obj
);
3419 scm_eval_3 (obj
, copyp
, env
)
3424 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3425 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3427 obj
= scm_copy_tree (obj
);
3428 return XEVAL (obj
, env
);
3433 scm_top_level_env (thunk
)
3439 return scm_cons(thunk
, (SCM
)SCM_EOL
);
3442 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
3445 scm_eval2 (obj
, env_thunk
)
3449 return scm_eval_3 (obj
, 1, scm_top_level_env(env_thunk
));
3452 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
3459 scm_eval_3(obj
, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_closure_var
)));
3462 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
3471 scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var
)));
3474 SCM_PROC (s_definedp
, "defined?", 1, 0, 0, scm_definedp
);
3482 if (SCM_ISYMP (sym
))
3485 SCM_ASSERT (SCM_NIMP (sym
) && SCM_SYMBOLP (sym
), sym
, SCM_ARG1
, s_definedp
);
3487 vcell
= scm_sym2vcell(sym
,
3488 SCM_CDR (scm_top_level_lookup_closure_var
),
3490 return (vcell
== SCM_BOOL_F
|| SCM_UNBNDP(SCM_CDR(vcell
))) ?
3491 SCM_BOOL_F
: SCM_BOOL_T
;
3494 static scm_smobfuns promsmob
= {scm_markcdr
, scm_free0
, prinprom
};
3496 static scm_smobfuns macrosmob
= {scm_markcdr
, scm_free0
};
3499 scm_make_synt (name
, macroizer
, fcn
)
3501 SCM (*macroizer
) ();
3504 SCM symcell
= scm_sysintern (name
, SCM_UNDEFINED
);
3505 long tmp
= ((((SCM_CELLPTR
) (SCM_CAR (symcell
))) - scm_heap_org
) << 8);
3507 if ((tmp
>> 8) != ((SCM_CELLPTR
) (SCM_CAR (symcell
)) - scm_heap_org
))
3510 SCM_SUBRF (z
) = fcn
;
3511 SCM_SETCAR (z
, tmp
+ scm_tc7_subr_2
);
3512 SCM_SETCDR (symcell
, macroizer (z
));
3513 return SCM_CAR (symcell
);
3517 /* At this point, scm_deval and scm_dapply are generated.
3520 #ifdef DEBUG_EXTENSIONS
3530 scm_init_opts (scm_evaluator_traps
,
3531 scm_evaluator_trap_table
,
3532 SCM_N_EVALUATOR_TRAPS
);
3533 scm_init_opts (scm_eval_options_interface
,
3535 SCM_N_EVAL_OPTIONS
);
3537 scm_tc16_promise
= scm_newsmob (&promsmob
);
3538 scm_tc16_macro
= scm_newsmob (¯osmob
);
3539 scm_i_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3540 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3541 scm_i_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3542 scm_i_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3543 scm_i_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3544 scm_i_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3545 scm_i_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3548 scm_i_quasiquote
= scm_make_synt (s_quasiquote
, scm_makacro
, scm_m_quasiquote
);
3549 scm_make_synt (s_undefine
, scm_makacro
, scm_m_undefine
);
3550 scm_make_synt (s_delay
, scm_makacro
, scm_m_delay
);
3553 scm_top_level_lookup_closure_var
=
3554 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3555 scm_can_use_top_level_lookup_closure_var
= 1;
3557 scm_i_and
= scm_make_synt ("and", scm_makmmacro
, scm_m_and
);
3558 scm_i_begin
= scm_make_synt ("begin", scm_makmmacro
, scm_m_begin
);
3559 scm_i_case
= scm_make_synt ("case", scm_makmmacro
, scm_m_case
);
3560 scm_i_cond
= scm_make_synt ("cond", scm_makmmacro
, scm_m_cond
);
3561 scm_i_define
= scm_make_synt ("define", scm_makmmacro
, scm_m_define
);
3562 scm_i_do
= scm_make_synt ("do", scm_makmmacro
, scm_m_do
);
3563 scm_i_if
= scm_make_synt ("if", scm_makmmacro
, scm_m_if
);
3564 scm_i_lambda
= scm_make_synt ("lambda", scm_makmmacro
, scm_m_lambda
);
3565 scm_i_let
= scm_make_synt ("let", scm_makmmacro
, scm_m_let
);
3566 scm_i_letrec
= scm_make_synt ("letrec", scm_makmmacro
, scm_m_letrec
);
3567 scm_i_letstar
= scm_make_synt ("let*", scm_makmmacro
, scm_m_letstar
);
3568 scm_i_or
= scm_make_synt ("or", scm_makmmacro
, scm_m_or
);
3569 scm_i_quote
= scm_make_synt ("quote", scm_makmmacro
, scm_m_quote
);
3570 scm_i_set
= scm_make_synt ("set!", scm_makmmacro
, scm_m_set
);
3571 scm_i_atapply
= scm_make_synt ("@apply", scm_makmmacro
, scm_m_apply
);
3572 scm_i_atcall_cc
= scm_make_synt ("@call-with-current-continuation",
3573 scm_makmmacro
, scm_m_cont
);
3575 #ifdef DEBUG_EXTENSIONS
3576 scm_i_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3577 scm_i_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3578 scm_i_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3579 scm_i_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3584 scm_add_feature ("delay");