1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000 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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
47 /* This file is read twice in order to produce debugging versions of
48 * scm_ceval and scm_apply. These functions, scm_deval and
49 * scm_dapply, are produced when we define the preprocessor macro
50 * DEVAL. The file is divided into sections which are treated
51 * differently with respect to DEVAL. The heads of these sections are
52 * marked with the string "SECTION:".
56 /* SECTION: This code is compiled once.
61 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
62 #include "scmconfig.h"
64 /* AIX requires this to be the first thing in the file. The #pragma
65 directive is indented so pre-ANSI compilers will ignore it, rather
74 # ifndef alloca /* predefined by HP cc +Olibcalls */
86 #include "continuations.h"
102 SCM (*scm_memoize_method
) (SCM
, SCM
);
106 /* The evaluator contains a plethora of EVAL symbols.
107 * This is an attempt at explanation.
109 * The following macros should be used in code which is read twice
110 * (where the choice of evaluator is hard soldered):
112 * SCM_CEVAL is the symbol used within one evaluator to call itself.
113 * Originally, it is defined to scm_ceval, but is redefined to
114 * scm_deval during the second pass.
116 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
117 * only side effects of expressions matter. All immediates are
120 * SCM_EVALIM is used when it is known that the expression is an
121 * immediate. (This macro never calls an evaluator.)
123 * EVALCAR evaluates the car of an expression.
125 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
126 * car is a lisp cell.
128 * The following macros should be used in code which is read once
129 * (where the choice of evaluator is dynamic):
131 * SCM_XEVAL takes care of immediates without calling an evaluator. It
132 * then calls scm_ceval *or* scm_deval, depending on the debugging
135 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
136 * depending on the debugging mode.
138 * The main motivation for keeping this plethora is efficiency
139 * together with maintainability (=> locality of code).
142 #define SCM_CEVAL scm_ceval
143 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
145 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
146 ? *scm_lookupcar (x, env, 1) \
147 : SCM_CEVAL (SCM_CAR (x), env))
149 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
150 ? (SCM_IMP (SCM_CAR (x)) \
151 ? SCM_EVALIM (SCM_CAR (x), env) \
152 : SCM_GLOC_VAL (SCM_CAR (x))) \
153 : EVALCELLCAR (x, env))
155 #define EXTEND_ENV SCM_EXTEND_ENV
157 #ifdef MEMOIZE_LOCALS
160 scm_ilookup (SCM iloc
, SCM env
)
162 register int ir
= SCM_IFRAME (iloc
);
163 register SCM er
= env
;
164 for (; 0 != ir
; --ir
)
167 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
169 if (SCM_ICDRP (iloc
))
170 return SCM_CDRLOC (er
);
171 return SCM_CARLOC (SCM_CDR (er
));
177 /* The Lookup Car Race
180 Memoization of variables and special forms is done while executing
181 the code for the first time. As long as there is only one thread
182 everything is fine, but as soon as two threads execute the same
183 code concurrently `for the first time' they can come into conflict.
185 This memoization includes rewriting variable references into more
186 efficient forms and expanding macros. Furthermore, macro expansion
187 includes `compiling' special forms like `let', `cond', etc. into
188 tree-code instructions.
190 There shouldn't normally be a problem with memoizing local and
191 global variable references (into ilocs and glocs), because all
192 threads will mutate the code in *exactly* the same way and (if I
193 read the C code correctly) it is not possible to observe a half-way
194 mutated cons cell. The lookup procedure can handle this
195 transparently without any critical sections.
197 It is different with macro expansion, because macro expansion
198 happens outside of the lookup procedure and can't be
199 undone. Therefore it can't cope with it. It has to indicate
200 failure when it detects a lost race and hope that the caller can
201 handle it. Luckily, it turns out that this is the case.
203 An example to illustrate this: Suppose that the follwing form will
204 be memoized concurrently by two threads
208 Let's first examine the lookup of X in the body. The first thread
209 decides that it has to find the symbol "x" in the environment and
210 starts to scan it. Then the other thread takes over and actually
211 overtakes the first. It looks up "x" and substitutes an
212 appropriate iloc for it. Now the first thread continues and
213 completes its lookup. It comes to exactly the same conclusions as
214 the second one and could - without much ado - just overwrite the
215 iloc with the same iloc.
217 But let's see what will happen when the race occurs while looking
218 up the symbol "let" at the start of the form. It could happen that
219 the second thread interrupts the lookup of the first thread and not
220 only substitutes a gloc for it but goes right ahead and replaces it
221 with the compiled form (#@let* (x 12) x). Now, when the first
222 thread completes its lookup, it would replace the #@let* with a
223 gloc pointing to the "let" binding, effectively reverting the form
224 to (let (x 12) x). This is wrong. It has to detect that it has
225 lost the race and the evaluator has to reconsider the changed form
228 This race condition could be resolved with some kind of traffic
229 light (like mutexes) around scm_lookupcar, but I think that it is
230 best to avoid them in this case. They would serialize memoization
231 completely and because lookup involves calling arbitrary Scheme
232 code (via the lookup-thunk), threads could be blocked for an
233 arbitrary amount of time or even deadlock. But with the current
234 solution a lot of unnecessary work is potentially done. */
236 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
237 return NULL to indicate a failed lookup due to some race conditions
238 between threads. This only happens when VLOC is the first cell of
239 a special form that will eventually be memoized (like `let', etc.)
240 In that case the whole lookup is bogus and the caller has to
241 reconsider the complete special form.
243 SCM_LOOKUPCAR is still there, of course. It just calls
244 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
245 should only be called when it is known that VLOC is not the first
246 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
247 for NULL. I think I've found the only places where this
250 #endif /* USE_THREADS */
252 /* scm_lookupcar returns a pointer to this when a variable could not
253 be found and it should not throw an error. Never assign to this.
255 static scm_cell undef_cell
= { SCM_UNDEFINED
, SCM_UNDEFINED
};
257 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
261 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
264 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
268 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
270 register SCM var2
= var
;
272 #ifdef MEMOIZE_LOCALS
273 register SCM iloc
= SCM_ILOC00
;
275 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
277 if (SCM_BOOL_T
== scm_procedure_p (SCM_CAR (env
)))
279 al
= SCM_CARLOC (env
);
280 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
286 #ifdef MEMOIZE_LOCALS
288 if (SCM_CAR (vloc
) != var
)
291 SCM_SETCAR (vloc
, iloc
+ SCM_ICDR
);
293 return SCM_CDRLOC (*al
);
298 al
= SCM_CDRLOC (*al
);
299 if (SCM_CAR (fl
) == var
)
301 #ifdef MEMOIZE_LOCALS
302 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
303 if (SCM_UNBNDP (SCM_CAR (*al
)))
310 if (SCM_CAR (vloc
) != var
)
313 SCM_SETCAR (vloc
, iloc
);
315 return SCM_CARLOC (*al
);
317 #ifdef MEMOIZE_LOCALS
321 #ifdef MEMOIZE_LOCALS
322 iloc
= SCM_ASSCM ((~SCM_IDSTMSK
) & SCM_ASWORD(iloc
+ SCM_IFRINC
));
326 SCM top_thunk
, vcell
;
329 top_thunk
= SCM_CAR(env
); /* env now refers to a top level env thunk */
333 top_thunk
= SCM_BOOL_F
;
334 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
335 if (vcell
== SCM_BOOL_F
)
341 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
345 /* scm_everr (vloc, genv,...) */
349 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
350 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
352 scm_misc_error (NULL
, "Damaged environment: ~S",
353 scm_cons (var
, SCM_EOL
));
356 return SCM_CDRLOC (&undef_cell
);
360 if (SCM_CAR (vloc
) != var2
)
362 /* Some other thread has changed the very cell we are working
363 on. In effect, it must have done our job or messed it up
366 var
= SCM_CAR (vloc
);
367 if (SCM_ITAG3 (var
) == 1)
368 return SCM_GLOC_VAL_LOC (var
);
369 #ifdef MEMOIZE_LOCALS
370 if ((SCM_ASWORD (var
) & 127) == (127 & SCM_ASWORD (SCM_ILOC00
)))
371 return scm_ilookup (var
, genv
);
373 /* We can't cope with anything else than glocs and ilocs. When
374 a special form has been memoized (i.e. `let' into `#@let') we
375 return NULL and expect the calling function to do the right
376 thing. For the evaluator, this means going back and redoing
377 the dispatch on the car of the form. */
380 #endif /* USE_THREADS */
382 SCM_SETCAR (vloc
, var
+ 1);
383 /* Except wait...what if the var is not a vcell,
384 * but syntax or something.... */
385 return SCM_CDRLOC (var
);
390 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
392 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
399 #define unmemocar scm_unmemocar
402 scm_unmemocar (SCM form
, SCM env
)
404 #ifdef DEBUG_EXTENSIONS
412 if (1 == (SCM_ASWORD (c
) & 7))
413 SCM_SETCAR (form
, SCM_CAR (c
- 1));
414 #ifdef MEMOIZE_LOCALS
415 #ifdef DEBUG_EXTENSIONS
416 else if (SCM_ILOCP (c
))
418 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
420 env
= SCM_CAR (SCM_CAR (env
));
421 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
423 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
432 scm_eval_car (SCM pair
, SCM env
)
434 return SCM_XEVALCAR (pair
, env
);
439 * The following rewrite expressions and
440 * some memoized forms have different syntax
443 const char scm_s_expression
[] = "missing or extra expression";
444 const char scm_s_test
[] = "bad test";
445 const char scm_s_body
[] = "bad body";
446 const char scm_s_bindings
[] = "bad bindings";
447 const char scm_s_variable
[] = "bad variable";
448 const char scm_s_clauses
[] = "bad or missing clauses";
449 const char scm_s_formals
[] = "bad formals";
451 SCM scm_sym_dot
, scm_sym_arrow
, scm_sym_else
;
452 SCM scm_sym_unquote
, scm_sym_uq_splicing
, scm_sym_apply
;
456 #ifdef DEBUG_EXTENSIONS
457 SCM scm_sym_enter_frame
, scm_sym_apply_frame
, scm_sym_exit_frame
;
461 #define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
465 static void bodycheck (SCM xorig
, SCM
*bodyloc
, const char *what
);
468 bodycheck (SCM xorig
, SCM
*bodyloc
, const char *what
)
470 ASRTSYNTAX (scm_ilength (*bodyloc
) >= 1, scm_s_expression
);
473 /* Check that the body denoted by XORIG is valid and rewrite it into
474 its internal form. The internal form of a body is just the body
475 itself, but prefixed with an ISYM that denotes to what kind of
476 outer construct this body belongs. A lambda body starts with
477 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
478 etc. The one exception is a body that belongs to a letrec that has
479 been formed by rewriting internal defines: it starts with
482 /* XXX - Besides controlling the rewriting of internal defines, the
483 additional ISYM could be used for improved error messages.
484 This is not done yet. */
487 scm_m_body (SCM op
, SCM xorig
, const char *what
)
489 ASRTSYNTAX (scm_ilength (xorig
) >= 1, scm_s_expression
);
491 /* Don't add another ISYM if one is present already. */
492 if (SCM_ISYMP (SCM_CAR (xorig
)))
495 /* Retain possible doc string. */
496 if (SCM_IMP (SCM_CAR(xorig
)) || SCM_NCONSP (SCM_CAR (xorig
)))
498 if (SCM_NNULLP (SCM_CDR(xorig
)))
499 return scm_cons (SCM_CAR (xorig
),
500 scm_m_body (op
, SCM_CDR(xorig
), what
));
504 return scm_cons2 (op
, SCM_CAR (xorig
), SCM_CDR(xorig
));
507 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
508 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
511 scm_m_quote (SCM xorig
, SCM env
)
513 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
515 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
516 xorig
, scm_s_expression
, s_quote
);
517 return scm_cons (SCM_IM_QUOTE
, x
);
522 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
523 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
526 scm_m_begin (SCM xorig
, SCM env
)
528 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1,
529 xorig
, scm_s_expression
, s_begin
);
530 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
533 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
534 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
537 scm_m_if (SCM xorig
, SCM env
)
539 int len
= scm_ilength (SCM_CDR (xorig
));
540 SCM_ASSYNT (len
>= 2 && len
<= 3, xorig
, scm_s_expression
, "if");
541 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
545 /* Will go into the RnRS module when Guile is factorized.
546 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
547 const char scm_s_set_x
[] = "set!";
548 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
551 scm_m_set_x (SCM xorig
, SCM env
)
553 SCM x
= SCM_CDR (xorig
);
554 SCM_ASSYNT (2 == scm_ilength (x
), xorig
, scm_s_expression
, scm_s_set_x
);
555 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)),
556 xorig
, scm_s_variable
, scm_s_set_x
);
557 return scm_cons (SCM_IM_SET_X
, x
);
564 scm_m_vref (SCM xorig
, SCM env
)
566 SCM x
= SCM_CDR (xorig
);
567 SCM_ASSYNT (1 == scm_ilength (x
), xorig
, scm_s_expression
, s_vref
);
568 if (SCM_NIMP(x
) && UDSCM_VARIABLEP (SCM_CAR (x
)))
570 /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
571 scm_misc_error (NULL
,
573 scm_listify (SCM_CAR (SCM_CDR (x
)), SCM_UNDEFINED
));
575 SCM_ASSYNT (SCM_NIMP(x
) && DEFSCM_VARIABLEP (SCM_CAR (x
)),
576 xorig
, scm_s_variable
, s_vref
);
577 return scm_cons (IM_VREF
, x
);
583 scm_m_vset (SCM xorig
, SCM env
)
585 SCM x
= SCM_CDR (xorig
);
586 SCM_ASSYNT (3 == scm_ilength (x
), xorig
, scm_s_expression
, s_vset
);
587 SCM_ASSYNT ((DEFSCM_VARIABLEP (SCM_CAR (x
))
588 || UDSCM_VARIABLEP (SCM_CAR (x
))),
589 xorig
, scm_s_variable
, s_vset
);
590 return scm_cons (IM_VSET
, x
);
595 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
596 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
599 scm_m_and (SCM xorig
, SCM env
)
601 int len
= scm_ilength (SCM_CDR (xorig
));
602 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_and
);
604 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
609 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
610 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
613 scm_m_or (SCM xorig
, SCM env
)
615 int len
= scm_ilength (SCM_CDR (xorig
));
616 SCM_ASSYNT (len
>= 0, xorig
, scm_s_test
, s_or
);
618 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
624 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
625 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
628 scm_m_case (SCM xorig
, SCM env
)
630 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
631 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_clauses
, s_case
);
632 while (SCM_NIMP (x
= SCM_CDR (x
)))
635 SCM_ASSYNT (scm_ilength (proc
) >= 2, xorig
, scm_s_clauses
, s_case
);
636 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
637 || scm_sym_else
== SCM_CAR (proc
),
638 xorig
, scm_s_clauses
, s_case
);
640 return scm_cons (SCM_IM_CASE
, cdrx
);
644 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
645 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
649 scm_m_cond (SCM xorig
, SCM env
)
651 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
652 int len
= scm_ilength (x
);
653 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
657 len
= scm_ilength (arg1
);
658 SCM_ASSYNT (len
>= 1, xorig
, scm_s_clauses
, s_cond
);
659 if (scm_sym_else
== SCM_CAR (arg1
))
661 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
662 xorig
, "bad ELSE clause", s_cond
);
663 SCM_SETCAR (arg1
, SCM_BOOL_T
);
665 if (len
>= 2 && scm_sym_arrow
== SCM_CAR (SCM_CDR (arg1
)))
666 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
667 xorig
, "bad recipient", s_cond
);
670 return scm_cons (SCM_IM_COND
, cdrx
);
673 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
674 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
677 scm_m_lambda (SCM xorig
, SCM env
)
679 SCM proc
, x
= SCM_CDR (xorig
);
680 if (scm_ilength (x
) < 2)
683 if (SCM_NULLP (proc
))
685 if (SCM_IM_LET
== proc
) /* named let */
689 if (SCM_SYMBOLP (proc
))
691 if (SCM_NCONSP (proc
))
693 while (SCM_NIMP (proc
))
695 if (SCM_NCONSP (proc
))
697 if (!SCM_SYMBOLP (proc
))
702 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
704 proc
= SCM_CDR (proc
);
706 if (SCM_NNULLP (proc
))
709 scm_wta (xorig
, scm_s_formals
, s_lambda
);
713 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
714 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
717 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
718 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
722 scm_m_letstar (SCM xorig
, SCM env
)
724 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
725 int len
= scm_ilength (x
);
726 SCM_ASSYNT (len
>= 2, xorig
, scm_s_body
, s_letstar
);
728 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_letstar
);
729 while (SCM_NIMP (proc
))
731 arg1
= SCM_CAR (proc
);
732 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_letstar
);
733 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, s_letstar
);
734 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
735 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
736 proc
= SCM_CDR (proc
);
738 x
= scm_cons (vars
, SCM_CDR (x
));
740 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
741 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
744 /* DO gets the most radically altered syntax
745 (do ((<var1> <init1> <step1>)
751 (do_mem (varn ... var2 var1)
752 (<init1> <init2> ... <initn>)
755 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
758 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
759 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
762 scm_m_do (SCM xorig
, SCM env
)
764 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
765 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
766 SCM
*initloc
= &inits
, *steploc
= &steps
;
767 int len
= scm_ilength (x
);
768 SCM_ASSYNT (len
>= 2, xorig
, scm_s_test
, "do");
770 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, "do");
771 while (SCM_NIMP(proc
))
773 arg1
= SCM_CAR (proc
);
774 len
= scm_ilength (arg1
);
775 SCM_ASSYNT (2 == len
|| 3 == len
, xorig
, scm_s_bindings
, "do");
776 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), xorig
, scm_s_variable
, "do");
777 /* vars reversed here, inits and steps reversed at evaluation */
778 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
779 arg1
= SCM_CDR (arg1
);
780 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
781 initloc
= SCM_CDRLOC (*initloc
);
782 arg1
= SCM_CDR (arg1
);
783 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
784 steploc
= SCM_CDRLOC (*steploc
);
785 proc
= SCM_CDR (proc
);
788 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, xorig
, scm_s_test
, "do");
789 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
790 x
= scm_cons2 (vars
, inits
, x
);
791 bodycheck (xorig
, SCM_CARLOC (SCM_CDR (SCM_CDR (x
))), "do");
792 return scm_cons (SCM_IM_DO
, x
);
795 /* evalcar is small version of inline EVALCAR when we don't care about
798 #define evalcar scm_eval_car
801 static SCM
iqq (SCM form
, SCM env
, int depth
);
803 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
804 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
807 scm_m_quasiquote (SCM xorig
, SCM env
)
809 SCM x
= SCM_CDR (xorig
);
810 SCM_ASSYNT (scm_ilength (x
) == 1, xorig
, scm_s_expression
, s_quasiquote
);
811 return iqq (SCM_CAR (x
), env
, 1);
816 iqq (SCM form
,SCM env
,int depth
)
822 if (SCM_VECTORP (form
))
824 long i
= SCM_LENGTH (form
);
825 SCM
*data
= SCM_VELTS (form
);
828 tmp
= scm_cons (data
[i
], tmp
);
829 return scm_vector (iqq (tmp
, env
, depth
));
831 if (SCM_NCONSP(form
))
833 tmp
= SCM_CAR (form
);
834 if (scm_sym_quasiquote
== tmp
)
839 if (scm_sym_unquote
== tmp
)
843 form
= SCM_CDR (form
);
844 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
845 form
, SCM_ARG1
, s_quasiquote
);
847 return evalcar (form
, env
);
848 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
850 if (SCM_NIMP (tmp
) && (scm_sym_uq_splicing
== SCM_CAR (tmp
)))
854 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
856 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
859 /* Here are acros which return values rather than code. */
861 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
862 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
865 scm_m_delay (SCM xorig
, SCM env
)
867 SCM_ASSYNT (scm_ilength (xorig
) == 2, xorig
, scm_s_expression
, s_delay
);
868 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
872 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
873 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
876 scm_m_define (SCM x
, SCM env
)
880 /* SCM_ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/
881 SCM_ASSYNT (scm_ilength (x
) >= 2, arg1
, scm_s_expression
, s_define
);
884 while (SCM_CONSP (proc
))
885 { /* nested define syntax */
886 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
887 proc
= SCM_CAR (proc
);
889 SCM_ASSYNT (SCM_SYMBOLP (proc
),
890 arg1
, scm_s_variable
, s_define
);
891 SCM_ASSYNT (1 == scm_ilength (x
), arg1
, scm_s_expression
, s_define
);
892 if (SCM_TOP_LEVEL (env
))
894 x
= evalcar (x
, env
);
895 #ifdef DEBUG_EXTENSIONS
896 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
900 if (SCM_CLOSUREP (arg1
)
901 /* Only the first definition determines the name. */
902 && scm_procedure_property (arg1
, scm_sym_name
) == SCM_BOOL_F
)
903 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
904 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
905 && SCM_CDR (arg1
) != arg1
)
907 arg1
= SCM_CDR (arg1
);
912 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
915 if (SCM_NIMP (SCM_CDR (arg1
)) && ((SCM
) SCM_SNAME (SCM_CDR (arg1
)) == proc
)
916 && (SCM_CDR (arg1
) != x
))
917 scm_warn ("redefining built-in ", SCM_CHARS (proc
));
920 if (5 <= scm_verbose
&& SCM_UNDEFINED
!= SCM_CDR (arg1
))
921 scm_warn ("redefining ", SCM_CHARS (proc
));
923 SCM_SETCDR (arg1
, x
);
925 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
927 return SCM_UNSPECIFIED
;
930 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
936 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
938 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
939 char *what
= SCM_CHARS (SCM_CAR (xorig
));
940 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
941 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
944 ASRTSYNTAX (scm_ilength (proc
) >= 1, scm_s_bindings
);
947 /* vars scm_list reversed here, inits reversed at evaluation */
948 arg1
= SCM_CAR (proc
);
949 ASRTSYNTAX (2 == scm_ilength (arg1
), scm_s_bindings
);
950 ASRTSYNTAX (SCM_SYMBOLP (SCM_CAR (arg1
)),
952 vars
= scm_cons (SCM_CAR (arg1
), vars
);
953 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
954 initloc
= SCM_CDRLOC (*initloc
);
956 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
958 return scm_cons2 (op
, vars
,
959 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
962 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
963 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
966 scm_m_letrec (SCM xorig
, SCM env
)
968 SCM x
= SCM_CDR (xorig
);
969 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_letrec
);
971 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
972 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
973 scm_m_body (SCM_IM_LETREC
,
978 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
981 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
982 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
985 scm_m_let (SCM xorig
, SCM env
)
987 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
988 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
989 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
991 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
995 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
997 /* null or single binding, let* is faster */
998 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
999 scm_m_body (SCM_IM_LET
,
1005 SCM_ASSYNT (SCM_NIMP (proc
), xorig
, scm_s_bindings
, s_let
);
1006 if (SCM_CONSP (proc
))
1008 /* plain let, proc is <bindings> */
1009 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
1012 if (!SCM_SYMBOLP (proc
))
1013 scm_wta (xorig
, scm_s_bindings
, s_let
); /* bad let */
1014 name
= proc
; /* named let, build equiv letrec */
1016 SCM_ASSYNT (scm_ilength (x
) >= 2, xorig
, scm_s_body
, s_let
);
1017 proc
= SCM_CAR (x
); /* bindings list */
1018 SCM_ASSYNT (scm_ilength (proc
) >= 0, xorig
, scm_s_bindings
, s_let
);
1019 while (SCM_NIMP (proc
))
1020 { /* vars and inits both in order */
1021 arg1
= SCM_CAR (proc
);
1022 SCM_ASSYNT (2 == scm_ilength (arg1
), xorig
, scm_s_bindings
, s_let
);
1023 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)),
1024 xorig
, scm_s_variable
, s_let
);
1025 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
1026 varloc
= SCM_CDRLOC (*varloc
);
1027 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
1028 initloc
= SCM_CDRLOC (*initloc
);
1029 proc
= SCM_CDR (proc
);
1032 proc
= scm_cons2 (scm_sym_lambda
, vars
,
1033 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1034 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1036 scm_acons (name
, inits
, SCM_EOL
));
1037 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1041 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1042 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1043 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1046 scm_m_apply (SCM xorig
, SCM env
)
1048 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1049 xorig
, scm_s_expression
, s_atapply
);
1050 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1054 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1055 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1059 scm_m_cont (SCM xorig
, SCM env
)
1061 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1062 xorig
, scm_s_expression
, s_atcall_cc
);
1063 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1066 /* Multi-language support */
1071 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1074 scm_m_nil_cond (SCM xorig
, SCM env
)
1076 int len
= scm_ilength (SCM_CDR (xorig
));
1077 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1078 scm_s_expression
, "nil-cond");
1079 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1082 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1085 scm_m_nil_ify (SCM xorig
, SCM env
)
1087 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1088 xorig
, scm_s_expression
, "nil-ify");
1089 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1095 scm_m_t_ify (SCM xorig
, SCM env
)
1097 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1098 xorig
, scm_s_expression
, "t-ify");
1099 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1102 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1105 scm_m_0_cond (SCM xorig
, SCM env
)
1107 int len
= scm_ilength (SCM_CDR (xorig
));
1108 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, xorig
,
1109 scm_s_expression
, "0-cond");
1110 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1113 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1116 scm_m_0_ify (SCM xorig
, SCM env
)
1118 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1119 xorig
, scm_s_expression
, "0-ify");
1120 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1123 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1126 scm_m_1_ify (SCM xorig
, SCM env
)
1128 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1129 xorig
, scm_s_expression
, "1-ify");
1130 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1133 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1136 scm_m_atfop (SCM xorig
, SCM env
)
1138 SCM x
= SCM_CDR (xorig
), vcell
;
1139 SCM_ASSYNT (scm_ilength (x
) >= 1, xorig
, scm_s_expression
, "@fop");
1140 vcell
= scm_symbol_fref (SCM_CAR (x
));
1141 SCM_ASSYNT (SCM_CONSP (vcell
), x
,
1142 "Symbol's function definition is void", NULL
);
1143 SCM_SETCAR (x
, vcell
+ 1);
1147 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1150 scm_m_atbind (SCM xorig
, SCM env
)
1152 SCM x
= SCM_CDR (xorig
);
1153 SCM_ASSYNT (scm_ilength (x
) > 1, xorig
, scm_s_expression
, "@bind");
1159 while (SCM_NIMP (SCM_CDR (env
)))
1160 env
= SCM_CDR (env
);
1161 env
= SCM_CAR (env
);
1162 if (SCM_CONSP (env
))
1167 while (SCM_NIMP (x
))
1169 SCM_SETCAR (x
, scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
) + 1);
1172 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1176 scm_m_expand_body (SCM xorig
, SCM env
)
1178 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1179 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1181 while (SCM_NIMP (x
))
1184 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1186 if (SCM_IMP (SCM_CAR (form
)))
1188 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1191 form
= scm_macroexp (scm_cons_source (form
,
1196 if (SCM_IM_DEFINE
== SCM_CAR (form
))
1198 defs
= scm_cons (SCM_CDR (form
), defs
);
1201 else if (SCM_NIMP(defs
))
1205 else if (SCM_IM_BEGIN
== SCM_CAR (form
))
1207 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1211 x
= scm_cons (form
, SCM_CDR(x
));
1216 SCM_ASSYNT (SCM_NIMP (x
), SCM_CDR (xorig
), scm_s_body
, what
);
1217 if (SCM_NIMP (defs
))
1219 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1221 scm_cons2 (scm_sym_define
, defs
, x
),
1227 SCM_SETCAR (xorig
, SCM_CAR (x
));
1228 SCM_SETCDR (xorig
, SCM_CDR (x
));
1235 scm_macroexp (SCM x
, SCM env
)
1239 /* Don't bother to produce error messages here. We get them when we
1240 eventually execute the code for real. */
1243 if (SCM_IMP (SCM_CAR (x
)) || !SCM_SYMBOLP (SCM_CAR (x
)))
1248 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1249 if (proc_ptr
== NULL
)
1251 /* We have lost the race. */
1257 proc
= *scm_lookupcar (x
, env
, 0);
1260 /* Only handle memoizing macros. `Acros' and `macros' are really
1261 special forms and should not be evaluated here. */
1264 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1265 || (int) (SCM_CARW (proc
) >> 16) != 2)
1269 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1271 if (scm_ilength (res
) <= 0)
1272 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1275 SCM_SETCAR (x
, SCM_CAR (res
));
1276 SCM_SETCDR (x
, SCM_CDR (res
));
1282 /* scm_unmemocopy takes a memoized expression together with its
1283 * environment and rewrites it to its original form. Thus, it is the
1284 * inversion of the rewrite rules above. The procedure is not
1285 * optimized for speed. It's used in scm_iprin1 when printing the
1286 * code of a closure, in scm_procedure_source, in display_frame when
1287 * generating the source for a stackframe in a backtrace, and in
1288 * display_expression.
1291 /* We should introduce an anti-macro interface so that it is possible
1292 * to plug in transformers in both directions from other compilation
1293 * units. unmemocopy could then dispatch to anti-macro transformers.
1294 * (Those transformers could perhaps be written in slightly more
1295 * readable style... :)
1298 #define SCM_BIT8(x) (127 & SCM_ASWORD (x))
1301 unmemocopy (SCM x
, SCM env
)
1304 #ifdef DEBUG_EXTENSIONS
1307 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1309 #ifdef DEBUG_EXTENSIONS
1310 p
= scm_whash_lookup (scm_source_whash
, x
);
1312 switch (SCM_TYP7 (x
))
1314 case SCM_BIT8(SCM_IM_AND
):
1315 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1317 case SCM_BIT8(SCM_IM_BEGIN
):
1318 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1320 case SCM_BIT8(SCM_IM_CASE
):
1321 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1323 case SCM_BIT8(SCM_IM_COND
):
1324 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1326 case SCM_BIT8(SCM_IM_DO
):
1327 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1329 case SCM_BIT8(SCM_IM_IF
):
1330 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1332 case SCM_BIT8(SCM_IM_LET
):
1333 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1335 case SCM_BIT8(SCM_IM_LETREC
):
1338 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1342 f
= v
= SCM_CAR (x
);
1344 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1346 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1347 SCM_CAR (ls
) == scm_sym_letrec
? z
: env
));
1350 s
= SCM_CAR (ls
) == scm_sym_do
1351 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1353 /* build transformed binding list */
1357 z
= scm_acons (SCM_CAR (v
),
1358 scm_cons (SCM_CAR (e
),
1359 SCM_CAR (s
) == SCM_CAR (v
)
1361 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1367 while (SCM_NIMP (v
));
1368 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1370 if (SCM_CAR (ls
) == scm_sym_do
)
1374 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1377 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1378 /* body forms are now to be found in SCM_CDR (x)
1379 (this is how *real* code look like! :) */
1383 case SCM_BIT8(SCM_IM_LETSTAR
):
1391 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1394 y
= z
= scm_acons (SCM_CAR (b
),
1396 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1398 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1399 b
= SCM_CDR (SCM_CDR (b
));
1402 SCM_SETCDR (y
, SCM_EOL
);
1403 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1408 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1410 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1413 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1414 b
= SCM_CDR (SCM_CDR (b
));
1416 while (SCM_NIMP (b
));
1417 SCM_SETCDR (z
, SCM_EOL
);
1419 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1422 case SCM_BIT8(SCM_IM_OR
):
1423 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1425 case SCM_BIT8(SCM_IM_LAMBDA
):
1427 ls
= scm_cons (scm_sym_lambda
,
1428 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1429 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1431 case SCM_BIT8(SCM_IM_QUOTE
):
1432 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1434 case SCM_BIT8(SCM_IM_SET_X
):
1435 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1437 case SCM_BIT8(SCM_IM_DEFINE
):
1441 ls
= scm_cons (scm_sym_define
,
1442 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1443 if (SCM_NNULLP (env
))
1444 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1447 case SCM_BIT8(SCM_MAKISYM (0)):
1451 switch (SCM_ISYMNUM (z
))
1453 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1454 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1456 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1457 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1459 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1460 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1464 /* appease the Sun compiler god: */ ;
1468 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1473 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1475 if (SCM_IMP (SCM_CAR (x
)) && SCM_ISYMP (SCM_CAR (x
)))
1476 /* skip body markers */
1478 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1484 #ifdef DEBUG_EXTENSIONS
1485 if (SCM_NFALSEP (p
))
1486 scm_whash_insert (scm_source_whash
, ls
, p
);
1493 scm_unmemocopy (SCM x
, SCM env
)
1495 if (SCM_NNULLP (env
))
1496 /* Make a copy of the lowest frame to protect it from
1497 modifications by SCM_IM_DEFINE */
1498 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1500 return unmemocopy (x
, env
);
1503 #ifndef SCM_RECKLESS
1506 scm_badargsp (SCM formals
, SCM args
)
1508 while (SCM_NIMP (formals
))
1510 if (SCM_NCONSP (formals
))
1514 formals
= SCM_CDR (formals
);
1515 args
= SCM_CDR (args
);
1517 return SCM_NNULLP (args
) ? 1 : 0;
1524 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1526 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1527 while (SCM_NIMP (l
))
1532 else if (SCM_CONSP (l
))
1534 if (SCM_IMP (SCM_CAR (l
)))
1535 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1537 res
= EVALCELLCAR (l
, env
);
1539 else if (SCM_TYP3 (l
) == 1)
1541 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1542 res
= SCM_CAR (l
); /* struct planted in code */
1547 res
= EVALCAR (l
, env
);
1549 *lloc
= scm_cons (res
, SCM_EOL
);
1550 lloc
= SCM_CDRLOC (*lloc
);
1557 scm_wrong_num_args (proc
);
1564 scm_eval_body (SCM code
, SCM env
)
1569 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1571 if (SCM_IMP (SCM_CAR (code
)))
1573 if (SCM_ISYMP (SCM_CAR (code
)))
1575 code
= scm_m_expand_body (code
, env
);
1580 SCM_XEVAL (SCM_CAR (code
), env
);
1583 return SCM_XEVALCAR (code
, env
);
1590 /* SECTION: This code is specific for the debugging support. One
1591 * branch is read when DEVAL isn't defined, the other when DEVAL is
1597 #define SCM_APPLY scm_apply
1598 #define PREP_APPLY(proc, args)
1600 #define RETURN(x) return x;
1601 #ifdef STACK_CHECKING
1602 #ifndef NO_CEVAL_STACK_CHECKING
1603 #define EVAL_STACK_CHECKING
1610 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1612 #define SCM_APPLY scm_dapply
1614 #define PREP_APPLY(p, l) \
1615 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1617 #define ENTER_APPLY \
1619 SCM_SET_ARGSREADY (debug);\
1620 if (CHECK_APPLY && SCM_TRAPS_P)\
1621 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1623 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1624 SCM_SET_TRACED_FRAME (debug); \
1625 if (SCM_CHEAPTRAPS_P)\
1627 tmp = scm_make_debugobj (&debug);\
1628 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1632 scm_make_cont (&tmp);\
1633 if (!setjmp (SCM_JMPBUF (tmp)))\
1634 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1639 #define RETURN(e) {proc = (e); goto exit;}
1640 #ifdef STACK_CHECKING
1641 #ifndef EVAL_STACK_CHECKING
1642 #define EVAL_STACK_CHECKING
1646 /* scm_ceval_ptr points to the currently selected evaluator.
1647 * *fixme*: Although efficiency is important here, this state variable
1648 * should probably not be a global. It should be related to the
1653 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1655 /* scm_last_debug_frame contains a pointer to the last debugging
1656 * information stack frame. It is accessed very often from the
1657 * debugging evaluator, so it should probably not be indirectly
1658 * addressed. Better to save and restore it from the current root at
1663 scm_debug_frame
*scm_last_debug_frame
;
1666 /* scm_debug_eframe_size is the number of slots available for pseudo
1667 * stack frames at each real stack frame.
1670 int scm_debug_eframe_size
;
1672 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1676 scm_option scm_eval_opts
[] = {
1677 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1680 scm_option scm_debug_opts
[] = {
1681 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1682 "*Flyweight representation of the stack at traps." },
1683 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1684 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1685 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1686 "Record procedure names at definition." },
1687 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1688 "Display backtrace in anti-chronological order." },
1689 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1690 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1691 { SCM_OPTION_INTEGER
, "frames", 3,
1692 "Maximum number of tail-recursive frames in backtrace." },
1693 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1694 "Maximal number of stored backtrace frames." },
1695 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1696 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1697 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1698 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1701 scm_option scm_evaluator_trap_table
[] = {
1702 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1703 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1704 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1705 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1708 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1711 #define FUNC_NAME s_scm_eval_options_interface
1715 ans
= scm_options (setting
,
1719 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1725 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1728 #define FUNC_NAME s_scm_evaluator_traps
1732 ans
= scm_options (setting
,
1733 scm_evaluator_trap_table
,
1734 SCM_N_EVALUATOR_TRAPS
,
1736 SCM_RESET_DEBUG_MODE
;
1743 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1745 SCM
*results
= lloc
, res
;
1746 while (SCM_NIMP (l
))
1751 else if (SCM_CONSP (l
))
1753 if (SCM_IMP (SCM_CAR (l
)))
1754 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1756 res
= EVALCELLCAR (l
, env
);
1758 else if (SCM_TYP3 (l
) == 1)
1760 if ((res
= SCM_GLOC_VAL (SCM_CAR (l
))) == 0)
1761 res
= SCM_CAR (l
); /* struct planted in code */
1766 res
= EVALCAR (l
, env
);
1768 *lloc
= scm_cons (res
, SCM_EOL
);
1769 lloc
= SCM_CDRLOC (*lloc
);
1776 scm_wrong_num_args (proc
);
1785 /* SECTION: Some local definitions for the evaluator.
1790 #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1792 #define CHECK_EQVISH(A,B) ((A) == (B))
1796 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1798 /* SECTION: This is the evaluator. Like any real monster, it has
1799 * three heads. This code is compiled twice.
1805 scm_ceval (SCM x
, SCM env
)
1811 scm_deval (SCM x
, SCM env
)
1816 SCM_CEVAL (SCM x
, SCM env
)
1825 scm_debug_frame debug
;
1826 scm_debug_info
*debug_info_end
;
1827 debug
.prev
= scm_last_debug_frame
;
1828 debug
.status
= scm_debug_eframe_size
;
1830 * The debug.vect contains twice as much scm_debug_info frames as the
1831 * user has specified with (debug-set! frames <n>).
1833 * Even frames are eval frames, odd frames are apply frames.
1835 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1836 * sizeof (debug
.vect
[0]));
1837 debug
.info
= debug
.vect
;
1838 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1839 scm_last_debug_frame
= &debug
;
1841 #ifdef EVAL_STACK_CHECKING
1842 if (scm_stack_checking_enabled_p
1843 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1846 debug
.info
->e
.exp
= x
;
1847 debug
.info
->e
.env
= env
;
1849 scm_report_stack_overflow ();
1856 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1859 SCM_CLEAR_ARGSREADY (debug
);
1860 if (SCM_OVERFLOWP (debug
))
1863 * In theory, this should be the only place where it is necessary to
1864 * check for space in debug.vect since both eval frames and
1865 * available space are even.
1867 * For this to be the case, however, it is necessary that primitive
1868 * special forms which jump back to `loop', `begin' or some similar
1869 * label call PREP_APPLY. A convenient way to do this is to jump to
1870 * `loopnoap' or `cdrxnoap'.
1872 else if (++debug
.info
>= debug_info_end
)
1874 SCM_SET_OVERFLOW (debug
);
1878 debug
.info
->e
.exp
= x
;
1879 debug
.info
->e
.env
= env
;
1880 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1881 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1883 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1884 SCM_SET_TAILREC (debug
);
1885 if (SCM_CHEAPTRAPS_P
)
1886 t
.arg1
= scm_make_debugobj (&debug
);
1889 scm_make_cont (&t
.arg1
);
1890 if (setjmp (SCM_JMPBUF (t
.arg1
)))
1892 x
= SCM_THROW_VALUE (t
.arg1
);
1898 /* This gives the possibility for the debugger to
1899 modify the source expression before evaluation. */
1903 scm_ithrow (scm_sym_enter_frame
,
1904 scm_cons2 (t
.arg1
, tail
,
1905 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1909 #if defined (USE_THREADS) || defined (DEVAL)
1913 switch (SCM_TYP7 (x
))
1915 case scm_tcs_symbols
:
1916 /* Only happens when called at top level.
1918 x
= scm_cons (x
, SCM_UNDEFINED
);
1921 case SCM_BIT8(SCM_IM_AND
):
1924 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1925 if (SCM_FALSEP (EVALCAR (x
, env
)))
1927 RETURN (SCM_BOOL_F
);
1931 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1934 case SCM_BIT8(SCM_IM_BEGIN
):
1936 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1942 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1944 if (SCM_IMP (SCM_CAR (x
)))
1946 if (SCM_ISYMP (SCM_CAR (x
)))
1948 x
= scm_m_expand_body (x
, env
);
1953 SCM_CEVAL (SCM_CAR (x
), env
);
1957 carloop
: /* scm_eval car of last form in list */
1958 if (SCM_NCELLP (SCM_CAR (x
)))
1961 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1964 if (SCM_SYMBOLP (SCM_CAR (x
)))
1967 RETURN (*scm_lookupcar (x
, env
, 1))
1971 goto loop
; /* tail recurse */
1974 case SCM_BIT8(SCM_IM_CASE
):
1976 t
.arg1
= EVALCAR (x
, env
);
1977 while (SCM_NIMP (x
= SCM_CDR (x
)))
1980 if (scm_sym_else
== SCM_CAR (proc
))
1983 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1986 proc
= SCM_CAR (proc
);
1987 while (SCM_NIMP (proc
))
1989 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
1991 x
= SCM_CDR (SCM_CAR (x
));
1992 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1995 proc
= SCM_CDR (proc
);
1998 RETURN (SCM_UNSPECIFIED
)
2001 case SCM_BIT8(SCM_IM_COND
):
2002 while (SCM_NIMP (x
= SCM_CDR (x
)))
2005 t
.arg1
= EVALCAR (proc
, env
);
2006 if (SCM_NFALSEP (t
.arg1
))
2013 if (scm_sym_arrow
!= SCM_CAR (x
))
2015 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2019 proc
= EVALCAR (proc
, env
);
2020 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2021 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2026 RETURN (SCM_UNSPECIFIED
)
2029 case SCM_BIT8(SCM_IM_DO
):
2031 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2032 t
.arg1
= SCM_EOL
; /* values */
2033 while (SCM_NIMP (proc
))
2035 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2036 proc
= SCM_CDR (proc
);
2038 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2039 x
= SCM_CDR (SCM_CDR (x
));
2040 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2042 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2044 t
.arg1
= SCM_CAR (proc
); /* body */
2045 SIDEVAL (t
.arg1
, env
);
2047 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2049 proc
= SCM_CDR (proc
))
2050 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2051 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2055 RETURN (SCM_UNSPECIFIED
);
2056 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2060 case SCM_BIT8(SCM_IM_IF
):
2062 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2064 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2066 RETURN (SCM_UNSPECIFIED
);
2068 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2072 case SCM_BIT8(SCM_IM_LET
):
2074 proc
= SCM_CAR (SCM_CDR (x
));
2078 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2080 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2081 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2086 case SCM_BIT8(SCM_IM_LETREC
):
2088 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2094 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2096 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2097 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2101 case SCM_BIT8(SCM_IM_LETSTAR
):
2106 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2111 t
.arg1
= SCM_CAR (proc
);
2112 proc
= SCM_CDR (proc
);
2113 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2115 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2118 case SCM_BIT8(SCM_IM_OR
):
2121 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2123 x
= EVALCAR (x
, env
);
2124 if (SCM_NFALSEP (x
))
2130 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2134 case SCM_BIT8(SCM_IM_LAMBDA
):
2135 RETURN (scm_closure (SCM_CDR (x
), env
));
2138 case SCM_BIT8(SCM_IM_QUOTE
):
2139 RETURN (SCM_CAR (SCM_CDR (x
)));
2142 case SCM_BIT8(SCM_IM_SET_X
):
2145 switch (7 & (int) proc
)
2148 t
.lloc
= scm_lookupcar (x
, env
, 1);
2151 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2153 #ifdef MEMOIZE_LOCALS
2155 t
.lloc
= scm_ilookup (proc
, env
);
2160 *t
.lloc
= EVALCAR (x
, env
);
2164 RETURN (SCM_UNSPECIFIED
);
2168 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2169 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2171 /* new syntactic forms go here. */
2172 case SCM_BIT8(SCM_MAKISYM (0)):
2174 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2175 switch SCM_ISYMNUM (proc
)
2178 case (SCM_ISYMNUM (IM_VREF
)):
2181 var
= SCM_CAR (SCM_CDR (x
));
2182 RETURN (SCM_CDR(var
));
2184 case (SCM_ISYMNUM (IM_VSET
)):
2185 SCM_CDR (SCM_CAR ( SCM_CDR (x
))) = EVALCAR( SCM_CDR ( SCM_CDR (x
)), env
);
2186 SCM_CAR (SCM_CAR ( SCM_CDR (x
))) = scm_tc16_variable
;
2187 RETURN (SCM_UNSPECIFIED
)
2190 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2192 proc
= EVALCAR (proc
, env
);
2193 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2194 if (SCM_CLOSUREP (proc
))
2197 PREP_APPLY (proc
, SCM_EOL
);
2198 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2199 t
.arg1
= EVALCAR (t
.arg1
, env
);
2201 debug
.info
->a
.args
= t
.arg1
;
2203 #ifndef SCM_RECKLESS
2204 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2208 /* Copy argument list */
2209 if (SCM_IMP (t
.arg1
))
2213 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2214 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2215 && SCM_CONSP (t
.arg1
))
2217 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2221 SCM_SETCDR (tl
, t
.arg1
);
2224 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2225 x
= SCM_CODE (proc
);
2231 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2232 scm_make_cont (&t
.arg1
);
2233 if (setjmp (SCM_JMPBUF (t
.arg1
)))
2236 val
= SCM_THROW_VALUE (t
.arg1
);
2240 proc
= evalcar (proc
, env
);
2241 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2242 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2246 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2247 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2249 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2250 proc
= SCM_CADR (x
); /* unevaluated operands */
2251 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2253 arg2
= *scm_ilookup (proc
, env
);
2254 else if (SCM_NCONSP (proc
))
2256 if (SCM_NCELLP (proc
))
2257 arg2
= SCM_GLOC_VAL (proc
);
2259 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2263 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2264 t
.lloc
= SCM_CDRLOC (arg2
);
2265 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2267 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2268 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2273 /* The type dispatch code is duplicated here
2274 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2275 * cuts down execution time for type dispatch to 50%.
2278 int i
, n
, end
, mask
;
2279 SCM z
= SCM_CDDR (x
);
2280 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2281 proc
= SCM_CADR (z
);
2283 if (SCM_NIMP (proc
))
2285 /* Prepare for linear search */
2288 end
= SCM_LENGTH (proc
);
2292 /* Compute a hash value */
2293 int hashset
= SCM_INUM (proc
);
2295 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2296 proc
= SCM_CADR (z
);
2299 if (SCM_NIMP (t
.arg1
))
2302 i
+= SCM_ASWORD ((SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
))))
2303 [scm_si_hashsets
+ hashset
]);
2304 t
.arg1
= SCM_CDR (t
.arg1
);
2306 while (--j
&& SCM_NIMP (t
.arg1
));
2311 /* Search for match */
2315 z
= SCM_VELTS (proc
)[i
];
2316 t
.arg1
= arg2
; /* list of arguments */
2317 if (SCM_NIMP (t
.arg1
))
2320 /* More arguments than specifiers => CLASS != ENV */
2321 if (scm_class_of (SCM_CAR (t
.arg1
)) != SCM_CAR (z
))
2323 t
.arg1
= SCM_CDR (t
.arg1
);
2326 while (--j
&& SCM_NIMP (t
.arg1
));
2327 /* Fewer arguments than specifiers => CAR != ENV */
2328 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2331 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2333 SCM_CMETHOD_ENV (z
));
2334 x
= SCM_CMETHOD_CODE (z
);
2340 z
= scm_memoize_method (x
, arg2
);
2344 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2346 t
.arg1
= EVALCAR (x
, env
);
2347 RETURN (SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CADR (x
))])
2349 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2351 t
.arg1
= EVALCAR (x
, env
);
2354 SCM_STRUCT_DATA (t
.arg1
)[SCM_INUM (SCM_CAR (x
))]
2355 = EVALCAR (proc
, env
);
2356 RETURN (SCM_UNSPECIFIED
)
2358 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2360 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2362 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2363 || t
.arg1
== scm_nil
))
2365 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2367 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2373 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2376 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2378 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2382 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2384 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_t
: scm_nil
)
2386 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2388 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2390 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2391 || t
.arg1
== SCM_INUM0
))
2393 if (SCM_CAR (x
) == SCM_UNSPECIFIED
)
2395 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2401 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2404 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2406 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2410 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2412 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2416 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2419 t
.arg1
= SCM_CAR (x
);
2420 arg2
= SCM_CDAR (env
);
2421 while (SCM_NIMP (arg2
))
2423 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2424 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2425 SCM_SETCAR (arg2
, proc
);
2426 t
.arg1
= SCM_CDR (t
.arg1
);
2427 arg2
= SCM_CDR (arg2
);
2429 t
.arg1
= SCM_CAR (x
);
2430 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2432 arg2
= x
= SCM_CDR (x
);
2433 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2435 SIDEVAL (SCM_CAR (x
), env
);
2438 proc
= EVALCAR (x
, env
);
2440 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2441 arg2
= SCM_CDAR (env
);
2442 while (SCM_NIMP (arg2
))
2444 SCM_SETCDR (SCM_CAR (t
.arg1
) - 1L, SCM_CAR (arg2
));
2445 t
.arg1
= SCM_CDR (t
.arg1
);
2446 arg2
= SCM_CDR (arg2
);
2458 /* scm_everr (x, env,...) */
2459 scm_misc_error (NULL
,
2460 "Wrong type to apply: ~S",
2461 scm_listify (proc
, SCM_UNDEFINED
));
2462 case scm_tc7_vector
:
2466 case scm_tc7_byvect
:
2473 #ifdef HAVE_LONG_LONGS
2474 case scm_tc7_llvect
:
2477 case scm_tc7_string
:
2478 case scm_tc7_substring
:
2480 case scm_tcs_closures
:
2488 #ifdef MEMOIZE_LOCALS
2489 case SCM_BIT8(SCM_ILOC00
):
2490 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2491 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2492 #ifndef SCM_RECKLESS
2498 #endif /* ifdef MEMOIZE_LOCALS */
2501 case scm_tcs_cons_gloc
:
2502 proc
= SCM_GLOC_VAL (SCM_CAR (x
));
2504 /* This is a struct implanted in the code, not a gloc. */
2506 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2507 #ifndef SCM_RECKLESS
2515 case scm_tcs_cons_nimcar
:
2516 if (SCM_SYMBOLP (SCM_CAR (x
)))
2519 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2522 /* we have lost the race, start again. */
2527 proc
= *scm_lookupcar (x
, env
, 1);
2535 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2541 /* Set a flag during macro expansion so that macro
2542 application frames can be deleted from the backtrace. */
2543 SCM_SET_MACROEXP (debug
);
2545 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2546 scm_cons (env
, scm_listofnull
));
2549 SCM_CLEAR_MACROEXP (debug
);
2551 switch ((int) (SCM_CARW (proc
) >> 16))
2554 if (scm_ilength (t
.arg1
) <= 0)
2555 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2557 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2560 #if 0 /* Top-level defines doesn't very often occur in backtraces */
2561 if (scm_m_define
== SCM_SUBRF (SCM_CDR (proc
)) && SCM_TOP_LEVEL (env
))
2562 /* Prevent memoizing result of define macro */
2564 debug
.info
->e
.exp
= scm_cons (SCM_CAR (x
), SCM_CDR (x
));
2565 scm_set_source_properties_x (debug
.info
->e
.exp
,
2566 scm_source_properties (x
));
2570 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2571 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2575 /* Prevent memoizing of debug info expression. */
2576 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2581 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2582 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2586 if (SCM_NIMP (x
= t
.arg1
))
2594 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2595 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2596 #ifndef SCM_RECKLESS
2600 if (SCM_CLOSUREP (proc
))
2602 arg2
= SCM_CAR (SCM_CODE (proc
));
2603 t
.arg1
= SCM_CDR (x
);
2604 while (SCM_NIMP (arg2
))
2606 if (SCM_NCONSP (arg2
))
2608 if (SCM_IMP (t
.arg1
))
2609 goto umwrongnumargs
;
2610 arg2
= SCM_CDR (arg2
);
2611 t
.arg1
= SCM_CDR (t
.arg1
);
2613 if (SCM_NNULLP (t
.arg1
))
2614 goto umwrongnumargs
;
2616 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2617 goto handle_a_macro
;
2623 PREP_APPLY (proc
, SCM_EOL
);
2624 if (SCM_NULLP (SCM_CDR (x
))) {
2627 switch (SCM_TYP7 (proc
))
2628 { /* no arguments given */
2629 case scm_tc7_subr_0
:
2630 RETURN (SCM_SUBRF (proc
) ());
2631 case scm_tc7_subr_1o
:
2632 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2634 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2635 case scm_tc7_rpsubr
:
2636 RETURN (SCM_BOOL_T
);
2638 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2642 proc
= SCM_CCLO_SUBR (proc
);
2644 debug
.info
->a
.proc
= proc
;
2645 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2650 proc
= SCM_PROCEDURE (proc
);
2652 debug
.info
->a
.proc
= proc
;
2655 case scm_tcs_closures
:
2656 x
= SCM_CODE (proc
);
2657 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2659 case scm_tcs_cons_gloc
:
2660 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2662 x
= SCM_ENTITY_PROCEDURE (proc
);
2666 else if (!SCM_I_OPERATORP (proc
))
2671 proc
= (SCM_I_ENTITYP (proc
)
2672 ? SCM_ENTITY_PROCEDURE (proc
)
2673 : SCM_OPERATOR_PROCEDURE (proc
));
2675 debug
.info
->a
.proc
= proc
;
2676 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2678 if (SCM_NIMP (proc
))
2683 case scm_tc7_contin
:
2684 case scm_tc7_subr_1
:
2685 case scm_tc7_subr_2
:
2686 case scm_tc7_subr_2o
:
2688 case scm_tc7_subr_3
:
2689 case scm_tc7_lsubr_2
:
2693 /* scm_everr (x, env,...) */
2694 scm_wrong_num_args (proc
);
2696 /* handle macros here */
2701 /* must handle macros by here */
2706 else if (SCM_CONSP (x
))
2708 if (SCM_IMP (SCM_CAR (x
)))
2709 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2711 t
.arg1
= EVALCELLCAR (x
, env
);
2713 else if (SCM_TYP3 (x
) == 1)
2715 if ((t
.arg1
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2716 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2721 t
.arg1
= EVALCAR (x
, env
);
2724 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2731 switch (SCM_TYP7 (proc
))
2732 { /* have one argument in t.arg1 */
2733 case scm_tc7_subr_2o
:
2734 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2735 case scm_tc7_subr_1
:
2736 case scm_tc7_subr_1o
:
2737 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2740 if (SCM_SUBRF (proc
))
2742 if (SCM_INUMP (t
.arg1
))
2744 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
)),
2747 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2748 if (SCM_REALP (t
.arg1
))
2750 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (t
.arg1
)), 0.0));
2753 if (SCM_BIGP (t
.arg1
))
2755 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
)), 0.0));
2759 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2760 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
2763 proc
= (SCM
) SCM_SNAME (proc
);
2765 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
2766 while ('c' != *--chrs
)
2768 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2769 t
.arg1
, SCM_ARG1
, SCM_CHARS (proc
));
2770 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2774 case scm_tc7_rpsubr
:
2775 RETURN (SCM_BOOL_T
);
2777 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2780 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2782 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2788 proc
= SCM_CCLO_SUBR (proc
);
2790 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2791 debug
.info
->a
.proc
= proc
;
2796 proc
= SCM_PROCEDURE (proc
);
2798 debug
.info
->a
.proc
= proc
;
2801 case scm_tcs_closures
:
2803 x
= SCM_CODE (proc
);
2805 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2807 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2810 case scm_tc7_contin
:
2811 scm_call_continuation (proc
, t
.arg1
);
2812 case scm_tcs_cons_gloc
:
2813 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2815 x
= SCM_ENTITY_PROCEDURE (proc
);
2817 arg2
= debug
.info
->a
.args
;
2819 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2823 else if (!SCM_I_OPERATORP (proc
))
2829 proc
= (SCM_I_ENTITYP (proc
)
2830 ? SCM_ENTITY_PROCEDURE (proc
)
2831 : SCM_OPERATOR_PROCEDURE (proc
));
2833 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2834 debug
.info
->a
.proc
= proc
;
2836 if (SCM_NIMP (proc
))
2841 case scm_tc7_subr_2
:
2842 case scm_tc7_subr_0
:
2843 case scm_tc7_subr_3
:
2844 case scm_tc7_lsubr_2
:
2853 else if (SCM_CONSP (x
))
2855 if (SCM_IMP (SCM_CAR (x
)))
2856 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2858 arg2
= EVALCELLCAR (x
, env
);
2860 else if (SCM_TYP3 (x
) == 1)
2862 if ((arg2
= SCM_GLOC_VAL (SCM_CAR (x
))) == 0)
2863 arg2
= SCM_CAR (x
); /* struct planted in code */
2868 arg2
= EVALCAR (x
, env
);
2870 { /* have two or more arguments */
2872 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2875 if (SCM_NULLP (x
)) {
2880 switch (SCM_TYP7 (proc
))
2881 { /* have two arguments */
2882 case scm_tc7_subr_2
:
2883 case scm_tc7_subr_2o
:
2884 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2887 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2889 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2891 case scm_tc7_lsubr_2
:
2892 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2893 case scm_tc7_rpsubr
:
2895 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2900 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2901 scm_cons (proc
, debug
.info
->a
.args
),
2904 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2905 scm_cons2 (proc
, t
.arg1
,
2912 /* case scm_tc7_cclo:
2913 x = scm_cons(arg2, scm_eval_args(x, env));
2916 proc = SCM_CCLO_SUBR(proc);
2920 proc
= SCM_PROCEDURE (proc
);
2922 debug
.info
->a
.proc
= proc
;
2925 case scm_tcs_cons_gloc
:
2926 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2928 x
= SCM_ENTITY_PROCEDURE (proc
);
2930 arg2
= debug
.info
->a
.args
;
2932 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2936 else if (!SCM_I_OPERATORP (proc
))
2942 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2943 ? SCM_ENTITY_PROCEDURE (proc
)
2944 : SCM_OPERATOR_PROCEDURE (proc
),
2945 scm_cons (proc
, debug
.info
->a
.args
),
2948 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2949 ? SCM_ENTITY_PROCEDURE (proc
)
2950 : SCM_OPERATOR_PROCEDURE (proc
),
2951 scm_cons2 (proc
, t
.arg1
,
2959 case scm_tc7_subr_0
:
2961 case scm_tc7_subr_1o
:
2962 case scm_tc7_subr_1
:
2963 case scm_tc7_subr_3
:
2964 case scm_tc7_contin
:
2968 case scm_tcs_closures
:
2971 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2975 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2976 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2978 x
= SCM_CODE (proc
);
2983 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2987 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2988 scm_deval_args (x
, env
, proc
,
2989 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2993 switch (SCM_TYP7 (proc
))
2994 { /* have 3 or more arguments */
2996 case scm_tc7_subr_3
:
2997 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
2998 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
2999 SCM_CADDR (debug
.info
->a
.args
)));
3001 #ifdef BUILTIN_RPASUBR
3002 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3003 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3006 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3007 arg2
= SCM_CDR (arg2
);
3009 while (SCM_NIMP (arg2
));
3011 #endif /* BUILTIN_RPASUBR */
3012 case scm_tc7_rpsubr
:
3013 #ifdef BUILTIN_RPASUBR
3014 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3016 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3019 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3021 arg2
= SCM_CAR (t
.arg1
);
3022 t
.arg1
= SCM_CDR (t
.arg1
);
3024 while (SCM_NIMP (t
.arg1
));
3026 #else /* BUILTIN_RPASUBR */
3027 RETURN (SCM_APPLY (proc
, t
.arg1
,
3029 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3031 #endif /* BUILTIN_RPASUBR */
3032 case scm_tc7_lsubr_2
:
3033 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3034 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3036 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3042 proc
= SCM_PROCEDURE (proc
);
3043 debug
.info
->a
.proc
= proc
;
3045 case scm_tcs_closures
:
3046 SCM_SET_ARGSREADY (debug
);
3047 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3050 x
= SCM_CODE (proc
);
3053 case scm_tc7_subr_3
:
3054 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3055 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3057 #ifdef BUILTIN_RPASUBR
3058 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3061 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3064 while (SCM_NIMP (x
));
3066 #endif /* BUILTIN_RPASUBR */
3067 case scm_tc7_rpsubr
:
3068 #ifdef BUILTIN_RPASUBR
3069 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3073 t
.arg1
= EVALCAR (x
, env
);
3074 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3079 while (SCM_NIMP (x
));
3081 #else /* BUILTIN_RPASUBR */
3082 RETURN (SCM_APPLY (proc
, t
.arg1
,
3084 scm_eval_args (x
, env
, proc
),
3086 #endif /* BUILTIN_RPASUBR */
3087 case scm_tc7_lsubr_2
:
3088 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3090 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3092 scm_eval_args (x
, env
, proc
))));
3098 proc
= SCM_PROCEDURE (proc
);
3100 case scm_tcs_closures
:
3102 SCM_SET_ARGSREADY (debug
);
3104 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3107 scm_eval_args (x
, env
, proc
)),
3109 x
= SCM_CODE (proc
);
3112 case scm_tcs_cons_gloc
:
3113 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3116 arg2
= debug
.info
->a
.args
;
3118 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3120 x
= SCM_ENTITY_PROCEDURE (proc
);
3123 else if (!SCM_I_OPERATORP (proc
))
3127 case scm_tc7_subr_2
:
3128 case scm_tc7_subr_1o
:
3129 case scm_tc7_subr_2o
:
3130 case scm_tc7_subr_0
:
3132 case scm_tc7_subr_1
:
3133 case scm_tc7_contin
:
3141 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3142 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3144 SCM_CLEAR_TRACED_FRAME (debug
);
3145 if (SCM_CHEAPTRAPS_P
)
3146 t
.arg1
= scm_make_debugobj (&debug
);
3149 scm_make_cont (&t
.arg1
);
3150 if (setjmp (SCM_JMPBUF (t
.arg1
)))
3152 proc
= SCM_THROW_VALUE (t
.arg1
);
3156 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3159 scm_last_debug_frame
= debug
.prev
;
3165 /* SECTION: This code is compiled once.
3170 /* This code processes the arguments to apply:
3172 (apply PROC ARG1 ... ARGS)
3174 Given a list (ARG1 ... ARGS), this function conses the ARG1
3175 ... arguments onto the front of ARGS, and returns the resulting
3176 list. Note that ARGS is a list; thus, the argument to this
3177 function is a list whose last element is a list.
3179 Apply calls this function, and applies PROC to the elements of the
3180 result. apply:nconc2last takes care of building the list of
3181 arguments, given (ARG1 ... ARGS).
3183 Rather than do new consing, apply:nconc2last destroys its argument.
3184 On that topic, this code came into my care with the following
3185 beautifully cryptic comment on that topic: "This will only screw
3186 you if you do (scm_apply scm_apply '( ... ))" If you know what
3187 they're referring to, send me a patch to this comment. */
3189 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3192 #define FUNC_NAME s_scm_nconc2last
3195 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3197 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3198 lloc
= SCM_CDRLOC (*lloc
);
3199 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3200 *lloc
= SCM_CAR (*lloc
);
3208 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3209 * It is compiled twice.
3215 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3222 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3227 /* Apply a function to a list of arguments.
3229 This function is exported to the Scheme level as taking two
3230 required arguments and a tail argument, as if it were:
3231 (lambda (proc arg1 . args) ...)
3232 Thus, if you just have a list of arguments to pass to a procedure,
3233 pass the list as ARG1, and '() for ARGS. If you have some fixed
3234 args, pass the first as ARG1, then cons any remaining fixed args
3235 onto the front of your argument list, and pass that as ARGS. */
3238 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3240 #ifdef DEBUG_EXTENSIONS
3242 scm_debug_frame debug
;
3243 scm_debug_info debug_vect_body
;
3244 debug
.prev
= scm_last_debug_frame
;
3245 debug
.status
= SCM_APPLYFRAME
;
3246 debug
.vect
= &debug_vect_body
;
3247 debug
.vect
[0].a
.proc
= proc
;
3248 debug
.vect
[0].a
.args
= SCM_EOL
;
3249 scm_last_debug_frame
= &debug
;
3252 return scm_dapply (proc
, arg1
, args
);
3256 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3258 /* If ARGS is the empty list, then we're calling apply with only two
3259 arguments --- ARG1 is the list of arguments for PROC. Whatever
3260 the case, futz with things so that ARG1 is the first argument to
3261 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3264 Setting the debug apply frame args this way is pretty messy.
3265 Perhaps we should store arg1 and args directly in the frame as
3266 received, and let scm_frame_arguments unpack them, because that's
3267 a relatively rare operation. This works for now; if the Guile
3268 developer archives are still around, see Mikael's post of
3270 if (SCM_NULLP (args
))
3272 if (SCM_NULLP (arg1
))
3274 arg1
= SCM_UNDEFINED
;
3276 debug
.vect
[0].a
.args
= SCM_EOL
;
3282 debug
.vect
[0].a
.args
= arg1
;
3284 args
= SCM_CDR (arg1
);
3285 arg1
= SCM_CAR (arg1
);
3290 /* SCM_ASRTGO(SCM_CONSP(args), wrongnumargs); */
3291 args
= scm_nconc2last (args
);
3293 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3297 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3300 if (SCM_CHEAPTRAPS_P
)
3301 tmp
= scm_make_debugobj (&debug
);
3304 scm_make_cont (&tmp
);
3305 if (setjmp (SCM_JMPBUF (tmp
)))
3308 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3316 switch (SCM_TYP7 (proc
))
3318 case scm_tc7_subr_2o
:
3319 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3320 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3321 case scm_tc7_subr_2
:
3322 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3324 args
= SCM_CAR (args
);
3325 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3326 case scm_tc7_subr_0
:
3327 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3328 RETURN (SCM_SUBRF (proc
) ())
3329 case scm_tc7_subr_1
:
3330 case scm_tc7_subr_1o
:
3331 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3332 RETURN (SCM_SUBRF (proc
) (arg1
))
3334 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3336 if (SCM_SUBRF (proc
))
3338 if (SCM_INUMP (arg1
))
3340 RETURN (scm_makdbl (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
)), 0.0));
3342 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3343 if (SCM_REALP (arg1
))
3345 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (SCM_REALPART (arg1
)), 0.0));
3348 if (SCM_BIGP (arg1
))
3349 RETURN (scm_makdbl (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
)), 0.0))
3352 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3353 SCM_ARG1
, SCM_CHARS (SCM_SNAME (proc
)));
3356 proc
= (SCM
) SCM_SNAME (proc
);
3358 char *chrs
= SCM_CHARS (proc
) + SCM_LENGTH (proc
) - 1;
3359 while ('c' != *--chrs
)
3361 SCM_ASSERT (SCM_CONSP (arg1
),
3362 arg1
, SCM_ARG1
, SCM_CHARS (proc
));
3363 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3367 case scm_tc7_subr_3
:
3368 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3371 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3373 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3375 case scm_tc7_lsubr_2
:
3376 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3377 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3379 if (SCM_NULLP (args
))
3380 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3381 while (SCM_NIMP (args
))
3383 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3384 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3385 args
= SCM_CDR (args
);
3388 case scm_tc7_rpsubr
:
3389 if (SCM_NULLP (args
))
3390 RETURN (SCM_BOOL_T
);
3391 while (SCM_NIMP (args
))
3393 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3394 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3395 RETURN (SCM_BOOL_F
);
3396 arg1
= SCM_CAR (args
);
3397 args
= SCM_CDR (args
);
3399 RETURN (SCM_BOOL_T
);
3400 case scm_tcs_closures
:
3402 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3404 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3406 #ifndef SCM_RECKLESS
3407 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3411 /* Copy argument list */
3416 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3417 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3419 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3423 SCM_SETCDR (tl
, arg1
);
3426 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3427 proc
= SCM_CDR (SCM_CODE (proc
));
3430 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3432 if (SCM_IMP (SCM_CAR (proc
)))
3434 if (SCM_ISYMP (SCM_CAR (proc
)))
3436 proc
= scm_m_expand_body (proc
, args
);
3441 SCM_CEVAL (SCM_CAR (proc
), args
);
3444 RETURN (EVALCAR (proc
, args
));
3445 case scm_tc7_contin
:
3446 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3447 scm_call_continuation (proc
, arg1
);
3451 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3453 proc
= SCM_CCLO_SUBR (proc
);
3454 debug
.vect
[0].a
.proc
= proc
;
3455 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3457 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3459 proc
= SCM_CCLO_SUBR (proc
);
3464 proc
= SCM_PROCEDURE (proc
);
3466 debug
.vect
[0].a
.proc
= proc
;
3469 case scm_tcs_cons_gloc
:
3470 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3473 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3475 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3477 RETURN (scm_apply_generic (proc
, args
));
3479 else if (!SCM_I_OPERATORP (proc
))
3484 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3486 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3489 proc
= (SCM_I_ENTITYP (proc
)
3490 ? SCM_ENTITY_PROCEDURE (proc
)
3491 : SCM_OPERATOR_PROCEDURE (proc
));
3493 debug
.vect
[0].a
.proc
= proc
;
3494 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3496 if (SCM_NIMP (proc
))
3502 scm_wrong_num_args (proc
);
3505 scm_wta (proc
, (char *) SCM_ARG1
, "apply");
3510 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3511 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3513 SCM_CLEAR_TRACED_FRAME (debug
);
3514 if (SCM_CHEAPTRAPS_P
)
3515 arg1
= scm_make_debugobj (&debug
);
3518 scm_make_cont (&arg1
);
3519 if (setjmp (SCM_JMPBUF (arg1
)))
3521 proc
= SCM_THROW_VALUE (arg1
);
3525 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3528 scm_last_debug_frame
= debug
.prev
;
3534 /* SECTION: The rest of this file is only read once.
3539 /* Typechecking for multi-argument MAP and FOR-EACH.
3541 Verify that each element of the vector ARGV, except for the first,
3542 is a proper list whose length is LEN. Attribute errors to WHO,
3543 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3545 check_map_args (SCM argv
,
3552 SCM
*ve
= SCM_VELTS (argv
);
3555 for (i
= SCM_LENGTH (argv
) - 1; i
>= 1; i
--)
3557 int elt_len
= scm_ilength (ve
[i
]);
3562 scm_apply_generic (gf
, scm_cons (proc
, args
));
3564 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3568 scm_out_of_range (who
, ve
[i
]);
3571 scm_remember (&argv
);
3575 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3577 /* Note: Currently, scm_map applies PROC to the argument list(s)
3578 sequentially, starting with the first element(s). This is used in
3579 evalext.c where the Scheme procedure `serial-map', which guarantees
3580 sequential behaviour, is implemented using scm_map. If the
3581 behaviour changes, we need to update `serial-map'.
3585 scm_map (SCM proc
, SCM arg1
, SCM args
)
3590 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3592 if (SCM_NULLP (arg1
))
3594 len
= scm_ilength (arg1
);
3595 SCM_GASSERTn (len
>= 0,
3596 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3597 if (SCM_NULLP (args
))
3599 while (SCM_NIMP (arg1
))
3601 SCM_GASSERT2 (SCM_CONSP (arg1
), g_map
, proc
, arg1
, SCM_ARG2
, s_map
);
3602 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3604 pres
= SCM_CDRLOC (*pres
);
3605 arg1
= SCM_CDR (arg1
);
3609 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3610 ve
= SCM_VELTS (args
);
3611 #ifndef SCM_RECKLESS
3612 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3617 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3619 if (SCM_IMP (ve
[i
]))
3621 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3622 ve
[i
] = SCM_CDR (ve
[i
]);
3624 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3625 pres
= SCM_CDRLOC (*pres
);
3630 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3633 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3635 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3638 return SCM_UNSPECIFIED
;
3639 len
= scm_ilength (arg1
);
3640 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3641 SCM_ARG2
, s_for_each
);
3644 while SCM_NIMP (arg1
)
3646 SCM_GASSERT2 (SCM_CONSP (arg1
),
3647 g_for_each
, proc
, arg1
, SCM_ARG2
, s_for_each
);
3648 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3649 arg1
= SCM_CDR (arg1
);
3651 return SCM_UNSPECIFIED
;
3653 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3654 ve
= SCM_VELTS (args
);
3655 #ifndef SCM_RECKLESS
3656 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3661 for (i
= SCM_LENGTH (args
) - 1; i
>= 0; i
--)
3664 (ve
[i
]) return SCM_UNSPECIFIED
;
3665 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3666 ve
[i
] = SCM_CDR (ve
[i
]);
3668 scm_apply (proc
, arg1
, SCM_EOL
);
3675 scm_closure (SCM code
, SCM env
)
3679 SCM_SETCODE (z
, code
);
3680 SCM_SETENV (z
, env
);
3685 long scm_tc16_promise
;
3688 scm_makprom (SCM code
)
3690 SCM_RETURN_NEWSMOB (scm_tc16_promise
, code
);
3696 prinprom (SCM exp
,SCM port
,scm_print_state
*pstate
)
3698 int writingp
= SCM_WRITINGP (pstate
);
3699 scm_puts ("#<promise ", port
);
3700 SCM_SET_WRITINGP (pstate
, 1);
3701 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3702 SCM_SET_WRITINGP (pstate
, writingp
);
3703 scm_putc ('>', port
);
3708 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3711 #define FUNC_NAME s_scm_force
3713 SCM_VALIDATE_SMOB (1,x
,promise
);
3714 if (!((1L << 16) & SCM_CARW (x
)))
3716 SCM ans
= scm_apply (SCM_CDR (x
), SCM_EOL
, SCM_EOL
);
3717 if (!((1L << 16) & SCM_CARW (x
)))
3720 SCM_SETCDR (x
, ans
);
3721 SCM_SETOR_CAR (x
, (1L << 16));
3729 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3731 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3732 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3733 #define FUNC_NAME s_scm_promise_p
3735 return SCM_BOOL(SCM_NIMP (x
) && (SCM_TYP16 (x
) == scm_tc16_promise
));
3739 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3740 (SCM xorig
, SCM x
, SCM y
),
3742 #define FUNC_NAME s_scm_cons_source
3748 /* Copy source properties possibly associated with xorig. */
3749 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3751 scm_whash_insert (scm_source_whash
, z
, p
);
3756 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3758 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3759 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3760 "contents of both pairs and vectors (since both cons cells and vector\n"
3761 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3762 "any other object.")
3763 #define FUNC_NAME s_scm_copy_tree
3768 if (SCM_VECTORP (obj
))
3770 scm_sizet i
= SCM_LENGTH (obj
);
3771 ans
= scm_make_vector (SCM_MAKINUM (i
), SCM_UNSPECIFIED
);
3773 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3776 if (SCM_NCONSP (obj
))
3778 /* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */
3779 ans
= tl
= scm_cons_source (obj
,
3780 scm_copy_tree (SCM_CAR (obj
)),
3782 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3784 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3788 SCM_SETCDR (tl
, obj
);
3795 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
3797 if (SCM_NIMP (SCM_CDR (scm_system_transformer
)))
3798 obj
= scm_apply (SCM_CDR (scm_system_transformer
), obj
, scm_listofnull
);
3800 obj
= scm_copy_tree (obj
);
3801 return SCM_XEVAL (obj
, env
);
3804 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
3805 (SCM obj
, SCM env_thunk
),
3806 "Evaluate @var{exp}, a Scheme expression, in the environment designated\n"
3807 "by @var{lookup}, a symbol-lookup function. @code{(eval exp)} is\n"
3808 "equivalent to @code{(eval2 exp *top-level-lookup-closure*)}.")
3809 #define FUNC_NAME s_scm_eval2
3811 return scm_eval_3 (obj
, 1, scm_top_level_env (env_thunk
));
3815 SCM_DEFINE (scm_eval
, "eval", 1, 0, 0,
3817 "Evaluate @var{exp}, a list representing a Scheme expression, in the\n"
3818 "top-level environment.")
3819 #define FUNC_NAME s_scm_eval
3821 return scm_eval_3 (obj
,
3824 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3829 SCM_REGISTER_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x);
3833 scm_eval_x (SCM obj
)
3835 return scm_eval_3 (obj
,
3838 (SCM_CDR (scm_top_level_lookup_closure_var
)));
3842 /* At this point, scm_deval and scm_dapply are generated.
3845 #ifdef DEBUG_EXTENSIONS
3855 scm_init_opts (scm_evaluator_traps
,
3856 scm_evaluator_trap_table
,
3857 SCM_N_EVALUATOR_TRAPS
);
3858 scm_init_opts (scm_eval_options_interface
,
3860 SCM_N_EVAL_OPTIONS
);
3862 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
3863 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
3864 scm_set_smob_print (scm_tc16_promise
, prinprom
);
3866 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
3867 scm_system_transformer
= scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED
);
3868 scm_sym_dot
= SCM_CAR (scm_sysintern (".", SCM_UNDEFINED
));
3869 scm_sym_arrow
= SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED
));
3870 scm_sym_else
= SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED
));
3871 scm_sym_unquote
= SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED
));
3872 scm_sym_uq_splicing
= SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED
));
3874 scm_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
3875 SCM_SETCDR (scm_nil
, SCM_CAR (scm_nil
));
3876 scm_nil
= SCM_CAR (scm_nil
);
3877 scm_t
= scm_sysintern ("t", SCM_UNDEFINED
);
3878 SCM_SETCDR (scm_t
, SCM_CAR (scm_t
));
3879 scm_t
= SCM_CAR (scm_t
);
3884 scm_top_level_lookup_closure_var
=
3885 scm_sysintern("*top-level-lookup-closure*", SCM_BOOL_F
);
3886 scm_can_use_top_level_lookup_closure_var
= 1;
3888 #ifdef DEBUG_EXTENSIONS
3889 scm_sym_enter_frame
= SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED
));
3890 scm_sym_apply_frame
= SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED
));
3891 scm_sym_exit_frame
= SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED
));
3892 scm_sym_trace
= SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED
));
3897 scm_add_feature ("delay");