1 /* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
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 SCM (*scm_memoize_method
) (SCM
, SCM
);
101 /* The evaluator contains a plethora of EVAL symbols.
102 * This is an attempt at explanation.
104 * The following macros should be used in code which is read twice
105 * (where the choice of evaluator is hard soldered):
107 * SCM_CEVAL is the symbol used within one evaluator to call itself.
108 * Originally, it is defined to scm_ceval, but is redefined to
109 * scm_deval during the second pass.
111 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
112 * only side effects of expressions matter. All immediates are
115 * SCM_EVALIM is used when it is known that the expression is an
116 * immediate. (This macro never calls an evaluator.)
118 * EVALCAR evaluates the car of an expression.
120 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
121 * car is a lisp cell.
123 * The following macros should be used in code which is read once
124 * (where the choice of evaluator is dynamic):
126 * SCM_XEVAL takes care of immediates without calling an evaluator. It
127 * then calls scm_ceval *or* scm_deval, depending on the debugging
130 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
131 * depending on the debugging mode.
133 * The main motivation for keeping this plethora is efficiency
134 * together with maintainability (=> locality of code).
137 #define SCM_CEVAL scm_ceval
138 #define SIDEVAL(x, env) if (SCM_NIMP(x)) SCM_CEVAL((x), (env))
140 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
141 ? *scm_lookupcar(x, env, 1) \
142 : SCM_CEVAL(SCM_CAR(x), env))
144 #define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
145 ? (SCM_IMP(SCM_CAR(x)) \
146 ? SCM_EVALIM(SCM_CAR(x), env) \
147 : SCM_GLOC_VAL(SCM_CAR(x))) \
148 : EVALCELLCAR(x, env))
150 #define EXTEND_ENV SCM_EXTEND_ENV
152 #ifdef MEMOIZE_LOCALS
155 scm_ilookup (iloc
, env
)
159 register int ir
= SCM_IFRAME (iloc
);
160 register SCM er
= env
;
161 for (; 0 != ir
; --ir
)
164 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
166 if (SCM_ICDRP (iloc
))
167 return SCM_CDRLOC (er
);
168 return SCM_CARLOC (SCM_CDR (er
));
174 /* The Lookup Car Race
177 Memoization of variables and special forms is done while executing
178 the code for the first time. As long as there is only one thread
179 everything is fine, but as soon as two threads execute the same
180 code concurrently `for the first time' they can come into conflict.
182 This memoization includes rewriting variable references into more
183 efficient forms and expanding macros. Furthermore, macro expansion
184 includes `compiling' special forms like `let', `cond', etc. into
185 tree-code instructions.
187 There shouldn't normally be a problem with memoizing local and
188 global variable references (into ilocs and glocs), because all
189 threads will mutate the code in *exactly* the same way and (if I
190 read the C code correctly) it is not possible to observe a half-way
191 mutated cons cell. The lookup procedure can handle this
192 transparently without any critical sections.
194 It is different with macro expansion, because macro expansion
195 happens outside of the lookup procedure and can't be
196 undone. Therefore it can't cope with it. It has to indicate
197 failure when it detects a lost race and hope that the caller can
198 handle it. Luckily, it turns out that this is the case.
200 An example to illustrate this: Suppose that the follwing form will
201 be memoized concurrently by two threads
205 Let's first examine the lookup of X in the body. The first thread
206 decides that it has to find the symbol "x" in the environment and
207 starts to scan it. Then the other thread takes over and actually
208 overtakes the first. It looks up "x" and substitutes an
209 appropriate iloc for it. Now the first thread continues and
210 completes its lookup. It comes to exactly the same conclusions as
211 the second one and could - without much ado - just overwrite the
212 iloc with the same iloc.
214 But let's see what will happen when the race occurs while looking
215 up the symbol "let" at the start of the form. It could happen that
216 the second thread interrupts the lookup of the first thread and not
217 only substitutes a gloc for it but goes right ahead and replaces it
218 with the compiled form (#@let* (x 12) x). Now, when the first
219 thread completes its lookup, it would replace the #@let* with a
220 gloc pointing to the "let" binding, effectively reverting the form
221 to (let (x 12) x). This is wrong. It has to detect that it has
222 lost the race and the evaluator has to reconsider the changed form
225 This race condition could be resolved with some kind of traffic
226 light (like mutexes) around scm_lookupcar, but I think that it is
227 best to avoid them in this case. They would serialize memoization
228 completely and because lookup involves calling arbitrary Scheme
229 code (via the lookup-thunk), threads could be blocked for an
230 arbitrary amount of time or even deadlock. But with the current
231 solution a lot of unnecessary work is potentially done. */
233 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
234 return NULL to indicate a failed lookup due to some race conditions
235 between threads. This only happens when VLOC is the first cell of
236 a special form that will eventually be memoized (like `let', etc.)
237 In that case the whole lookup is bogus and the caller has to
238 reconsider the complete special form.
240 SCM_LOOKUPCAR is still there, of course. It just calls
241 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
242 should only be called when it is known that VLOC is not the first
243 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
244 for NULL. I think I've found the only places where this
247 #endif /* USE_THREADS */
249 /* scm_lookupcar returns a pointer to this when a variable could not
250 be found and it should not throw an error. Never assign to this.
252 static scm_cell undef_cell
= { SCM_UNDEFINED
, SCM_UNDEFINED
};
256 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
259 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
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 SCM_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,...) */
342 scm_misc_error (NULL
,
344 ? "Unbound variable: %S"
345 : "Damaged environment: %S",
346 scm_listify (var
, SCM_UNDEFINED
));
348 return SCM_CDRLOC (&undef_cell
);
352 if (SCM_CAR (vloc
) != var2
)
354 /* Some other thread has changed the very cell we are working
355 on. In effect, it must have done our job or messed it up
358 var
= SCM_CAR (vloc
);
360 return SCM_GLOC_VAL_LOC (var
);
361 #ifdef MEMOIZE_LOCALS
362 if ((var
& 127) == (127 & SCM_ILOC00
))
363 return scm_ilookup (var
, genv
);
365 /* We can't cope with anything else than glocs and ilocs. When
366 a special form has been memoized (i.e. `let' into `#@let') we
367 return NULL and expect the calling function to do the right
368 thing. For the evaluator, this means going back and redoing
369 the dispatch on the car of the form. */
372 #endif /* USE_THREADS */
374 SCM_SETCAR (vloc
, var
+ 1);
375 /* Except wait...what if the var is not a vcell,
376 * but syntax or something.... */
377 return SCM_CDRLOC (var
);
382 scm_lookupcar (vloc
, genv
, check
)
387 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
394 #define unmemocar scm_unmemocar
397 scm_unmemocar (form
, env
)
401 #ifdef DEBUG_EXTENSIONS
410 SCM_SETCAR (form
, SCM_CAR (c
- 1));
411 #ifdef MEMOIZE_LOCALS
412 #ifdef DEBUG_EXTENSIONS
413 else if (SCM_ILOCP (c
))
415 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
417 env
= SCM_CAR (SCM_CAR (env
));
418 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
420 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
429 scm_eval_car (pair
, env
)
433 return SCM_XEVALCAR (pair
, env
);
438 * The following rewrite expressions and
439 * some memoized forms have different syntax
442 const char scm_s_expression
[] = "missing or extra expression";
443 const char scm_s_test
[] = "bad test";
444 const char scm_s_body
[] = "bad body";
445 const char scm_s_bindings
[] = "bad bindings";
446 const char scm_s_variable
[] = "bad variable";
447 const char scm_s_clauses
[] = "bad or missing clauses";
448 const char scm_s_formals
[] = "bad formals";
450 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
451 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
455 #ifdef DEBUG_EXTENSIONS
456 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
460 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
464 static void bodycheck
SCM_P ((SCM xorig
, SCM
*bodyloc
, const char *what
));
467 bodycheck (xorig
, bodyloc
, what
)
472 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
475 /* Check that the body denoted by XORIG is valid and rewrite it into
476 its internal form. The internal form of a body is just the body
477 itself, but prefixed with an ISYM that denotes to what kind of
478 outer construct this body belongs. A lambda body starts with
479 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
480 etc. The one exception is a body that belongs to a letrec that has
481 been formed by rewriting internal defines: it starts with
484 /* XXX - Besides controlling the rewriting of internal defines, the
485 additional ISYM could be used for improved error messages.
486 This is not done yet. */
489 scm_m_body (op
, xorig
, what
)
494 ASRTSYNTAX (scm_ilength (xorig
) >= 1, scm_s_expression
);
496 /* Don't add another ISYM if one is present already. */
497 if (SCM_ISYMP (SCM_CAR (xorig
)))
500 /* Retain possible doc string. */
501 if (SCM_IMP (SCM_CAR(xorig
)) || SCM_NCONSP (SCM_CAR (xorig
)))
503 if (SCM_NNULLP (SCM_CDR(xorig
)))
504 return scm_cons (SCM_CAR (xorig
),
505 scm_m_body (op
, SCM_CDR(xorig
), what
));
509 return scm_cons2 (op
, SCM_CAR (xorig
), SCM_CDR(xorig
));
512 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
513 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
516 scm_m_quote (xorig
, env
)
520 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
522 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
523 xorig
, scm_s_expression
, s_quote
);
524 return scm_cons (SCM_IM_QUOTE
, x
);
529 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
530 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
533 scm_m_begin (xorig
, env
)
537 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
538 xorig
, scm_s_expression
, s_begin
);
539 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
542 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
543 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
546 scm_m_if (xorig
, env
)
550 int len
= scm_ilength (SCM_CDR (xorig
));
551 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
552 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
556 /* Will go into the RnRS module when Guile is factorized.
557 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
558 const char scm_s_set_x
[] = "set!";
559 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
562 scm_m_set_x (xorig
, env
)
566 SCM x
= SCM_CDR (xorig
);
567 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
568 SCM_ASSYNT (SCM_NIMP (SCM_CAR (x
)) && SCM_SYMBOLP (SCM_CAR (x
)),
569 xorig
, scm_s_variable
, scm_s_set_x
);
570 return scm_cons (SCM_IM_SET_X
, x
);
577 scm_m_vref (xorig
, env
)
581 SCM x
= SCM_CDR (xorig
);
582 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
583 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
585 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
586 scm_misc_error (NULL
,
588 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
590 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
591 xorig
, scm_s_variable
, s_vref
);
592 return scm_cons (IM_VREF
, x
);
598 scm_m_vset (xorig
, env
)
602 SCM x
= SCM_CDR (xorig
);
603 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
604 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
605 || UDSCM_VARIABLEP (SCM_CAR (x
))),
606 xorig
, scm_s_variable
, s_vset
);
607 return scm_cons (IM_VSET
, x
);
612 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
613 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
616 scm_m_and (xorig
, env
)
620 int len
= scm_ilength (SCM_CDR (xorig
));
621 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
623 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
628 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
629 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
632 scm_m_or (xorig
, env
)
636 int len
= scm_ilength (SCM_CDR (xorig
));
637 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
639 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
645 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
646 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
649 scm_m_case (xorig
, env
)
653 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
654 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
655 while (SCM_NIMP (x
= SCM_CDR (x
)))
658 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
659 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
660 || scm_sym_else
== SCM_CAR (proc
),
661 xorig
, scm_s_clauses
, s_case
);
663 return scm_cons (SCM_IM_CASE
, cdrx
);
667 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
668 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
672 scm_m_cond (xorig
, env
)
676 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
677 int len
= scm_ilength (x
);
678 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
682 len
= scm_ilength (arg1
);
683 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
684 if (scm_sym_else
== SCM_CAR (arg1
))
686 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
687 xorig
, "bad ELSE clause", s_cond
);
688 SCM_SETCAR (arg1
, SCM_BOOL_T
);
690 if (len
>= 2 && scm_sym_arrow
== SCM_CAR (SCM_CDR (arg1
)))
691 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
692 xorig
, "bad recipient", s_cond
);
695 return scm_cons (SCM_IM_COND
, cdrx
);
698 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
699 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
702 scm_m_lambda (xorig
, env
)
706 SCM proc
, x
= SCM_CDR (xorig
);
707 if (scm_ilength (x
) < 2)
710 if (SCM_NULLP (proc
))
712 if (SCM_IM_LET
== proc
) /* named let */
716 if (SCM_SYMBOLP (proc
))
718 if (SCM_NCONSP (proc
))
720 while (SCM_NIMP (proc
))
722 if (SCM_NCONSP (proc
))
724 if (!SCM_SYMBOLP (proc
))
729 if (!(SCM_NIMP (SCM_CAR (proc
)) && SCM_SYMBOLP (SCM_CAR (proc
))))
731 proc
= SCM_CDR (proc
);
733 if (SCM_NNULLP (proc
))
736 scm_wta (xorig
, scm_s_formals
, s_lambda
);
740 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
741 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
744 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
745 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
749 scm_m_letstar (xorig
, env
)
753 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
754 int len
= scm_ilength (x
);
755 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
757 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
758 while (SCM_NIMP (proc
))
760 arg1
= SCM_CAR (proc
);
761 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
762 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
763 xorig
, scm_s_variable
, s_letstar
);
764 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
765 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
766 proc
= SCM_CDR (proc
);
768 x
= scm_cons (vars
, SCM_CDR (x
));
770 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
771 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
774 /* DO gets the most radically altered syntax
775 (do ((<var1> <init1> <step1>)
781 (do_mem (varn ... var2 var1)
782 (<init1> <init2> ... <initn>)
785 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
788 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
789 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
792 scm_m_do (xorig
, env
)
796 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
797 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
798 SCM
*initloc
= &inits
, *steploc
= &steps
;
799 int len
= scm_ilength (x
);
800 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
802 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
803 while (SCM_NIMP(proc
))
805 arg1
= SCM_CAR (proc
);
806 len
= scm_ilength (arg1
);
807 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
808 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
809 xorig
, scm_s_variable
, "do");
810 /* vars reversed here, inits and steps reversed at evaluation */
811 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
812 arg1
= SCM_CDR (arg1
);
813 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
814 initloc
= SCM_CDRLOC (*initloc
);
815 arg1
= SCM_CDR (arg1
);
816 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
817 steploc
= SCM_CDRLOC (*steploc
);
818 proc
= SCM_CDR (proc
);
821 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
822 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
823 x
= scm_cons2 (vars
, inits
, x
);
824 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
825 return scm_cons (SCM_IM_DO
, x
);
828 /* evalcar is small version of inline EVALCAR when we don't care about
831 #define evalcar scm_eval_car
834 static SCM iqq
SCM_P ((SCM form
, SCM env
, int depth
));
836 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
837 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
840 scm_m_quasiquote (xorig
, env
)
844 SCM x
= SCM_CDR (xorig
);
845 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
846 return iqq (SCM_CAR (x
), env
, 1);
851 iqq (form
, env
, depth
)
860 if (SCM_VECTORP (form
))
862 long i
= SCM_LENGTH (form
);
863 SCM
*data
= SCM_VELTS (form
);
866 tmp
= scm_cons (data
[i
], tmp
);
867 return scm_vector (iqq (tmp
, env
, depth
));
869 if (SCM_NCONSP(form
))
871 tmp
= SCM_CAR (form
);
872 if (scm_sym_quasiquote
== tmp
)
877 if (scm_sym_unquote
== tmp
)
881 form
= SCM_CDR (form
);
882 SCM_ASSERT (SCM_NIMP (form
) && SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
883 form
, SCM_ARG1
, s_quasiquote
);
885 return evalcar (form
, env
);
886 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
888 if (SCM_NIMP (tmp
) && (scm_sym_uq_splicing
== SCM_CAR (tmp
)))
892 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
894 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
897 /* Here are acros which return values rather than code. */
899 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
900 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
903 scm_m_delay (xorig
, env
)
907 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
908 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
912 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
913 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
916 scm_m_define (x
, env
)
922 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
923 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
926 while (SCM_NIMP (proc
) && SCM_CONSP (proc
))
927 { /* nested define syntax */
928 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
929 proc
= SCM_CAR (proc
);
931 SCM_ASSYNT (SCM_NIMP (proc
) && SCM_SYMBOLP (proc
),
932 arg1
, scm_s_variable
, s_define
);
933 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
934 if (SCM_TOP_LEVEL (env
))
936 x
= evalcar (x
, env
);
937 #ifdef DEBUG_EXTENSIONS
938 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
942 if (SCM_CLOSUREP (arg1
)
943 /* Only the first definition determines the name. */
944 && scm_procedure_property (arg1
, scm_sym_name
) == SCM_BOOL_F
)
945 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
946 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
947 && SCM_CDR (arg1
) != arg1
)
949 arg1
= SCM_CDR (arg1
);
954 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
957 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
958 && (SCM_CDR (arg1
) != x
))
959 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
962 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
963 scm_warn ("redefining ", SCM_CHARS (proc
));
965 SCM_SETCDR (arg1
, x
);
967 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
969 return SCM_UNSPECIFIED
;
972 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
978 scm_m_letrec1 (op
, imm
, xorig
, env
)
984 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
985 char *what
= SCM_CHARS (SCM_CAR (xorig
));
986 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
987 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
990 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
993 /* vars scm_list reversed here, inits reversed at evaluation */
994 arg1
= SCM_CAR (proc
);
995 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
996 ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
998 vars
= scm_cons (SCM_CAR (arg1
), vars
);
999 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1000 initloc
= SCM_CDRLOC (*initloc
);
1002 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
1004 return scm_cons2 (op
, vars
,
1005 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
1008 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
1009 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1012 scm_m_letrec (xorig
, env
)
1016 SCM x
= SCM_CDR (xorig
);
1017 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
1019 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
1020 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
1021 scm_m_body (SCM_IM_LETREC
,
1026 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
1029 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
1030 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1033 scm_m_let (xorig
, env
)
1037 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
1038 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
1039 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
1041 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1043 if (SCM_NULLP (proc
)
1044 || (SCM_NIMP (proc
) && SCM_CONSP (proc
)
1045 && SCM_NIMP (SCM_CAR (proc
))
1046 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
1048 /* null or single binding, let* is faster */
1049 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
1050 scm_m_body (SCM_IM_LET
,
1056 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
1057 if (SCM_CONSP (proc
))
1059 /* plain let, proc is <bindings> */
1060 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1063 if (!SCM_SYMBOLP (proc
))
1064 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1065 name
= proc
; /* named let, build equiv letrec */
1067 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1068 proc
= SCM_CAR (x
); /* bindings list */
1069 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1070 while (SCM_NIMP (proc
))
1071 { /* vars and inits both in order */
1072 arg1
= SCM_CAR (proc
);
1073 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1074 SCM_ASSYNT (SCM_NIMP (SCM_CAR (arg1
)) && SCM_SYMBOLP (SCM_CAR (arg1
)),
1075 xorig
, scm_s_variable
, s_let
);
1076 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1077 varloc
= SCM_CDRLOC (*varloc
);
1078 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1079 initloc
= SCM_CDRLOC (*initloc
);
1080 proc
= SCM_CDR (proc
);
1083 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1084 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1085 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1087 scm_acons (name
, inits
, SCM_EOL
));
1088 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1092 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1093 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1094 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1097 scm_m_apply (xorig
, env
)
1101 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1102 xorig
, scm_s_expression
, s_atapply
);
1103 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1107 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1108 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1112 scm_m_cont (xorig
, env
)
1116 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1117 xorig
, scm_s_expression
, s_atcall_cc
);
1118 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1121 /* Multi-language support */
1126 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1129 scm_m_nil_cond (SCM xorig
, SCM env
)
1131 int len
= scm_ilength (SCM_CDR (xorig
));
1132 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1133 scm_s_expression
, "nil-cond");
1134 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1137 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1140 scm_m_nil_ify (SCM xorig
, SCM env
)
1142 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1143 xorig
, scm_s_expression
, "nil-ify");
1144 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1147 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1150 scm_m_t_ify (SCM xorig
, SCM env
)
1152 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1153 xorig
, scm_s_expression
, "t-ify");
1154 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1157 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1160 scm_m_0_cond (SCM xorig
, SCM env
)
1162 int len
= scm_ilength (SCM_CDR (xorig
));
1163 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1164 scm_s_expression
, "0-cond");
1165 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1168 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1171 scm_m_0_ify (SCM xorig
, SCM env
)
1173 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1174 xorig
, scm_s_expression
, "0-ify");
1175 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1178 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1181 scm_m_1_ify (SCM xorig
, SCM env
)
1183 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1184 xorig
, scm_s_expression
, "1-ify");
1185 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1188 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1191 scm_m_atfop (SCM xorig
, SCM env
)
1193 SCM x
= SCM_CDR (xorig
), vcell
;
1194 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1195 vcell
= scm_symbol_fref (SCM_CAR (x
));
1196 SCM_ASSYNT (SCM_NIMP (vcell
) && SCM_CONSP (vcell
), x
,
1197 "Symbol's function definition is void", NULL
);
1198 SCM_SETCAR (x
, vcell
+ 1);
1202 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1205 scm_m_atbind (SCM xorig
, SCM env
)
1207 SCM x
= SCM_CDR (xorig
);
1208 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1214 while (SCM_NIMP (SCM_CDR (env
)))
1215 env
= SCM_CDR (env
);
1216 env
= SCM_CAR (env
);
1217 if (SCM_CONSP (env
))
1222 while (SCM_NIMP (x
))
1224 SCM_SETCAR (x
, scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
) + 1);
1227 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1231 scm_m_expand_body (SCM xorig
, SCM env
)
1233 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1234 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1236 while (SCM_NIMP (x
))
1239 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1241 if (SCM_IMP (SCM_CAR (form
)))
1243 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1246 form
= scm_macroexp (scm_cons_source (form
,
1251 if (SCM_IM_DEFINE
== SCM_CAR (form
))
1253 defs
= scm_cons (SCM_CDR (form
), defs
);
1256 else if (SCM_NIMP(defs
))
1260 else if (SCM_IM_BEGIN
== SCM_CAR (form
))
1262 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1266 x
= scm_cons (form
, SCM_CDR(x
));
1271 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1272 if (SCM_NIMP (defs
))
1274 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1276 scm_cons2 (scm_sym_define
, defs
, x
),
1282 SCM_SETCAR (xorig
, SCM_CAR (x
));
1283 SCM_SETCDR (xorig
, SCM_CDR (x
));
1290 scm_macroexp (SCM x
, SCM env
)
1294 /* Don't bother to produce error messages here. We get them when we
1295 eventually execute the code for real. */
1298 if (SCM_IMP (SCM_CAR (x
)) || !SCM_SYMBOLP (SCM_CAR (x
)))
1303 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1304 if (proc_ptr
== NULL
)
1306 /* We have lost the race. */
1312 proc
= *scm_lookupcar (x
, env
, 0);
1315 /* Only handle memoizing macros. `Acros' and `macros' are really
1316 special forms and should not be evaluated here. */
1319 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1320 || (int) (SCM_CAR (proc
) >> 16) != 2)
1324 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1326 if (scm_ilength (res
) <= 0)
1327 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1330 SCM_SETCAR (x
, SCM_CAR (res
));
1331 SCM_SETCDR (x
, SCM_CDR (res
));
1337 /* scm_unmemocopy takes a memoized expression together with its
1338 * environment and rewrites it to its original form. Thus, it is the
1339 * inversion of the rewrite rules above. The procedure is not
1340 * optimized for speed. It's used in scm_iprin1 when printing the
1341 * code of a closure, in scm_procedure_source, in display_frame when
1342 * generating the source for a stackframe in a backtrace, and in
1343 * display_expression.
1346 /* We should introduce an anti-macro interface so that it is possible
1347 * to plug in transformers in both directions from other compilation
1348 * units. unmemocopy could then dispatch to anti-macro transformers.
1349 * (Those transformers could perhaps be written in slightly more
1350 * readable style... :)
1353 static SCM unmemocopy
SCM_P ((SCM x
, SCM env
));
1361 #ifdef DEBUG_EXTENSIONS
1364 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1366 #ifdef DEBUG_EXTENSIONS
1367 p
= scm_whash_lookup (scm_source_whash
, x
);
1369 switch (SCM_TYP7 (x
))
1371 case (127 & SCM_IM_AND
):
1372 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1374 case (127 & SCM_IM_BEGIN
):
1375 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1377 case (127 & SCM_IM_CASE
):
1378 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1380 case (127 & SCM_IM_COND
):
1381 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1383 case (127 & SCM_IM_DO
):
1384 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1386 case (127 & SCM_IM_IF
):
1387 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1389 case (127 & SCM_IM_LET
):
1390 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1392 case (127 & SCM_IM_LETREC
):
1395 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1399 f
= v
= SCM_CAR (x
);
1401 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1403 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1404 SCM_CAR (ls
) == scm_sym_letrec
? z
: env
));
1407 s
= SCM_CAR (ls
) == scm_sym_do
1408 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1410 /* build transformed binding list */
1414 z
= scm_acons (SCM_CAR (v
),
1415 scm_cons (SCM_CAR (e
),
1416 SCM_CAR (s
) == SCM_CAR (v
)
1418 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1424 while (SCM_NIMP (v
));
1425 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1427 if (SCM_CAR (ls
) == scm_sym_do
)
1431 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1434 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1435 /* body forms are now to be found in SCM_CDR (x)
1436 (this is how *real* code look like! :) */
1440 case (127 & SCM_IM_LETSTAR
):
1448 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1451 y
= z
= scm_acons (SCM_CAR (b
),
1453 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1455 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1456 b
= SCM_CDR (SCM_CDR (b
));
1459 SCM_SETCDR (y
, SCM_EOL
);
1460 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1465 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1467 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1470 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1471 b
= SCM_CDR (SCM_CDR (b
));
1473 while (SCM_NIMP (b
));
1474 SCM_SETCDR (z
, SCM_EOL
);
1476 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1479 case (127 & SCM_IM_OR
):
1480 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1482 case (127 & SCM_IM_LAMBDA
):
1484 ls
= scm_cons (scm_sym_lambda
,
1485 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1486 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1488 case (127 & SCM_IM_QUOTE
):
1489 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1491 case (127 & SCM_IM_SET_X
):
1492 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1494 case (127 & SCM_IM_DEFINE
):
1498 ls
= scm_cons (scm_sym_define
,
1499 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1500 if (SCM_NNULLP (env
))
1501 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1504 case (127 & SCM_MAKISYM (0)):
1508 switch (SCM_ISYMNUM (z
))
1510 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1511 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1513 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1514 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1516 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1517 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1521 /* appease the Sun compiler god: */ ;
1525 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1530 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1532 if (SCM_IMP (SCM_CAR (x
)) && SCM_ISYMP (SCM_CAR (x
)))
1533 /* skip body markers */
1535 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1541 #ifdef DEBUG_EXTENSIONS
1542 if (SCM_NFALSEP (p
))
1543 scm_whash_insert (scm_source_whash
, ls
, p
);
1550 scm_unmemocopy (x
, env
)
1554 if (SCM_NNULLP (env
))
1555 /* Make a copy of the lowest frame to protect it from
1556 modifications by SCM_IM_DEFINE */
1557 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1559 return unmemocopy (x
, env
);
1562 #ifndef SCM_RECKLESS
1565 scm_badargsp (formals
, args
)
1569 while (SCM_NIMP (formals
))
1571 if (SCM_NCONSP (formals
))
1575 formals
= SCM_CDR (formals
);
1576 args
= SCM_CDR (args
);
1578 return SCM_NNULLP (args
) ? 1 : 0;
1585 scm_eval_args (l
, env
, proc
)
1590 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1591 while (SCM_NIMP (l
))
1596 else if (SCM_CONSP (l
))
1598 if (SCM_IMP (SCM_CAR (l
)))
1599 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1601 res
= EVALCELLCAR (l
, env
);
1603 else if (SCM_TYP3 (l
) == 1)
1605 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1606 res
= SCM_CAR (l
); /* struct planted in code */
1611 res
= EVALCAR (l
, env
);
1613 *lloc
= scm_cons (res
, SCM_EOL
);
1614 lloc
= SCM_CDRLOC (*lloc
);
1621 scm_wrong_num_args (proc
);
1628 scm_eval_body (SCM code
, SCM env
)
1633 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1635 if (SCM_IMP (SCM_CAR (code
)))
1637 if (SCM_ISYMP (SCM_CAR (code
)))
1639 code
= scm_m_expand_body (code
, env
);
1644 SCM_XEVAL (SCM_CAR (code
), env
);
1647 return SCM_XEVALCAR (code
, env
);
1654 /* SECTION: This code is specific for the debugging support. One
1655 * branch is read when DEVAL isn't defined, the other when DEVAL is
1661 #define SCM_APPLY scm_apply
1662 #define PREP_APPLY(proc, args)
1664 #define RETURN(x) return x;
1665 #ifdef STACK_CHECKING
1666 #ifndef NO_CEVAL_STACK_CHECKING
1667 #define EVAL_STACK_CHECKING
1674 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1676 #define SCM_APPLY scm_dapply
1678 #define PREP_APPLY(p, l) \
1679 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1681 #define ENTER_APPLY \
1683 SCM_SET_ARGSREADY (debug);\
1684 if (CHECK_APPLY && SCM_TRAPS_P)\
1685 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1687 SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
1688 SCM_SET_TRACED_FRAME (debug); \
1689 if (SCM_CHEAPTRAPS_P)\
1691 tmp = scm_make_debugobj (&debug);\
1692 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1696 scm_make_cont (&tmp);\
1697 if (!setjmp (SCM_JMPBUF (tmp)))\
1698 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1703 #define RETURN(e) {proc = (e); goto exit;}
1704 #ifdef STACK_CHECKING
1705 #ifndef EVAL_STACK_CHECKING
1706 #define EVAL_STACK_CHECKING
1710 /* scm_ceval_ptr points to the currently selected evaluator.
1711 * *fixme*: Although efficiency is important here, this state variable
1712 * should probably not be a global. It should be related to the
1717 SCM (*scm_ceval_ptr
) SCM_P ((SCM x
, SCM env
));
1719 /* scm_last_debug_frame contains a pointer to the last debugging
1720 * information stack frame. It is accessed very often from the
1721 * debugging evaluator, so it should probably not be indirectly
1722 * addressed. Better to save and restore it from the current root at
1727 scm_debug_frame
*scm_last_debug_frame
;
1730 /* scm_debug_eframe_size is the number of slots available for pseudo
1731 * stack frames at each real stack frame.
1734 int scm_debug_eframe_size
;
1736 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1740 scm_option scm_eval_opts
[] = {
1741 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1744 scm_option scm_debug_opts
[] = {
1745 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1746 "*Flyweight representation of the stack at traps." },
1747 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1748 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1749 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1750 "Record procedure names at definition." },
1751 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1752 "Display backtrace in anti-chronological order." },
1753 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1754 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1755 { SCM_OPTION_INTEGER
, "frames", 3,
1756 "Maximum number of tail-recursive frames in backtrace." },
1757 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1758 "Maximal number of stored backtrace frames." },
1759 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1760 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1761 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1762 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1765 scm_option scm_evaluator_trap_table
[] = {
1766 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1767 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1768 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1769 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1772 SCM_PROC (s_eval_options_interface
, "eval-options-interface", 0, 1, 0, scm_eval_options_interface
);
1775 scm_eval_options_interface (SCM setting
)
1779 ans
= scm_options (setting
,
1782 s_eval_options_interface
);
1783 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1788 SCM_PROC (s_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps
);
1791 scm_evaluator_traps (setting
)
1796 ans
= scm_options (setting
,
1797 scm_evaluator_trap_table
,
1798 SCM_N_EVALUATOR_TRAPS
,
1800 SCM_RESET_DEBUG_MODE
;
1806 scm_deval_args (l
, env
, proc
, lloc
)
1807 SCM l
, env
, proc
, *lloc
;
1809 SCM
*results
= lloc
, res
;
1810 while (SCM_NIMP (l
))
1815 else if (SCM_CONSP (l
))
1817 if (SCM_IMP (SCM_CAR (l
)))
1818 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1820 res
= EVALCELLCAR (l
, env
);
1822 else if (SCM_TYP3 (l
) == 1)
1824 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1825 res
= SCM_CAR (l
); /* struct planted in code */
1830 res
= EVALCAR (l
, env
);
1832 *lloc
= scm_cons (res
, SCM_EOL
);
1833 lloc
= SCM_CDRLOC (*lloc
);
1840 scm_wrong_num_args (proc
);
1849 /* SECTION: Some local definitions for the evaluator.
1854 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1856 #define CHECK_EQVISH(A,B) ((A) == (B))
1860 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1862 /* SECTION: This is the evaluator. Like any real monster, it has
1863 * three heads. This code is compiled twice.
1895 scm_debug_frame debug
;
1896 scm_debug_info
*debug_info_end
;
1897 debug
.prev
= scm_last_debug_frame
;
1898 debug
.status
= scm_debug_eframe_size
;
1900 * The debug.vect contains twice as much scm_debug_info frames as the
1901 * user has specified with (debug-set! frames <n>).
1903 * Even frames are eval frames, odd frames are apply frames.
1905 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1906 * sizeof (debug
.vect
[0]));
1907 debug
.info
= debug
.vect
;
1908 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1909 scm_last_debug_frame
= &debug
;
1911 #ifdef EVAL_STACK_CHECKING
1912 if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
)
1913 && scm_stack_checking_enabled_p
)
1916 debug
.info
->e
.exp
= x
;
1917 debug
.info
->e
.env
= env
;
1919 scm_report_stack_overflow ();
1926 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1929 SCM_CLEAR_ARGSREADY (debug
);
1930 if (SCM_OVERFLOWP (debug
))
1933 * In theory, this should be the only place where it is necessary to
1934 * check for space in debug.vect since both eval frames and
1935 * available space are even.
1937 * For this to be the case, however, it is necessary that primitive
1938 * special forms which jump back to `loop', `begin' or some similar
1939 * label call PREP_APPLY. A convenient way to do this is to jump to
1940 * `loopnoap' or `cdrxnoap'.
1942 else if (++debug
.info
>= debug_info_end
)
1944 SCM_SET_OVERFLOW (debug
);
1948 debug
.info
->e
.exp
= x
;
1949 debug
.info
->e
.env
= env
;
1950 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1951 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1953 SCM tail
= SCM_TAILRECP (debug
) ? SCM_BOOL_T
: SCM_BOOL_F
;
1954 SCM_SET_TAILREC (debug
);
1955 if (SCM_CHEAPTRAPS_P
)
1956 t
.arg1
= scm_make_debugobj (&debug
);
1959 scm_make_cont (&t
.arg1
);
1960 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1962 x
= SCM_THROW_VALUE (t
.arg1
);
1968 /* This gives the possibility for the debugger to
1969 modify the source expression before evaluation. */
1973 scm_ithrow (scm_sym_enter_frame
,
1974 scm_cons2 (t
.arg1
, tail
,
1975 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1979 #if defined (USE_THREADS) || defined (DEVAL)
1983 switch (SCM_TYP7 (x
))
1985 case scm_tcs_symbols
:
1986 /* Only happens when called at top level.
1988 x
= scm_cons (x
, SCM_UNDEFINED
);
1991 case (127 & SCM_IM_AND
):
1994 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1995 if (SCM_FALSEP (EVALCAR (x
, env
)))
1997 RETURN (SCM_BOOL_F
);
2001 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2004 case (127 & SCM_IM_BEGIN
):
2006 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2012 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2014 if (SCM_IMP (SCM_CAR (x
)))
2016 if (SCM_ISYMP (SCM_CAR (x
)))
2018 x
= scm_m_expand_body (x
, env
);
2023 SCM_CEVAL (SCM_CAR (x
), env
);
2027 carloop
: /* scm_eval car of last form in list */
2028 if (SCM_NCELLP (SCM_CAR (x
)))
2031 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
2034 if (SCM_SYMBOLP (SCM_CAR (x
)))
2037 RETURN (*scm_lookupcar (x
, env
, 1))
2041 goto loop
; /* tail recurse */
2044 case (127 & SCM_IM_CASE
):
2046 t
.arg1
= EVALCAR (x
, env
);
2047 while (SCM_NIMP (x
= SCM_CDR (x
)))
2050 if (scm_sym_else
== SCM_CAR (proc
))
2053 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2056 proc
= SCM_CAR (proc
);
2057 while (SCM_NIMP (proc
))
2059 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2061 x
= SCM_CDR (SCM_CAR (x
));
2062 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2065 proc
= SCM_CDR (proc
);
2068 RETURN (SCM_UNSPECIFIED
)
2071 case (127 & SCM_IM_COND
):
2072 while (SCM_NIMP (x
= SCM_CDR (x
)))
2075 t
.arg1
= EVALCAR (proc
, env
);
2076 if (SCM_NFALSEP (t
.arg1
))
2083 if (scm_sym_arrow
!= SCM_CAR (x
))
2085 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2089 proc
= EVALCAR (proc
, env
);
2090 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2091 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2096 RETURN (SCM_UNSPECIFIED
)
2099 case (127 & SCM_IM_DO
):
2101 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2102 t
.arg1
= SCM_EOL
; /* values */
2103 while (SCM_NIMP (proc
))
2105 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2106 proc
= SCM_CDR (proc
);
2108 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2109 x
= SCM_CDR (SCM_CDR (x
));
2110 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2112 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2114 t
.arg1
= SCM_CAR (proc
); /* body */
2115 SIDEVAL (t
.arg1
, env
);
2117 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2119 proc
= SCM_CDR (proc
))
2120 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2121 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2125 RETURN (SCM_UNSPECIFIED
);
2126 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2130 case (127 & SCM_IM_IF
):
2132 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2134 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2136 RETURN (SCM_UNSPECIFIED
);
2138 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2142 case (127 & SCM_IM_LET
):
2144 proc
= SCM_CAR (SCM_CDR (x
));
2148 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2150 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2151 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2156 case (127 & SCM_IM_LETREC
):
2158 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2164 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2166 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2167 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2171 case (127 & SCM_IM_LETSTAR
):
2176 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2181 t
.arg1
= SCM_CAR (proc
);
2182 proc
= SCM_CDR (proc
);
2183 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2185 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2188 case (127 & SCM_IM_OR
):
2191 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2193 x
= EVALCAR (x
, env
);
2194 if (SCM_NFALSEP (x
))
2200 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2204 case (127 & SCM_IM_LAMBDA
):
2205 RETURN (scm_closure (SCM_CDR (x
), env
));
2208 case (127 & SCM_IM_QUOTE
):
2209 RETURN (SCM_CAR (SCM_CDR (x
)));
2212 case (127 & SCM_IM_SET_X
):
2215 switch (7 & (int) proc
)
2218 t
.lloc
= scm_lookupcar (x
, env
, 1);
2221 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2223 #ifdef MEMOIZE_LOCALS
2225 t
.lloc
= scm_ilookup (proc
, env
);
2230 *t
.lloc
= EVALCAR (x
, env
);
2234 RETURN (SCM_UNSPECIFIED
);
2238 case (127 & SCM_IM_DEFINE
): /* only for internal defines */
2239 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2241 /* new syntactic forms go here. */
2242 case (127 & SCM_MAKISYM (0)):
2244 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2245 switch SCM_ISYMNUM (proc
)
2248 case (SCM_ISYMNUM (IM_VREF
)):
2251 var
= SCM_CAR (SCM_CDR (x
));
2252 RETURN (SCM_CDR(var
));
2254 case (SCM_ISYMNUM (IM_VSET
)):
2255 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2256 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2257 RETURN (SCM_UNSPECIFIED
)
2260 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2262 proc
= EVALCAR (proc
, env
);
2263 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2264 if (SCM_CLOSUREP (proc
))
2267 PREP_APPLY (proc
, SCM_EOL
);
2268 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2269 t
.arg1
= EVALCAR (t
.arg1
, env
);
2271 debug
.info
->a
.args
= t
.arg1
;
2273 #ifndef SCM_RECKLESS
2274 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2278 /* Copy argument list */
2279 if (SCM_IMP (t
.arg1
))
2283 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2284 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2285 && SCM_CONSP (t
.arg1
))
2287 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2291 SCM_SETCDR (tl
, t
.arg1
);
2294 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2295 x
= SCM_CODE (proc
);
2301 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2302 scm_make_cont (&t
.arg1
);
2303 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2306 val
= SCM_THROW_VALUE (t
.arg1
);
2310 proc
= evalcar (proc
, env
);
2311 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2312 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2316 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2317 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2319 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2320 proc
= SCM_CADR (x
); /* unevaluated operands */
2321 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2323 arg2
= *scm_ilookup (proc
, env
);
2324 else if (SCM_NCONSP (proc
))
2326 if (SCM_NCELLP (proc
))
2327 arg2
= SCM_GLOC_VAL (proc
);
2329 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2333 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2334 t
.lloc
= SCM_CDRLOC (arg2
);
2335 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2337 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2338 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2343 /* The type dispatch code is duplicated here
2344 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2345 * cuts down execution time for type dispatch to 50%.
2348 int i
, n
, end
, mask
;
2349 SCM z
= SCM_CDDR (x
);
2350 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2351 proc
= SCM_CADR (z
);
2353 if (SCM_NIMP (proc
))
2355 /* Prepare for linear search */
2358 end
= SCM_LENGTH (proc
);
2362 /* Compute a hash value */
2363 int hashset
= SCM_INUM (proc
);
2365 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2366 proc
= SCM_CADR (z
);
2369 if (SCM_NIMP (t
.arg1
))
2372 i
+= (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2373 [scm_si_hashsets
+ hashset
]);
2374 t
.arg1
= SCM_CDR (t
.arg1
);
2376 while (--j
&& SCM_NIMP (t
.arg1
));
2381 /* Search for match */
2385 z
= SCM_VELTS (proc
)[i
];
2386 t
.arg1
= arg2
; /* list of arguments */
2387 if (SCM_NIMP (t
.arg1
))
2390 /* More arguments than specifiers => CLASS != ENV */
2391 if (scm_class_of (SCM_CAR (t
.arg1
)) != SCM_CAR (z
))
2393 t
.arg1
= SCM_CDR (t
.arg1
);
2396 while (--j
&& SCM_NIMP (t
.arg1
));
2397 /* Fewer arguments than specifiers => CAR != ENV */
2398 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2401 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2403 SCM_CMETHOD_ENV (z
));
2404 x
= SCM_CMETHOD_CODE (z
);
2410 z
= scm_memoize_method (x
, arg2
);
2414 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2416 t
.arg1
= EVALCAR (x
, env
);
2417 RETURN (SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CADR (x
))]);
2419 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2421 t
.arg1
= EVALCAR (x
, env
);
2424 SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CAR (x
))]
2425 = EVALCAR (proc
, env
);
2426 RETURN (SCM_UNSPECIFIED
);
2428 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2430 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2432 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2433 || t
.arg1
== scm_nil
))
2435 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2437 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2443 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2446 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2448 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2452 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2454 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_t
: scm_nil
)
2456 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2458 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2460 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2461 || t
.arg1
== SCM_INUM0
))
2463 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2465 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2471 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2474 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2476 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2480 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2482 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2486 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2489 t
.arg1
= SCM_CAR (x
);
2490 arg2
= SCM_CDAR (env
);
2491 while (SCM_NIMP (arg2
))
2493 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2494 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2495 SCM_SETCAR (arg2
, proc
);
2496 t
.arg1
= SCM_CDR (t
.arg1
);
2497 arg2
= SCM_CDR (arg2
);
2499 t
.arg1
= SCM_CAR (x
);
2500 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2502 arg2
= x
= SCM_CDR (x
);
2503 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2505 SIDEVAL (SCM_CAR (x
), env
);
2508 proc
= EVALCAR (x
, env
);
2510 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2511 arg2
= SCM_CDAR (env
);
2512 while (SCM_NIMP (arg2
))
2514 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2515 t
.arg1
= SCM_CDR (t
.arg1
);
2516 arg2
= SCM_CDR (arg2
);
2528 /* scm_everr (x, env,...) */
2529 scm_misc_error (NULL
,
2530 "Wrong type to apply: %S",
2531 scm_listify (proc
, SCM_UNDEFINED
));
2532 case scm_tc7_vector
:
2535 case scm_tc7_byvect
:
2542 #ifdef HAVE_LONG_LONGS
2543 case scm_tc7_llvect
:
2545 case scm_tc7_string
:
2546 case scm_tc7_substring
:
2548 case scm_tcs_closures
:
2556 #ifdef MEMOIZE_LOCALS
2557 case (127 & SCM_ILOC00
):
2558 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2559 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2560 #ifndef SCM_RECKLESS
2566 #endif /* ifdef MEMOIZE_LOCALS */
2569 case scm_tcs_cons_gloc
:
2570 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2572 /* This is a struct implanted in the code, not a gloc. */
2574 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2575 #ifndef SCM_RECKLESS
2583 case scm_tcs_cons_nimcar
:
2584 if (SCM_SYMBOLP (SCM_CAR (x
)))
2587 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2590 /* we have lost the race, start again. */
2595 proc
= *scm_lookupcar (x
, env
, 1);
2603 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2609 /* Set a flag during macro expansion so that macro
2610 application frames can be deleted from the backtrace. */
2611 SCM_SET_MACROEXP (debug
);
2613 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2614 scm_cons (env
, scm_listofnull
));
2617 SCM_CLEAR_MACROEXP (debug
);
2619 switch ((int) (SCM_CAR (proc
) >> 16))
2622 if (scm_ilength (t
.arg1
) <= 0)
2623 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2625 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2628 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2629 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2630 /* Prevent memoizing result of define macro */
2632 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2633 scm_set_source_properties_x (debug
.info
->e
.exp
,
2634 scm_source_properties (x
));
2638 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2639 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2643 /* Prevent memoizing of debug info expression. */
2644 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2649 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2650 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2654 if (SCM_NIMP (x
= t
.arg1
))
2662 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2663 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2664 #ifndef SCM_RECKLESS
2668 if (SCM_CLOSUREP (proc
))
2670 arg2
= SCM_CAR (SCM_CODE (proc
));
2671 t
.arg1
= SCM_CDR (x
);
2672 while (SCM_NIMP (arg2
))
2674 if (SCM_NCONSP (arg2
))
2676 if (SCM_IMP (t
.arg1
))
2677 goto umwrongnumargs
;
2678 arg2
= SCM_CDR (arg2
);
2679 t
.arg1
= SCM_CDR (t
.arg1
);
2681 if (SCM_NNULLP (t
.arg1
))
2682 goto umwrongnumargs
;
2684 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2685 goto handle_a_macro
;
2691 PREP_APPLY (proc
, SCM_EOL
);
2692 if (SCM_NULLP (SCM_CDR (x
))) {
2695 switch (SCM_TYP7 (proc
))
2696 { /* no arguments given */
2697 case scm_tc7_subr_0
:
2698 RETURN (SCM_SUBRF (proc
) ());
2699 case scm_tc7_subr_1o
:
2700 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2702 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2703 case scm_tc7_rpsubr
:
2704 RETURN (SCM_BOOL_T
);
2706 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2710 proc
= SCM_CCLO_SUBR (proc
);
2712 debug
.info
->a
.proc
= proc
;
2713 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2718 proc
= SCM_PROCEDURE (proc
);
2720 debug
.info
->a
.proc
= proc
;
2723 case scm_tcs_closures
:
2724 x
= SCM_CODE (proc
);
2725 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2727 case scm_tcs_cons_gloc
:
2728 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2730 x
= SCM_ENTITY_PROCEDURE (proc
);
2734 else if (!SCM_I_OPERATORP (proc
))
2739 proc
= (SCM_I_ENTITYP (proc
)
2740 ? SCM_ENTITY_PROCEDURE (proc
)
2741 : SCM_OPERATOR_PROCEDURE (proc
));
2743 debug
.info
->a
.proc
= proc
;
2744 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2746 if (SCM_NIMP (proc
))
2751 case scm_tc7_contin
:
2752 case scm_tc7_subr_1
:
2753 case scm_tc7_subr_2
:
2754 case scm_tc7_subr_2o
:
2756 case scm_tc7_subr_3
:
2757 case scm_tc7_lsubr_2
:
2761 /* scm_everr (x, env,...) */
2762 scm_wrong_num_args (proc
);
2764 /* handle macros here */
2769 /* must handle macros by here */
2774 else if (SCM_CONSP (x
))
2776 if (SCM_IMP (SCM_CAR (x
)))
2777 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2779 t
.arg1
= EVALCELLCAR (x
, env
);
2781 else if (SCM_TYP3 (x
) == 1)
2783 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2784 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2789 t
.arg1
= EVALCAR (x
, env
);
2792 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2799 switch (SCM_TYP7 (proc
))
2800 { /* have one argument in t.arg1 */
2801 case scm_tc7_subr_2o
:
2802 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2803 case scm_tc7_subr_1
:
2804 case scm_tc7_subr_1o
:
2805 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2808 if (SCM_SUBRF (proc
))
2810 if (SCM_INUMP (t
.arg1
))
2812 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2815 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2816 if (SCM_REALP (t
.arg1
))
2818 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2821 if (SCM_BIGP (t
.arg1
))
2823 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2827 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2828 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2831 proc
= (SCM
) SCM_SNAME (proc
);
2833 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2834 while ('c' != *--chrs
)
2836 SCM_ASSERT (SCM_NIMP (t
.arg1
) && SCM_CONSP (t
.arg1
),
2837 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2838 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2842 case scm_tc7_rpsubr
:
2843 RETURN (SCM_BOOL_T
);
2845 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2848 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2850 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2856 proc
= SCM_CCLO_SUBR (proc
);
2858 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2859 debug
.info
->a
.proc
= proc
;
2864 proc
= SCM_PROCEDURE (proc
);
2866 debug
.info
->a
.proc
= proc
;
2869 case scm_tcs_closures
:
2871 x
= SCM_CODE (proc
);
2873 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2875 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2878 case scm_tc7_contin
:
2879 scm_call_continuation (proc
, t
.arg1
);
2880 case scm_tcs_cons_gloc
:
2881 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2883 x
= SCM_ENTITY_PROCEDURE (proc
);
2885 arg2
= debug
.info
->a
.args
;
2887 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2891 else if (!SCM_I_OPERATORP (proc
))
2897 proc
= (SCM_I_ENTITYP (proc
)
2898 ? SCM_ENTITY_PROCEDURE (proc
)
2899 : SCM_OPERATOR_PROCEDURE (proc
));
2901 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2902 debug
.info
->a
.proc
= proc
;
2904 if (SCM_NIMP (proc
))
2909 case scm_tc7_subr_2
:
2910 case scm_tc7_subr_0
:
2911 case scm_tc7_subr_3
:
2912 case scm_tc7_lsubr_2
:
2921 else if (SCM_CONSP (x
))
2923 if (SCM_IMP (SCM_CAR (x
)))
2924 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2926 arg2
= EVALCELLCAR (x
, env
);
2928 else if (SCM_TYP3 (x
) == 1)
2930 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2931 arg2
= SCM_CAR (x
); /* struct planted in code */
2936 arg2
= EVALCAR (x
, env
);
2938 { /* have two or more arguments */
2940 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2943 if (SCM_NULLP (x
)) {
2948 switch (SCM_TYP7 (proc
))
2949 { /* have two arguments */
2950 case scm_tc7_subr_2
:
2951 case scm_tc7_subr_2o
:
2952 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2955 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2957 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2959 case scm_tc7_lsubr_2
:
2960 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2961 case scm_tc7_rpsubr
:
2963 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2968 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2969 scm_cons (proc
, debug
.info
->a
.args
),
2972 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2973 scm_cons2 (proc
, t
.arg1
,
2980 /* case scm_tc7_cclo:
2981 x = scm_cons(arg2, scm_eval_args(x, env));
2984 proc = SCM_CCLO_SUBR(proc);
2988 proc
= SCM_PROCEDURE (proc
);
2990 debug
.info
->a
.proc
= proc
;
2993 case scm_tcs_cons_gloc
:
2994 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2996 x
= SCM_ENTITY_PROCEDURE (proc
);
2998 arg2
= debug
.info
->a
.args
;
3000 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
3004 else if (!SCM_I_OPERATORP (proc
))
3010 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3011 ? SCM_ENTITY_PROCEDURE (proc
)
3012 : SCM_OPERATOR_PROCEDURE (proc
),
3013 scm_cons (proc
, debug
.info
->a
.args
),
3016 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3017 ? SCM_ENTITY_PROCEDURE (proc
)
3018 : SCM_OPERATOR_PROCEDURE (proc
),
3019 scm_cons2 (proc
, t
.arg1
,
3027 case scm_tc7_subr_0
:
3029 case scm_tc7_subr_1o
:
3030 case scm_tc7_subr_1
:
3031 case scm_tc7_subr_3
:
3032 case scm_tc7_contin
:
3036 case scm_tcs_closures
:
3039 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3043 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3044 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
3046 x
= SCM_CODE (proc
);
3051 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3055 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3056 scm_deval_args (x
, env
, proc
,
3057 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3061 switch (SCM_TYP7 (proc
))
3062 { /* have 3 or more arguments */
3064 case scm_tc7_subr_3
:
3065 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3066 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3067 SCM_CADDR (debug
.info
->a
.args
)));
3069 #ifdef BUILTIN_RPASUBR
3070 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3071 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3074 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3075 arg2
= SCM_CDR (arg2
);
3077 while (SCM_NIMP (arg2
));
3079 #endif /* BUILTIN_RPASUBR */
3080 case scm_tc7_rpsubr
:
3081 #ifdef BUILTIN_RPASUBR
3082 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3084 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3087 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3089 arg2
= SCM_CAR (t
.arg1
);
3090 t
.arg1
= SCM_CDR (t
.arg1
);
3092 while (SCM_NIMP (t
.arg1
));
3094 #else /* BUILTIN_RPASUBR */
3095 RETURN (SCM_APPLY (proc
, t
.arg1
,
3097 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3099 #endif /* BUILTIN_RPASUBR */
3100 case scm_tc7_lsubr_2
:
3101 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3102 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3104 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3110 proc
= SCM_PROCEDURE (proc
);
3111 debug
.info
->a
.proc
= proc
;
3113 case scm_tcs_closures
:
3114 SCM_SET_ARGSREADY (debug
);
3115 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3118 x
= SCM_CODE (proc
);
3121 case scm_tc7_subr_3
:
3122 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3123 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3125 #ifdef BUILTIN_RPASUBR
3126 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3129 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3132 while (SCM_NIMP (x
));
3134 #endif /* BUILTIN_RPASUBR */
3135 case scm_tc7_rpsubr
:
3136 #ifdef BUILTIN_RPASUBR
3137 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3141 t
.arg1
= EVALCAR (x
, env
);
3142 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3147 while (SCM_NIMP (x
));
3149 #else /* BUILTIN_RPASUBR */
3150 RETURN (SCM_APPLY (proc
, t
.arg1
,
3152 scm_eval_args (x
, env
, proc
),
3154 #endif /* BUILTIN_RPASUBR */
3155 case scm_tc7_lsubr_2
:
3156 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3158 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3160 scm_eval_args (x
, env
, proc
))));
3166 proc
= SCM_PROCEDURE (proc
);
3168 case scm_tcs_closures
:
3170 SCM_SET_ARGSREADY (debug
);
3172 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3175 scm_eval_args (x
, env
, proc
)),
3177 x
= SCM_CODE (proc
);
3180 case scm_tcs_cons_gloc
:
3181 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3184 arg2
= debug
.info
->a
.args
;
3186 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3188 x
= SCM_ENTITY_PROCEDURE (proc
);
3191 else if (!SCM_I_OPERATORP (proc
))
3195 case scm_tc7_subr_2
:
3196 case scm_tc7_subr_1o
:
3197 case scm_tc7_subr_2o
:
3198 case scm_tc7_subr_0
:
3200 case scm_tc7_subr_1
:
3201 case scm_tc7_contin
:
3209 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3210 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3212 SCM_CLEAR_TRACED_FRAME (debug
);
3213 if (SCM_CHEAPTRAPS_P
)
3214 t
.arg1
= scm_make_debugobj (&debug
);
3217 scm_make_cont (&t
.arg1
);
3218 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3220 proc
= SCM_THROW_VALUE (t
.arg1
);
3224 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3227 scm_last_debug_frame
= debug
.prev
;
3233 /* SECTION: This code is compiled once.
3238 /* This code processes the arguments to apply:
3240 (apply PROC ARG1 ... ARGS)
3242 Given a list (ARG1 ... ARGS), this function conses the ARG1
3243 ... arguments onto the front of ARGS, and returns the resulting
3244 list. Note that ARGS is a list; thus, the argument to this
3245 function is a list whose last element is a list.
3247 Apply calls this function, and applies PROC to the elements of the
3248 result. apply:nconc2last takes care of building the list of
3249 arguments, given (ARG1 ... ARGS).
3251 Rather than do new consing, apply:nconc2last destroys its argument.
3252 On that topic, this code came into my care with the following
3253 beautifully cryptic comment on that topic: "This will only screw
3254 you if you do (scm_apply scm_apply '( ... ))" If you know what
3255 they're referring to, send me a patch to this comment. */
3257 SCM_PROC(s_nconc2last
, "apply:nconc2last", 1, 0, 0, scm_nconc2last
);
3260 scm_nconc2last (lst
)
3264 SCM_ASSERT (scm_ilength (lst
) > 0, lst
, SCM_ARG1
, s_nconc2last
);
3266 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3267 lloc
= SCM_CDRLOC (*lloc
);
3268 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, s_nconc2last
);
3269 *lloc
= SCM_CAR (*lloc
);
3276 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3277 * It is compiled twice.
3283 scm_apply (proc
, arg1
, args
)
3293 scm_dapply (proc
, arg1
, args
)
3301 /* Apply a function to a list of arguments.
3303 This function is exported to the Scheme level as taking two
3304 required arguments and a tail argument, as if it were:
3305 (lambda (proc arg1 . args) ...)
3306 Thus, if you just have a list of arguments to pass to a procedure,
3307 pass the list as ARG1, and '() for ARGS. If you have some fixed
3308 args, pass the first as ARG1, then cons any remaining fixed args
3309 onto the front of your argument list, and pass that as ARGS. */
3312 SCM_APPLY (proc
, arg1
, args
)
3317 #ifdef DEBUG_EXTENSIONS
3319 scm_debug_frame debug
;
3320 scm_debug_info debug_vect_body
;
3321 debug
.prev
= scm_last_debug_frame
;
3322 debug
.status
= SCM_APPLYFRAME
;
3323 debug
.vect
= &debug_vect_body
;
3324 debug
.vect
[0].a
.proc
= proc
;
3325 debug
.vect
[0].a
.args
= SCM_EOL
;
3326 scm_last_debug_frame
= &debug
;
3329 return scm_dapply (proc
, arg1
, args
);
3333 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3335 /* If ARGS is the empty list, then we're calling apply with only two
3336 arguments --- ARG1 is the list of arguments for PROC. Whatever
3337 the case, futz with things so that ARG1 is the first argument to
3338 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3341 Setting the debug apply frame args this way is pretty messy.
3342 Perhaps we should store arg1 and args directly in the frame as
3343 received, and let scm_frame_arguments unpack them, because that's
3344 a relatively rare operation. This works for now; if the Guile
3345 developer archives are still around, see Mikael's post of
3347 if (SCM_NULLP (args
))
3349 if (SCM_NULLP (arg1
))
3351 arg1
= SCM_UNDEFINED
;
3353 debug
.vect
[0].a
.args
= SCM_EOL
;
3359 debug
.vect
[0].a
.args
= arg1
;
3361 args
= SCM_CDR (arg1
);
3362 arg1
= SCM_CAR (arg1
);
3367 /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */
3368 args
= scm_nconc2last (args
);
3370 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3374 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3377 if (SCM_CHEAPTRAPS_P
)
3378 tmp
= scm_make_debugobj (&debug
);
3381 scm_make_cont (&tmp
);
3382 if (setjmp (SCM_JMPBUF (tmp
)))
3385 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3393 switch (SCM_TYP7 (proc
))
3395 case scm_tc7_subr_2o
:
3396 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3397 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3398 case scm_tc7_subr_2
:
3399 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3401 args
= SCM_CAR (args
);
3402 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3403 case scm_tc7_subr_0
:
3404 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3405 RETURN (SCM_SUBRF (proc
) ())
3406 case scm_tc7_subr_1
:
3407 case scm_tc7_subr_1o
:
3408 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3409 RETURN (SCM_SUBRF (proc
) (arg1
))
3411 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3413 if (SCM_SUBRF (proc
))
3415 if (SCM_INUMP (arg1
))
3417 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
3419 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3420 if (SCM_REALP (arg1
))
3422 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
3425 if (SCM_BIGP (arg1
))
3426 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
3429 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3430 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3433 proc
= (SCM
) SCM_SNAME (proc
);
3435 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3436 while ('c' != *--chrs
)
3438 SCM_ASSERT (SCM_NIMP (arg1
) && SCM_CONSP (arg1
),
3439 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3440 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3444 case scm_tc7_subr_3
:
3445 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3448 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3450 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3452 case scm_tc7_lsubr_2
:
3453 SCM_ASRTGO (SCM_NIMP (args
) && SCM_CONSP (args
), wrongnumargs
);
3454 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3456 if (SCM_NULLP (args
))
3457 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3458 while (SCM_NIMP (args
))
3460 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3461 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3462 args
= SCM_CDR (args
);
3465 case scm_tc7_rpsubr
:
3466 if (SCM_NULLP (args
))
3467 RETURN (SCM_BOOL_T
);
3468 while (SCM_NIMP (args
))
3470 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3471 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3472 RETURN (SCM_BOOL_F
);
3473 arg1
= SCM_CAR (args
);
3474 args
= SCM_CDR (args
);
3476 RETURN (SCM_BOOL_T
);
3477 case scm_tcs_closures
:
3479 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3481 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3483 #ifndef SCM_RECKLESS
3484 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3488 /* Copy argument list */
3493 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3494 while (SCM_NIMP (arg1
= SCM_CDR (arg1
))
3495 && SCM_CONSP (arg1
))
3497 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3501 SCM_SETCDR (tl
, arg1
);
3504 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3505 proc
= SCM_CDR (SCM_CODE (proc
));
3508 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3510 if (SCM_IMP (SCM_CAR (proc
)))
3512 if (SCM_ISYMP (SCM_CAR (proc
)))
3514 proc
= scm_m_expand_body (proc
, args
);
3519 SCM_CEVAL (SCM_CAR (proc
), args
);
3522 RETURN (EVALCAR (proc
, args
));
3523 case scm_tc7_contin
:
3524 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3525 scm_call_continuation (proc
, arg1
);
3529 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3531 proc
= SCM_CCLO_SUBR (proc
);
3532 debug
.vect
[0].a
.proc
= proc
;
3533 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3535 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3537 proc
= SCM_CCLO_SUBR (proc
);
3542 proc
= SCM_PROCEDURE (proc
);
3544 debug
.vect
[0].a
.proc
= proc
;
3547 case scm_tcs_cons_gloc
:
3548 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3551 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3553 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3555 RETURN (scm_apply_generic (proc
, args
));
3557 else if (!SCM_I_OPERATORP (proc
))
3562 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3564 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3567 proc
= (SCM_I_ENTITYP (proc
)
3568 ? SCM_ENTITY_PROCEDURE (proc
)
3569 : SCM_OPERATOR_PROCEDURE (proc
));
3571 debug
.vect
[0].a
.proc
= proc
;
3572 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3574 if (SCM_NIMP (proc
))
3580 scm_wrong_num_args (proc
);
3583 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3588 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3589 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3591 SCM_CLEAR_TRACED_FRAME (debug
);
3592 if (SCM_CHEAPTRAPS_P
)
3593 arg1
= scm_make_debugobj (&debug
);
3596 scm_make_cont (&arg1
);
3597 if (setjmp (SCM_JMPBUF (arg1
)))
3599 proc
= SCM_THROW_VALUE (arg1
);
3603 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3606 scm_last_debug_frame
= debug
.prev
;
3612 /* SECTION: The rest of this file is only read once.
3617 /* Typechecking for multi-argument MAP and FOR-EACH.
3619 Verify that each element of the vector ARGV, except for the first,
3620 is a proper list whose length is LEN. Attribute errors to WHO,
3621 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3623 check_map_args (SCM argv
,
3630 SCM
*ve
= SCM_VELTS (argv
);
3633 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3635 int elt_len
= scm_ilength (ve
[i
]);
3640 scm_apply_generic (gf
, scm_cons (proc
, args
));
3642 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3646 scm_out_of_range (who
, ve
[i
]);
3649 scm_remember (&argv
);
3653 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3655 /* Note: Currently, scm_map applies PROC to the argument list(s)
3656 sequentially, starting with the first element(s). This is used in
3657 evalext.c where the Scheme procedure `serial-map', which guarantees
3658 sequential behaviour, is implemented using scm_map. If the
3659 behaviour changes, we need to update `serial-map'.
3663 scm_map (proc
, arg1
, args
)
3671 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3673 if (SCM_NULLP (arg1
))
3675 len
= scm_ilength (arg1
);
3676 SCM_GASSERTn (len
>= 0,
3677 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3678 if (SCM_NULLP (args
))
3680 while (SCM_NIMP (arg1
))
3682 SCM_GASSERT2 (SCM_CONSP (arg1
), g_map
, proc
, arg1
, SCM_ARG2
, s_map
);
3683 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3685 pres
= SCM_CDRLOC (*pres
);
3686 arg1
= SCM_CDR (arg1
);
3690 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3691 ve
= SCM_VELTS (args
);
3692 #ifndef SCM_RECKLESS
3693 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3698 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3700 if (SCM_IMP (ve
[i
]))
3702 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3703 ve
[i
] = SCM_CDR (ve
[i
]);
3705 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3706 pres
= SCM_CDRLOC (*pres
);
3711 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3714 scm_for_each (proc
, arg1
, args
)
3719 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3722 return SCM_UNSPECIFIED
;
3723 len
= scm_ilength (arg1
);
3724 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3725 SCM_ARG2
, s_for_each
);
3728 while SCM_NIMP (arg1
)
3730 SCM_GASSERT2 (SCM_CONSP (arg1
),
3731 g_for_each
, proc
, arg1
, SCM_ARG2
, s_for_each
);
3732 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3733 arg1
= SCM_CDR (arg1
);
3735 return SCM_UNSPECIFIED
;
3737 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3738 ve
= SCM_VELTS (args
);
3739 #ifndef SCM_RECKLESS
3740 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3745 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3748 (ve
[i
]) return SCM_UNSPECIFIED
;
3749 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3750 ve
[i
] = SCM_CDR (ve
[i
]);
3752 scm_apply (proc
, arg1
, SCM_EOL
);
3759 scm_closure (code
, env
)
3765 SCM_SETCODE (z
, code
);
3766 SCM_SETENV (z
, env
);
3771 long scm_tc16_promise
;
3777 SCM_RETURN_NEWSMOB (scm_tc16_promise
, code
);
3782 static int prinprom
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
3785 prinprom (exp
, port
, pstate
)
3788 scm_print_state
*pstate
;
3790 int writingp
= SCM_WRITINGP (pstate
);
3791 scm_puts ("#<promise ", port
);
3792 SCM_SET_WRITINGP (pstate
, 1);
3793 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3794 SCM_SET_WRITINGP (pstate
, writingp
);
3795 scm_putc ('>', port
);
3800 SCM_PROC(s_force
, "force", 1, 0, 0, scm_force
);
3806 SCM_ASSERT (SCM_NIMP(x
) && SCM_TYP16 (x
) == scm_tc16_promise
,
3807 x
, SCM_ARG1
, s_force
);
3808 if (!((1L << 16) & SCM_CAR (x
)))
3810 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3811 if (!((1L << 16) & SCM_CAR (x
)))
3814 SCM_SETCDR (x
, ans
);
3815 SCM_SETOR_CAR (x
, (1L << 16));
3822 SCM_PROC (s_promise_p
, "promise?", 1, 0, 0, scm_promise_p
);
3828 return ((SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
))
3833 SCM_PROC (s_cons_source
, "cons-source", 3, 0, 0, scm_cons_source
);
3836 scm_cons_source (SCM xorig
, SCM x
, SCM y
)
3842 /* Copy source properties possibly associated with xorig. */
3843 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3845 scm_whash_insert (scm_source_whash
, z
, p
);
3849 SCM_PROC (s_copy_tree
, "copy-tree", 1, 0, 0, scm_copy_tree
);
3858 if (SCM_VECTORP (obj
))
3860 scm_sizet i
= SCM_LENGTH (obj
);
3861 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3863 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3866 if (SCM_NCONSP (obj
))
3868 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3869 ans
= tl
= scm_cons_source (obj
,
3870 scm_copy_tree (SCM_CAR (obj
)),
3872 while (SCM_NIMP (obj
= SCM_CDR (obj
)) && SCM_CONSP (obj
))
3874 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3878 SCM_SETCDR (tl
, obj
);
3884 scm_eval_3 (obj
, copyp
, env
)
3889 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3890 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3892 obj
= scm_copy_tree (obj
);
3893 return SCM_XEVAL (obj
, env
);
3896 SCM_PROC(s_eval2
, "eval2", 2, 0, 0, scm_eval2
);
3899 scm_eval2 (obj
, env_thunk
)
3903 return scm_eval_3 (obj
, 1, scm_top_level_env (env_thunk
));
3906 SCM_PROC(s_eval
, "eval", 1, 0, 0, scm_eval
);
3912 return scm_eval_3 (obj
,
3915 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3918 /* SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); */
3924 return scm_eval_3 (obj
,
3927 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3931 /* At this point, scm_deval and scm_dapply are generated.
3934 #ifdef DEBUG_EXTENSIONS
3944 scm_init_opts (scm_evaluator_traps
,
3945 scm_evaluator_trap_table
,
3946 SCM_N_EVALUATOR_TRAPS
);
3947 scm_init_opts (scm_eval_options_interface
,
3949 SCM_N_EVAL_OPTIONS
);
3951 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3952 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3953 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3955 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3956 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3957 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3958 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3959 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3960 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3961 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3963 scm_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3964 SCM_SETCDR (scm_nil
, SCM_CAR (scm_nil
));
3965 scm_nil
= SCM_CAR (scm_nil
);
3966 scm_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3967 SCM_SETCDR (scm_t
, SCM_CAR (scm_t
));
3968 scm_t
= SCM_CAR (scm_t
);
3973 scm_top_level_lookup_closure_var
=
3974 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3975 scm_can_use_top_level_lookup_closure_var
= 1;
3977 #ifdef DEBUG_EXTENSIONS
3978 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3979 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3980 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3981 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3986 scm_add_feature ("delay");