1 /* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 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 "libguile/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 */
81 #include "libguile/_scm.h"
82 #include "libguile/debug.h"
83 #include "libguile/dynwind.h"
84 #include "libguile/alist.h"
85 #include "libguile/eq.h"
86 #include "libguile/continuations.h"
87 #include "libguile/throw.h"
88 #include "libguile/smob.h"
89 #include "libguile/macros.h"
90 #include "libguile/procprop.h"
91 #include "libguile/hashtab.h"
92 #include "libguile/hash.h"
93 #include "libguile/srcprop.h"
94 #include "libguile/stackchk.h"
95 #include "libguile/objects.h"
96 #include "libguile/async.h"
97 #include "libguile/feature.h"
98 #include "libguile/modules.h"
99 #include "libguile/ports.h"
100 #include "libguile/root.h"
101 #include "libguile/vectors.h"
102 #include "libguile/fluids.h"
104 #include "libguile/validate.h"
105 #include "libguile/eval.h"
109 /* The evaluator contains a plethora of EVAL symbols.
110 * This is an attempt at explanation.
112 * The following macros should be used in code which is read twice
113 * (where the choice of evaluator is hard soldered):
115 * SCM_CEVAL is the symbol used within one evaluator to call itself.
116 * Originally, it is defined to scm_ceval, but is redefined to
117 * scm_deval during the second pass.
119 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
120 * only side effects of expressions matter. All immediates are
123 * SCM_EVALIM is used when it is known that the expression is an
124 * immediate. (This macro never calls an evaluator.)
126 * EVALCAR evaluates the car of an expression.
128 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
129 * car is a lisp cell.
131 * The following macros should be used in code which is read once
132 * (where the choice of evaluator is dynamic):
134 * SCM_XEVAL takes care of immediates without calling an evaluator. It
135 * then calls scm_ceval *or* scm_deval, depending on the debugging
138 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
139 * depending on the debugging mode.
141 * The main motivation for keeping this plethora is efficiency
142 * together with maintainability (=> locality of code).
145 #define SCM_CEVAL scm_ceval
146 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
148 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
149 ? *scm_lookupcar (x, env, 1) \
150 : SCM_CEVAL (SCM_CAR (x), env))
152 #define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \
153 ? (SCM_IMP (SCM_CAR (x)) \
154 ? SCM_EVALIM (SCM_CAR (x), env) \
155 : SCM_GLOC_VAL (SCM_CAR (x))) \
156 : EVALCELLCAR (x, env))
158 #define EXTEND_ENV SCM_EXTEND_ENV
160 #ifdef MEMOIZE_LOCALS
163 scm_ilookup (SCM iloc
, SCM env
)
165 register int ir
= SCM_IFRAME (iloc
);
166 register SCM er
= env
;
167 for (; 0 != ir
; --ir
)
170 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
172 if (SCM_ICDRP (iloc
))
173 return SCM_CDRLOC (er
);
174 return SCM_CARLOC (SCM_CDR (er
));
180 /* The Lookup Car Race
183 Memoization of variables and special forms is done while executing
184 the code for the first time. As long as there is only one thread
185 everything is fine, but as soon as two threads execute the same
186 code concurrently `for the first time' they can come into conflict.
188 This memoization includes rewriting variable references into more
189 efficient forms and expanding macros. Furthermore, macro expansion
190 includes `compiling' special forms like `let', `cond', etc. into
191 tree-code instructions.
193 There shouldn't normally be a problem with memoizing local and
194 global variable references (into ilocs and glocs), because all
195 threads will mutate the code in *exactly* the same way and (if I
196 read the C code correctly) it is not possible to observe a half-way
197 mutated cons cell. The lookup procedure can handle this
198 transparently without any critical sections.
200 It is different with macro expansion, because macro expansion
201 happens outside of the lookup procedure and can't be
202 undone. Therefore it can't cope with it. It has to indicate
203 failure when it detects a lost race and hope that the caller can
204 handle it. Luckily, it turns out that this is the case.
206 An example to illustrate this: Suppose that the follwing form will
207 be memoized concurrently by two threads
211 Let's first examine the lookup of X in the body. The first thread
212 decides that it has to find the symbol "x" in the environment and
213 starts to scan it. Then the other thread takes over and actually
214 overtakes the first. It looks up "x" and substitutes an
215 appropriate iloc for it. Now the first thread continues and
216 completes its lookup. It comes to exactly the same conclusions as
217 the second one and could - without much ado - just overwrite the
218 iloc with the same iloc.
220 But let's see what will happen when the race occurs while looking
221 up the symbol "let" at the start of the form. It could happen that
222 the second thread interrupts the lookup of the first thread and not
223 only substitutes a gloc for it but goes right ahead and replaces it
224 with the compiled form (#@let* (x 12) x). Now, when the first
225 thread completes its lookup, it would replace the #@let* with a
226 gloc pointing to the "let" binding, effectively reverting the form
227 to (let (x 12) x). This is wrong. It has to detect that it has
228 lost the race and the evaluator has to reconsider the changed form
231 This race condition could be resolved with some kind of traffic
232 light (like mutexes) around scm_lookupcar, but I think that it is
233 best to avoid them in this case. They would serialize memoization
234 completely and because lookup involves calling arbitrary Scheme
235 code (via the lookup-thunk), threads could be blocked for an
236 arbitrary amount of time or even deadlock. But with the current
237 solution a lot of unnecessary work is potentially done. */
239 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
240 return NULL to indicate a failed lookup due to some race conditions
241 between threads. This only happens when VLOC is the first cell of
242 a special form that will eventually be memoized (like `let', etc.)
243 In that case the whole lookup is bogus and the caller has to
244 reconsider the complete special form.
246 SCM_LOOKUPCAR is still there, of course. It just calls
247 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
248 should only be called when it is known that VLOC is not the first
249 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
250 for NULL. I think I've found the only places where this
253 #endif /* USE_THREADS */
255 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
259 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
262 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
266 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
268 register SCM var2
= var
;
270 #ifdef MEMOIZE_LOCALS
271 register SCM iloc
= SCM_ILOC00
;
273 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
275 if (!SCM_CONSP (SCM_CAR (env
)))
277 al
= SCM_CARLOC (env
);
278 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
282 if (SCM_EQ_P (fl
, var
))
284 #ifdef MEMOIZE_LOCALS
286 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
289 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
291 return SCM_CDRLOC (*al
);
296 al
= SCM_CDRLOC (*al
);
297 if (SCM_EQ_P (SCM_CAR (fl
), var
))
299 #ifdef MEMOIZE_LOCALS
300 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
301 if (SCM_UNBNDP (SCM_CAR (*al
)))
308 if (SCM_CAR (vloc
) != var
)
311 SCM_SETCAR (vloc
, iloc
);
313 return SCM_CARLOC (*al
);
315 #ifdef MEMOIZE_LOCALS
316 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
319 #ifdef MEMOIZE_LOCALS
320 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
324 SCM top_thunk
, vcell
;
327 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
331 top_thunk
= SCM_BOOL_F
;
332 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
333 if (SCM_FALSEP (vcell
))
339 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
343 /* scm_everr (vloc, genv,...) */
347 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
348 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
350 scm_misc_error (NULL
, "Damaged environment: ~S",
351 scm_cons (var
, SCM_EOL
));
354 /* A variable could not be found, but we shall not throw an error. */
355 static SCM undef_object
= SCM_UNDEFINED
;
356 return &undef_object
;
361 if (SCM_CAR (vloc
) != var2
)
363 /* Some other thread has changed the very cell we are working
364 on. In effect, it must have done our job or messed it up
367 var
= SCM_CAR (vloc
);
368 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
369 return SCM_GLOC_VAL_LOC (var
);
370 #ifdef MEMOIZE_LOCALS
371 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
372 return scm_ilookup (var
, genv
);
374 /* We can't cope with anything else than glocs and ilocs. When
375 a special form has been memoized (i.e. `let' into `#@let') we
376 return NULL and expect the calling function to do the right
377 thing. For the evaluator, this means going back and redoing
378 the dispatch on the car of the form. */
381 #endif /* USE_THREADS */
383 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
384 /* Except wait...what if the var is not a vcell,
385 * but syntax or something.... */
386 return SCM_CDRLOC (var
);
391 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
393 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
400 #define unmemocar scm_unmemocar
403 scm_unmemocar (SCM form
, SCM env
)
410 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
411 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
412 #ifdef MEMOIZE_LOCALS
413 #ifdef DEBUG_EXTENSIONS
414 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_duplicate_bindings
[] = "duplicate bindings";
448 const char scm_s_variable
[] = "bad variable";
449 const char scm_s_clauses
[] = "bad or missing clauses";
450 const char scm_s_formals
[] = "bad formals";
451 const char scm_s_duplicate_formals
[] = "duplicate formals";
453 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
454 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
455 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
456 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
457 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
461 #ifdef DEBUG_EXTENSIONS
462 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
463 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
464 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
465 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
469 /* Check that the body denoted by XORIG is valid and rewrite it into
470 its internal form. The internal form of a body is just the body
471 itself, but prefixed with an ISYM that denotes to what kind of
472 outer construct this body belongs. A lambda body starts with
473 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
474 etc. The one exception is a body that belongs to a letrec that has
475 been formed by rewriting internal defines: it starts with
478 /* XXX - Besides controlling the rewriting of internal defines, the
479 additional ISYM could be used for improved error messages.
480 This is not done yet. */
483 scm_m_body (SCM op
, SCM xorig
, const char *what
)
485 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_expression
, what
);
487 /* Don't add another ISYM if one is present already. */
488 if (SCM_ISYMP (SCM_CAR (xorig
)))
491 /* Retain possible doc string. */
492 if (!SCM_CONSP (SCM_CAR (xorig
)))
494 if (SCM_NNULLP (SCM_CDR(xorig
)))
495 return scm_cons (SCM_CAR (xorig
),
496 scm_m_body (op
, SCM_CDR(xorig
), what
));
500 return scm_cons (op
, xorig
);
503 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
504 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
507 scm_m_quote (SCM xorig
, SCM env
)
509 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
511 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
512 return scm_cons (SCM_IM_QUOTE
, x
);
517 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
518 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
521 scm_m_begin (SCM xorig
, SCM env
)
523 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, scm_s_expression
, s_begin
);
524 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
527 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
528 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
531 scm_m_if (SCM xorig
, SCM env
)
533 int len
= scm_ilength (SCM_CDR (xorig
));
534 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, "if");
535 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
539 /* Will go into the RnRS module when Guile is factorized.
540 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
541 const char scm_s_set_x
[] = "set!";
542 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
545 scm_m_set_x (SCM xorig
, SCM env
)
547 SCM x
= SCM_CDR (xorig
);
548 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, scm_s_set_x
);
549 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
550 return scm_cons (SCM_IM_SET_X
, x
);
554 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
555 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
558 scm_m_and (SCM xorig
, SCM env
)
560 int len
= scm_ilength (SCM_CDR (xorig
));
561 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
563 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
568 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
569 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
572 scm_m_or (SCM xorig
, SCM env
)
574 int len
= scm_ilength (SCM_CDR (xorig
));
575 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
577 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
583 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
584 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
587 scm_m_case (SCM xorig
, SCM env
)
589 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
590 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_clauses
, s_case
);
591 while (SCM_NIMP (x
= SCM_CDR (x
)))
594 SCM_ASSYNT (scm_ilength (proc
) >= 2, scm_s_clauses
, s_case
);
595 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
596 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
597 && SCM_NULLP (SCM_CDR (x
))),
598 scm_s_clauses
, s_case
);
600 return scm_cons (SCM_IM_CASE
, cdrx
);
604 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
605 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
609 scm_m_cond (SCM xorig
, SCM env
)
611 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
612 int len
= scm_ilength (x
);
613 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
617 len
= scm_ilength (arg1
);
618 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
619 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
621 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
622 "bad ELSE clause", s_cond
);
623 SCM_SETCAR (arg1
, SCM_BOOL_T
);
625 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
626 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
627 "bad recipient", s_cond
);
630 return scm_cons (SCM_IM_COND
, cdrx
);
633 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
634 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
636 /* Return #t if OBJ is `eq?' to one of the elements of LIST or to the
637 cdr of the last cons. (Thus, LIST is not required to be a proper
638 list and when OBJ also found in the improper ending.) */
641 scm_c_improper_memq (SCM obj
, SCM list
)
643 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
645 if (SCM_EQ_P (SCM_CAR (list
), obj
))
648 return SCM_EQ_P (list
, obj
);
652 scm_m_lambda (SCM xorig
, SCM env
)
654 SCM proc
, x
= SCM_CDR (xorig
);
655 if (scm_ilength (x
) < 2)
658 if (SCM_NULLP (proc
))
660 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
664 if (SCM_SYMBOLP (proc
))
666 if (SCM_NCONSP (proc
))
668 while (SCM_NIMP (proc
))
670 if (SCM_NCONSP (proc
))
672 if (!SCM_SYMBOLP (proc
))
677 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
679 else if (scm_c_improper_memq (SCM_CAR(proc
), SCM_CDR(proc
)))
680 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
681 proc
= SCM_CDR (proc
);
683 if (SCM_NNULLP (proc
))
686 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
690 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
691 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
694 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
695 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
699 scm_m_letstar (SCM xorig
, SCM env
)
701 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
702 int len
= scm_ilength (x
);
703 SCM_ASSYNT (len
>= 2, scm_s_body
, s_letstar
);
705 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_letstar
);
706 while (SCM_NIMP (proc
))
708 arg1
= SCM_CAR (proc
);
709 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_letstar
);
710 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_letstar
);
711 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
712 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
713 proc
= SCM_CDR (proc
);
715 x
= scm_cons (vars
, SCM_CDR (x
));
717 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
718 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
721 /* DO gets the most radically altered syntax
722 (do ((<var1> <init1> <step1>)
728 (do_mem (varn ... var2 var1)
729 (<init1> <init2> ... <initn>)
732 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
735 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
736 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
739 scm_m_do (SCM xorig
, SCM env
)
741 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
742 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
743 SCM
*initloc
= &inits
, *steploc
= &steps
;
744 int len
= scm_ilength (x
);
745 SCM_ASSYNT (len
>= 2, scm_s_test
, "do");
747 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, "do");
748 while (SCM_NIMP(proc
))
750 arg1
= SCM_CAR (proc
);
751 len
= scm_ilength (arg1
);
752 SCM_ASSYNT (2 == len
|| 3 == len
, scm_s_bindings
, "do");
753 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, "do");
754 /* vars reversed here, inits and steps reversed at evaluation */
755 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
756 arg1
= SCM_CDR (arg1
);
757 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
758 initloc
= SCM_CDRLOC (*initloc
);
759 arg1
= SCM_CDR (arg1
);
760 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
761 steploc
= SCM_CDRLOC (*steploc
);
762 proc
= SCM_CDR (proc
);
765 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
766 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
767 x
= scm_cons2 (vars
, inits
, x
);
768 return scm_cons (SCM_IM_DO
, x
);
771 /* evalcar is small version of inline EVALCAR when we don't care about
774 #define evalcar scm_eval_car
777 static SCM
iqq (SCM form
, SCM env
, int depth
);
779 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
780 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
783 scm_m_quasiquote (SCM xorig
, SCM env
)
785 SCM x
= SCM_CDR (xorig
);
786 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
787 return iqq (SCM_CAR (x
), env
, 1);
792 iqq (SCM form
,SCM env
,int depth
)
798 if (SCM_VECTORP (form
))
800 long i
= SCM_VECTOR_LENGTH (form
);
801 SCM
*data
= SCM_VELTS (form
);
804 tmp
= scm_cons (data
[i
], tmp
);
805 return scm_vector (iqq (tmp
, env
, depth
));
807 if (SCM_NCONSP(form
))
809 tmp
= SCM_CAR (form
);
810 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
815 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
819 form
= SCM_CDR (form
);
820 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
821 form
, SCM_ARG1
, s_quasiquote
);
823 return evalcar (form
, env
);
824 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
826 if (SCM_NIMP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
830 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
832 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
835 /* Here are acros which return values rather than code. */
837 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
838 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
841 scm_m_delay (SCM xorig
, SCM env
)
843 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
844 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
848 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
849 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
852 scm_m_define (SCM x
, SCM env
)
856 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
859 while (SCM_CONSP (proc
))
860 { /* nested define syntax */
861 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
862 proc
= SCM_CAR (proc
);
864 SCM_ASSYNT (SCM_SYMBOLP (proc
), scm_s_variable
, s_define
);
865 SCM_ASSYNT (1 == scm_ilength (x
), scm_s_expression
, s_define
);
866 if (SCM_TOP_LEVEL (env
))
868 x
= evalcar (x
, env
);
869 #ifdef DEBUG_EXTENSIONS
870 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
874 if (SCM_CLOSUREP (arg1
)
875 /* Only the first definition determines the name. */
876 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
877 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
878 else if (SCM_TYP16 (arg1
) == scm_tc16_macro
879 && !SCM_EQ_P (SCM_CDR (arg1
), arg1
))
881 arg1
= SCM_CDR (arg1
);
886 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
887 SCM_SETCDR (arg1
, x
);
889 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
891 return SCM_UNSPECIFIED
;
894 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
900 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
902 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
903 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
904 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
905 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
908 SCM_ASSYNT (scm_ilength (proc
) >= 1, scm_s_bindings
, what
);
911 /* vars scm_list reversed here, inits reversed at evaluation */
912 arg1
= SCM_CAR (proc
);
913 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, what
);
914 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, what
);
915 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
916 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
917 vars
= scm_cons (SCM_CAR (arg1
), vars
);
918 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
919 initloc
= SCM_CDRLOC (*initloc
);
921 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
923 return scm_cons2 (op
, vars
,
924 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
927 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
928 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
931 scm_m_letrec (SCM xorig
, SCM env
)
933 SCM x
= SCM_CDR (xorig
);
934 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_letrec
);
936 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
937 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
938 scm_m_body (SCM_IM_LETREC
,
943 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
946 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
947 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
950 scm_m_let (SCM xorig
, SCM env
)
952 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
953 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
954 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
956 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
960 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
962 /* null or single binding, let* is faster */
963 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
964 scm_m_body (SCM_IM_LET
,
970 SCM_ASSYNT (SCM_NIMP (proc
), scm_s_bindings
, s_let
);
971 if (SCM_CONSP (proc
))
973 /* plain let, proc is <bindings> */
974 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
977 if (!SCM_SYMBOLP (proc
))
978 scm_misc_error (s_let
, scm_s_bindings
, SCM_EOL
); /* bad let */
979 name
= proc
; /* named let, build equiv letrec */
981 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
982 proc
= SCM_CAR (x
); /* bindings list */
983 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_let
);
984 while (SCM_NIMP (proc
))
985 { /* vars and inits both in order */
986 arg1
= SCM_CAR (proc
);
987 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_let
);
988 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_let
);
989 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
990 varloc
= SCM_CDRLOC (*varloc
);
991 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
992 initloc
= SCM_CDRLOC (*initloc
);
993 proc
= SCM_CDR (proc
);
996 proc
= scm_cons2 (scm_sym_lambda
, vars
,
997 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
998 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1000 scm_acons (name
, inits
, SCM_EOL
));
1001 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1005 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1006 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1007 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1010 scm_m_apply (SCM xorig
, SCM env
)
1012 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1013 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1017 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1018 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1022 scm_m_cont (SCM xorig
, SCM env
)
1024 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1025 scm_s_expression
, s_atcall_cc
);
1026 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1029 /* Multi-language support */
1034 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1037 scm_m_nil_cond (SCM xorig
, SCM env
)
1039 int len
= scm_ilength (SCM_CDR (xorig
));
1040 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1041 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1044 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1047 scm_m_nil_ify (SCM xorig
, SCM env
)
1049 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1050 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1053 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1056 scm_m_t_ify (SCM xorig
, SCM env
)
1058 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1059 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1062 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1065 scm_m_0_cond (SCM xorig
, SCM env
)
1067 int len
= scm_ilength (SCM_CDR (xorig
));
1068 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1069 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1072 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1075 scm_m_0_ify (SCM xorig
, SCM env
)
1077 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1078 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1081 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1084 scm_m_1_ify (SCM xorig
, SCM env
)
1086 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1087 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1090 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1093 scm_m_atfop (SCM xorig
, SCM env
)
1095 SCM x
= SCM_CDR (xorig
), vcell
;
1096 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1097 vcell
= scm_symbol_fref (SCM_CAR (x
));
1098 SCM_ASSYNT (SCM_CONSP (vcell
),
1099 "Symbol's function definition is void", NULL
);
1100 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1104 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1107 scm_m_atbind (SCM xorig
, SCM env
)
1109 SCM x
= SCM_CDR (xorig
);
1110 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, "@bind");
1116 while (SCM_NIMP (SCM_CDR (env
)))
1117 env
= SCM_CDR (env
);
1118 env
= SCM_CAR (env
);
1119 if (SCM_CONSP (env
))
1124 while (SCM_NIMP (x
))
1126 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1129 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1133 scm_m_expand_body (SCM xorig
, SCM env
)
1135 SCM form
, x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1136 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1138 while (SCM_NIMP (x
))
1141 if (SCM_IMP (form
) || SCM_NCONSP (form
))
1143 if (SCM_IMP (SCM_CAR (form
)))
1145 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1148 form
= scm_macroexp (scm_cons_source (form
,
1153 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1155 defs
= scm_cons (SCM_CDR (form
), defs
);
1158 else if (SCM_NIMP(defs
))
1162 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1164 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1168 x
= scm_cons (form
, SCM_CDR(x
));
1173 SCM_ASSYNT (SCM_NIMP (x
), scm_s_body
, what
);
1174 if (SCM_NIMP (defs
))
1176 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1178 scm_cons2 (scm_sym_define
, defs
, x
),
1184 SCM_SETCAR (xorig
, SCM_CAR (x
));
1185 SCM_SETCDR (xorig
, SCM_CDR (x
));
1192 scm_macroexp (SCM x
, SCM env
)
1196 /* Don't bother to produce error messages here. We get them when we
1197 eventually execute the code for real. */
1200 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1205 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1206 if (proc_ptr
== NULL
)
1208 /* We have lost the race. */
1214 proc
= *scm_lookupcar (x
, env
, 0);
1217 /* Only handle memoizing macros. `Acros' and `macros' are really
1218 special forms and should not be evaluated here. */
1221 || scm_tc16_macro
!= SCM_TYP16 (proc
)
1222 || (SCM_CELL_WORD_0 (proc
) >> 16) != 2)
1226 res
= scm_apply (SCM_CDR (proc
), x
, scm_cons (env
, scm_listofnull
));
1228 if (scm_ilength (res
) <= 0)
1229 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1232 SCM_SETCAR (x
, SCM_CAR (res
));
1233 SCM_SETCDR (x
, SCM_CDR (res
));
1239 /* scm_unmemocopy takes a memoized expression together with its
1240 * environment and rewrites it to its original form. Thus, it is the
1241 * inversion of the rewrite rules above. The procedure is not
1242 * optimized for speed. It's used in scm_iprin1 when printing the
1243 * code of a closure, in scm_procedure_source, in display_frame when
1244 * generating the source for a stackframe in a backtrace, and in
1245 * display_expression.
1248 /* We should introduce an anti-macro interface so that it is possible
1249 * to plug in transformers in both directions from other compilation
1250 * units. unmemocopy could then dispatch to anti-macro transformers.
1251 * (Those transformers could perhaps be written in slightly more
1252 * readable style... :)
1255 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1258 unmemocopy (SCM x
, SCM env
)
1261 #ifdef DEBUG_EXTENSIONS
1264 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1266 #ifdef DEBUG_EXTENSIONS
1267 p
= scm_whash_lookup (scm_source_whash
, x
);
1269 switch (SCM_TYP7 (x
))
1271 case SCM_BIT8(SCM_IM_AND
):
1272 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1274 case SCM_BIT8(SCM_IM_BEGIN
):
1275 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1277 case SCM_BIT8(SCM_IM_CASE
):
1278 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1280 case SCM_BIT8(SCM_IM_COND
):
1281 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1283 case SCM_BIT8(SCM_IM_DO
):
1284 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1286 case SCM_BIT8(SCM_IM_IF
):
1287 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1289 case SCM_BIT8(SCM_IM_LET
):
1290 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1292 case SCM_BIT8(SCM_IM_LETREC
):
1295 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1299 f
= v
= SCM_CAR (x
);
1301 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1303 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1304 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1307 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1308 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1310 /* build transformed binding list */
1312 while (SCM_NIMP (v
))
1314 z
= scm_acons (SCM_CAR (v
),
1315 scm_cons (SCM_CAR (e
),
1316 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1318 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1324 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1326 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1330 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1333 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1334 /* body forms are now to be found in SCM_CDR (x)
1335 (this is how *real* code look like! :) */
1339 case SCM_BIT8(SCM_IM_LETSTAR
):
1347 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1350 y
= z
= scm_acons (SCM_CAR (b
),
1352 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1354 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1355 b
= SCM_CDR (SCM_CDR (b
));
1358 SCM_SETCDR (y
, SCM_EOL
);
1359 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1364 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1366 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1369 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1370 b
= SCM_CDR (SCM_CDR (b
));
1372 while (SCM_NIMP (b
));
1373 SCM_SETCDR (z
, SCM_EOL
);
1375 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1378 case SCM_BIT8(SCM_IM_OR
):
1379 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1381 case SCM_BIT8(SCM_IM_LAMBDA
):
1383 ls
= scm_cons (scm_sym_lambda
,
1384 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1385 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1387 case SCM_BIT8(SCM_IM_QUOTE
):
1388 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1390 case SCM_BIT8(SCM_IM_SET_X
):
1391 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1393 case SCM_BIT8(SCM_IM_DEFINE
):
1397 ls
= scm_cons (scm_sym_define
,
1398 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1399 if (SCM_NNULLP (env
))
1400 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1403 case SCM_BIT8(SCM_MAKISYM (0)):
1407 switch (SCM_ISYMNUM (z
))
1409 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1410 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1412 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1413 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1415 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1416 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1420 /* appease the Sun compiler god: */ ;
1424 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1429 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1431 if (SCM_ISYMP (SCM_CAR (x
)))
1432 /* skip body markers */
1434 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1440 #ifdef DEBUG_EXTENSIONS
1441 if (SCM_NFALSEP (p
))
1442 scm_whash_insert (scm_source_whash
, ls
, p
);
1449 scm_unmemocopy (SCM x
, SCM env
)
1451 if (SCM_NNULLP (env
))
1452 /* Make a copy of the lowest frame to protect it from
1453 modifications by SCM_IM_DEFINE */
1454 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1456 return unmemocopy (x
, env
);
1459 #ifndef SCM_RECKLESS
1462 scm_badargsp (SCM formals
, SCM args
)
1464 while (SCM_NIMP (formals
))
1466 if (SCM_NCONSP (formals
))
1470 formals
= SCM_CDR (formals
);
1471 args
= SCM_CDR (args
);
1473 return SCM_NNULLP (args
) ? 1 : 0;
1478 scm_badformalsp (SCM closure
, int n
)
1480 SCM formals
= SCM_CAR (SCM_CODE (closure
));
1481 while (SCM_NIMP (formals
))
1483 if (SCM_NCONSP (formals
))
1488 formals
= SCM_CDR (formals
);
1495 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1497 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1498 while (SCM_NIMP (l
))
1503 if (SCM_IMP (SCM_CAR (l
)))
1504 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1506 res
= EVALCELLCAR (l
, env
);
1508 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1510 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1512 res
= SCM_CAR (l
); /* struct planted in code */
1514 res
= SCM_PACK (vcell
);
1519 res
= EVALCAR (l
, env
);
1521 *lloc
= scm_cons (res
, SCM_EOL
);
1522 lloc
= SCM_CDRLOC (*lloc
);
1529 scm_wrong_num_args (proc
);
1536 scm_eval_body (SCM code
, SCM env
)
1541 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1543 if (SCM_IMP (SCM_CAR (code
)))
1545 if (SCM_ISYMP (SCM_CAR (code
)))
1547 code
= scm_m_expand_body (code
, env
);
1552 SCM_XEVAL (SCM_CAR (code
), env
);
1555 return SCM_XEVALCAR (code
, env
);
1562 /* SECTION: This code is specific for the debugging support. One
1563 * branch is read when DEVAL isn't defined, the other when DEVAL is
1569 #define SCM_APPLY scm_apply
1570 #define PREP_APPLY(proc, args)
1572 #define RETURN(x) return x;
1573 #ifdef STACK_CHECKING
1574 #ifndef NO_CEVAL_STACK_CHECKING
1575 #define EVAL_STACK_CHECKING
1582 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1584 #define SCM_APPLY scm_dapply
1586 #define PREP_APPLY(p, l) \
1587 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1589 #define ENTER_APPLY \
1591 SCM_SET_ARGSREADY (debug);\
1592 if (CHECK_APPLY && SCM_TRAPS_P)\
1593 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1595 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1596 SCM_SET_TRACED_FRAME (debug); \
1597 if (SCM_CHEAPTRAPS_P)\
1599 tmp = scm_make_debugobj (&debug);\
1600 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1605 tmp = scm_make_continuation (&first);\
1607 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1612 #define RETURN(e) {proc = (e); goto exit;}
1613 #ifdef STACK_CHECKING
1614 #ifndef EVAL_STACK_CHECKING
1615 #define EVAL_STACK_CHECKING
1619 /* scm_ceval_ptr points to the currently selected evaluator.
1620 * *fixme*: Although efficiency is important here, this state variable
1621 * should probably not be a global. It should be related to the
1626 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1628 /* scm_last_debug_frame contains a pointer to the last debugging
1629 * information stack frame. It is accessed very often from the
1630 * debugging evaluator, so it should probably not be indirectly
1631 * addressed. Better to save and restore it from the current root at
1636 scm_debug_frame
*scm_last_debug_frame
;
1639 /* scm_debug_eframe_size is the number of slots available for pseudo
1640 * stack frames at each real stack frame.
1643 int scm_debug_eframe_size
;
1645 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1649 scm_option scm_eval_opts
[] = {
1650 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1653 scm_option scm_debug_opts
[] = {
1654 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1655 "*Flyweight representation of the stack at traps." },
1656 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1657 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1658 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1659 "Record procedure names at definition." },
1660 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1661 "Display backtrace in anti-chronological order." },
1662 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1663 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1664 { SCM_OPTION_INTEGER
, "frames", 3,
1665 "Maximum number of tail-recursive frames in backtrace." },
1666 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1667 "Maximal number of stored backtrace frames." },
1668 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1669 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1670 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1671 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1674 scm_option scm_evaluator_trap_table
[] = {
1675 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1676 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1677 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1678 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1681 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1683 "Option interface for the evaluation options. Instead of using\n"
1684 "this procedure directly, use the procedures @code{eval-enable},\n"
1685 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1686 #define FUNC_NAME s_scm_eval_options_interface
1690 ans
= scm_options (setting
,
1694 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1700 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1702 "Option interface for the evaluator trap options.")
1703 #define FUNC_NAME s_scm_evaluator_traps
1707 ans
= scm_options (setting
,
1708 scm_evaluator_trap_table
,
1709 SCM_N_EVALUATOR_TRAPS
,
1711 SCM_RESET_DEBUG_MODE
;
1718 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1720 SCM
*results
= lloc
, res
;
1721 while (SCM_NIMP (l
))
1726 if (SCM_IMP (SCM_CAR (l
)))
1727 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1729 res
= EVALCELLCAR (l
, env
);
1731 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1733 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1735 res
= SCM_CAR (l
); /* struct planted in code */
1737 res
= SCM_PACK (vcell
);
1742 res
= EVALCAR (l
, env
);
1744 *lloc
= scm_cons (res
, SCM_EOL
);
1745 lloc
= SCM_CDRLOC (*lloc
);
1752 scm_wrong_num_args (proc
);
1761 /* SECTION: Some local definitions for the evaluator.
1764 /* Update the toplevel environment frame ENV so that it refers to the
1767 #define UPDATE_TOPLEVEL_ENV(env) \
1769 SCM p = scm_current_module_lookup_closure (); \
1770 if (p != SCM_CAR(env)) \
1771 env = scm_top_level_env (p); \
1775 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1778 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1780 /* SECTION: This is the evaluator. Like any real monster, it has
1781 * three heads. This code is compiled twice.
1787 scm_ceval (SCM x
, SCM env
)
1793 scm_deval (SCM x
, SCM env
)
1798 SCM_CEVAL (SCM x
, SCM env
)
1807 scm_debug_frame debug
;
1808 scm_debug_info
*debug_info_end
;
1809 debug
.prev
= scm_last_debug_frame
;
1810 debug
.status
= scm_debug_eframe_size
;
1812 * The debug.vect contains twice as much scm_debug_info frames as the
1813 * user has specified with (debug-set! frames <n>).
1815 * Even frames are eval frames, odd frames are apply frames.
1817 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1818 * sizeof (debug
.vect
[0]));
1819 debug
.info
= debug
.vect
;
1820 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1821 scm_last_debug_frame
= &debug
;
1823 #ifdef EVAL_STACK_CHECKING
1824 if (scm_stack_checking_enabled_p
1825 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1828 debug
.info
->e
.exp
= x
;
1829 debug
.info
->e
.env
= env
;
1831 scm_report_stack_overflow ();
1838 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1841 SCM_CLEAR_ARGSREADY (debug
);
1842 if (SCM_OVERFLOWP (debug
))
1845 * In theory, this should be the only place where it is necessary to
1846 * check for space in debug.vect since both eval frames and
1847 * available space are even.
1849 * For this to be the case, however, it is necessary that primitive
1850 * special forms which jump back to `loop', `begin' or some similar
1851 * label call PREP_APPLY. A convenient way to do this is to jump to
1852 * `loopnoap' or `cdrxnoap'.
1854 else if (++debug
.info
>= debug_info_end
)
1856 SCM_SET_OVERFLOW (debug
);
1860 debug
.info
->e
.exp
= x
;
1861 debug
.info
->e
.env
= env
;
1862 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1863 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1865 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1866 SCM_SET_TAILREC (debug
);
1867 if (SCM_CHEAPTRAPS_P
)
1868 t
.arg1
= scm_make_debugobj (&debug
);
1872 SCM val
= scm_make_continuation (&first
);
1884 /* This gives the possibility for the debugger to
1885 modify the source expression before evaluation. */
1889 scm_ithrow (scm_sym_enter_frame
,
1890 scm_cons2 (t
.arg1
, tail
,
1891 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1895 #if defined (USE_THREADS) || defined (DEVAL)
1899 switch (SCM_TYP7 (x
))
1901 case scm_tc7_symbol
:
1902 /* Only happens when called at top level.
1904 x
= scm_cons (x
, SCM_UNDEFINED
);
1907 case SCM_BIT8(SCM_IM_AND
):
1910 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1911 if (SCM_FALSEP (EVALCAR (x
, env
)))
1913 RETURN (SCM_BOOL_F
);
1917 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1920 case SCM_BIT8(SCM_IM_BEGIN
):
1921 /* (currently unused)
1923 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1924 /* (currently unused)
1929 /* If we are on toplevel with a lookup closure, we need to sync
1930 with the current module. */
1931 if (SCM_CONSP(env
) && !SCM_CONSP(SCM_CAR(env
)))
1934 UPDATE_TOPLEVEL_ENV (env
);
1935 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1939 UPDATE_TOPLEVEL_ENV (env
);
1944 goto nontoplevel_begin
;
1946 nontoplevel_cdrxnoap
:
1947 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1948 nontoplevel_cdrxbegin
:
1952 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1954 if (SCM_IMP (SCM_CAR (x
)))
1956 if (SCM_ISYMP (SCM_CAR (x
)))
1958 x
= scm_m_expand_body (x
, env
);
1959 goto nontoplevel_begin
;
1962 SCM_EVALIM2 (SCM_CAR(x
));
1965 SCM_CEVAL (SCM_CAR (x
), env
);
1969 carloop
: /* scm_eval car of last form in list */
1970 if (SCM_NCELLP (SCM_CAR (x
)))
1973 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1976 if (SCM_SYMBOLP (SCM_CAR (x
)))
1979 RETURN (*scm_lookupcar (x
, env
, 1))
1983 goto loop
; /* tail recurse */
1986 case SCM_BIT8(SCM_IM_CASE
):
1988 t
.arg1
= EVALCAR (x
, env
);
1989 while (SCM_NIMP (x
= SCM_CDR (x
)))
1992 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
1995 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1998 proc
= SCM_CAR (proc
);
1999 while (SCM_NIMP (proc
))
2001 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2003 x
= SCM_CDR (SCM_CAR (x
));
2004 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2007 proc
= SCM_CDR (proc
);
2010 RETURN (SCM_UNSPECIFIED
)
2013 case SCM_BIT8(SCM_IM_COND
):
2014 while (SCM_NIMP (x
= SCM_CDR (x
)))
2017 t
.arg1
= EVALCAR (proc
, env
);
2018 if (SCM_NFALSEP (t
.arg1
))
2025 if (! SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2027 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2031 proc
= EVALCAR (proc
, env
);
2032 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2033 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2035 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2036 goto umwrongnumargs
;
2040 RETURN (SCM_UNSPECIFIED
)
2043 case SCM_BIT8(SCM_IM_DO
):
2045 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2046 t
.arg1
= SCM_EOL
; /* values */
2047 while (SCM_NIMP (proc
))
2049 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2050 proc
= SCM_CDR (proc
);
2052 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2053 x
= SCM_CDR (SCM_CDR (x
));
2054 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2056 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2058 t
.arg1
= SCM_CAR (proc
); /* body */
2059 SIDEVAL (t
.arg1
, env
);
2061 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2063 proc
= SCM_CDR (proc
))
2064 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2065 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2069 RETURN (SCM_UNSPECIFIED
);
2070 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2071 goto nontoplevel_begin
;
2074 case SCM_BIT8(SCM_IM_IF
):
2076 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2078 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2080 RETURN (SCM_UNSPECIFIED
);
2082 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2086 case SCM_BIT8(SCM_IM_LET
):
2088 proc
= SCM_CAR (SCM_CDR (x
));
2092 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2094 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2095 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2097 goto nontoplevel_cdrxnoap
;
2100 case SCM_BIT8(SCM_IM_LETREC
):
2102 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2108 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2110 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2111 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2112 goto nontoplevel_cdrxnoap
;
2115 case SCM_BIT8(SCM_IM_LETSTAR
):
2120 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2121 goto nontoplevel_cdrxnoap
;
2125 t
.arg1
= SCM_CAR (proc
);
2126 proc
= SCM_CDR (proc
);
2127 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2129 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2130 goto nontoplevel_cdrxnoap
;
2132 case SCM_BIT8(SCM_IM_OR
):
2135 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2137 x
= EVALCAR (x
, env
);
2138 if (SCM_NFALSEP (x
))
2144 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2148 case SCM_BIT8(SCM_IM_LAMBDA
):
2149 RETURN (scm_closure (SCM_CDR (x
), env
));
2152 case SCM_BIT8(SCM_IM_QUOTE
):
2153 RETURN (SCM_CAR (SCM_CDR (x
)));
2156 case SCM_BIT8(SCM_IM_SET_X
):
2159 switch (SCM_ITAG3 (proc
))
2162 t
.lloc
= scm_lookupcar (x
, env
, 1);
2164 case scm_tc3_cons_gloc
:
2165 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2167 #ifdef MEMOIZE_LOCALS
2169 t
.lloc
= scm_ilookup (proc
, env
);
2174 *t
.lloc
= EVALCAR (x
, env
);
2178 RETURN (SCM_UNSPECIFIED
);
2182 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2183 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2185 /* new syntactic forms go here. */
2186 case SCM_BIT8(SCM_MAKISYM (0)):
2188 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2189 switch SCM_ISYMNUM (proc
)
2191 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2193 proc
= EVALCAR (proc
, env
);
2194 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2195 if (SCM_CLOSUREP (proc
))
2198 PREP_APPLY (proc
, SCM_EOL
);
2199 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2200 t
.arg1
= EVALCAR (t
.arg1
, env
);
2202 debug
.info
->a
.args
= t
.arg1
;
2204 #ifndef SCM_RECKLESS
2205 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), t
.arg1
))
2209 /* Copy argument list */
2210 if (SCM_IMP (t
.arg1
))
2214 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2215 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2216 && SCM_CONSP (t
.arg1
))
2218 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2222 SCM_SETCDR (tl
, t
.arg1
);
2225 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), argl
, SCM_ENV (proc
));
2226 x
= SCM_CODE (proc
);
2227 goto nontoplevel_cdrxbegin
;
2232 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2235 SCM val
= scm_make_continuation (&first
);
2243 proc
= evalcar (proc
, env
);
2244 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2245 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2247 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2248 goto umwrongnumargs
;
2251 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2252 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2254 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2255 proc
= SCM_CADR (x
); /* unevaluated operands */
2256 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2258 arg2
= *scm_ilookup (proc
, env
);
2259 else if (SCM_NCONSP (proc
))
2261 if (SCM_NCELLP (proc
))
2262 arg2
= SCM_GLOC_VAL (proc
);
2264 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2268 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2269 t
.lloc
= SCM_CDRLOC (arg2
);
2270 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2272 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2273 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2278 /* The type dispatch code is duplicated here
2279 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2280 * cuts down execution time for type dispatch to 50%.
2283 int i
, n
, end
, mask
;
2284 SCM z
= SCM_CDDR (x
);
2285 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2286 proc
= SCM_CADR (z
);
2288 if (SCM_NIMP (proc
))
2290 /* Prepare for linear search */
2293 end
= SCM_VECTOR_LENGTH (proc
);
2297 /* Compute a hash value */
2298 int hashset
= SCM_INUM (proc
);
2300 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2301 proc
= SCM_CADR (z
);
2304 if (SCM_NIMP (t
.arg1
))
2307 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2308 [scm_si_hashsets
+ hashset
];
2309 t
.arg1
= SCM_CDR (t
.arg1
);
2311 while (j
-- && SCM_NIMP (t
.arg1
));
2316 /* Search for match */
2320 z
= SCM_VELTS (proc
)[i
];
2321 t
.arg1
= arg2
; /* list of arguments */
2322 if (SCM_NIMP (t
.arg1
))
2325 /* More arguments than specifiers => CLASS != ENV */
2326 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2328 t
.arg1
= SCM_CDR (t
.arg1
);
2331 while (j
-- && SCM_NIMP (t
.arg1
));
2332 /* Fewer arguments than specifiers => CAR != ENV */
2333 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2336 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2338 SCM_CMETHOD_ENV (z
));
2339 x
= SCM_CMETHOD_CODE (z
);
2340 goto nontoplevel_cdrxbegin
;
2345 z
= scm_memoize_method (x
, arg2
);
2349 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2351 t
.arg1
= EVALCAR (x
, env
);
2352 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2354 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2356 t
.arg1
= EVALCAR (x
, env
);
2359 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2360 = SCM_UNPACK (EVALCAR (proc
, env
));
2361 RETURN (SCM_UNSPECIFIED
)
2363 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2365 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2367 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2368 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2370 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2372 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2378 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2381 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2383 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2387 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2389 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2391 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2393 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2395 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2396 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2398 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2400 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2406 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2409 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2411 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2415 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2417 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2421 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2424 t
.arg1
= SCM_CAR (x
);
2425 arg2
= SCM_CDAR (env
);
2426 while (SCM_NIMP (arg2
))
2428 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2429 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2431 SCM_SETCAR (arg2
, proc
);
2432 t
.arg1
= SCM_CDR (t
.arg1
);
2433 arg2
= SCM_CDR (arg2
);
2435 t
.arg1
= SCM_CAR (x
);
2436 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2438 arg2
= x
= SCM_CDR (x
);
2439 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2441 SIDEVAL (SCM_CAR (x
), env
);
2444 proc
= EVALCAR (x
, env
);
2446 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2447 arg2
= SCM_CDAR (env
);
2448 while (SCM_NIMP (arg2
))
2450 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2452 t
.arg1
= SCM_CDR (t
.arg1
);
2453 arg2
= SCM_CDR (arg2
);
2465 /* scm_everr (x, env,...) */
2466 scm_misc_error (NULL
, "Wrong type to apply: ~S", SCM_LIST1 (proc
));
2467 case scm_tc7_vector
:
2471 case scm_tc7_byvect
:
2478 #ifdef HAVE_LONG_LONGS
2479 case scm_tc7_llvect
:
2482 case scm_tc7_string
:
2483 case scm_tc7_substring
:
2485 case scm_tcs_closures
:
2491 #ifdef MEMOIZE_LOCALS
2492 case SCM_BIT8(SCM_ILOC00
):
2493 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2494 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2495 #ifndef SCM_RECKLESS
2501 #endif /* ifdef MEMOIZE_LOCALS */
2504 case scm_tcs_cons_gloc
: {
2505 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2507 /* This is a struct implanted in the code, not a gloc. */
2510 proc
= SCM_PACK (vcell
);
2511 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2512 #ifndef SCM_RECKLESS
2521 case scm_tcs_cons_nimcar
:
2522 if (SCM_SYMBOLP (SCM_CAR (x
)))
2525 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2528 /* we have lost the race, start again. */
2533 proc
= *scm_lookupcar (x
, env
, 1);
2541 if (scm_tc16_macro
== SCM_TYP16 (proc
))
2547 /* Set a flag during macro expansion so that macro
2548 application frames can be deleted from the backtrace. */
2549 SCM_SET_MACROEXP (debug
);
2551 t
.arg1
= SCM_APPLY (SCM_CDR (proc
), x
,
2552 scm_cons (env
, scm_listofnull
));
2555 SCM_CLEAR_MACROEXP (debug
);
2557 switch (SCM_CELL_WORD_0 (proc
) >> 16)
2560 if (scm_ilength (t
.arg1
) <= 0)
2561 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2563 if (!SCM_CLOSUREP (SCM_CDR (proc
)))
2566 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2567 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2571 /* Prevent memoizing of debug info expression. */
2572 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2577 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2578 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2582 if (SCM_NIMP (x
= t
.arg1
))
2590 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2591 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2592 #ifndef SCM_RECKLESS
2596 if (SCM_CLOSUREP (proc
))
2598 arg2
= SCM_CAR (SCM_CODE (proc
));
2599 t
.arg1
= SCM_CDR (x
);
2600 while (SCM_NIMP (arg2
))
2602 if (SCM_NCONSP (arg2
))
2604 if (SCM_IMP (t
.arg1
))
2605 goto umwrongnumargs
;
2606 arg2
= SCM_CDR (arg2
);
2607 t
.arg1
= SCM_CDR (t
.arg1
);
2609 if (SCM_NNULLP (t
.arg1
))
2610 goto umwrongnumargs
;
2612 else if (scm_tc16_macro
== SCM_TYP16 (proc
))
2613 goto handle_a_macro
;
2619 PREP_APPLY (proc
, SCM_EOL
);
2620 if (SCM_NULLP (SCM_CDR (x
))) {
2623 switch (SCM_TYP7 (proc
))
2624 { /* no arguments given */
2625 case scm_tc7_subr_0
:
2626 RETURN (SCM_SUBRF (proc
) ());
2627 case scm_tc7_subr_1o
:
2628 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2630 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2631 case scm_tc7_rpsubr
:
2632 RETURN (SCM_BOOL_T
);
2634 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2636 if (!SCM_SMOB_APPLICABLE_P (proc
))
2638 RETURN (SCM_SMOB_APPLY_0 (proc
));
2641 proc
= SCM_CCLO_SUBR (proc
);
2643 debug
.info
->a
.proc
= proc
;
2644 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2648 proc
= SCM_PROCEDURE (proc
);
2650 debug
.info
->a
.proc
= proc
;
2652 if (!SCM_CLOSUREP (proc
))
2654 if (scm_badformalsp (proc
, 0))
2655 goto umwrongnumargs
;
2656 case scm_tcs_closures
:
2657 x
= SCM_CODE (proc
);
2658 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, SCM_ENV (proc
));
2659 goto nontoplevel_cdrxbegin
;
2660 case scm_tcs_cons_gloc
:
2661 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2663 x
= SCM_ENTITY_PROCEDURE (proc
);
2667 else if (!SCM_I_OPERATORP (proc
))
2672 proc
= (SCM_I_ENTITYP (proc
)
2673 ? SCM_ENTITY_PROCEDURE (proc
)
2674 : SCM_OPERATOR_PROCEDURE (proc
));
2676 debug
.info
->a
.proc
= proc
;
2677 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2679 if (SCM_NIMP (proc
))
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
) == scm_tc3_cons_gloc
)
2715 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2717 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2719 t
.arg1
= SCM_PACK (vcell
);
2724 t
.arg1
= EVALCAR (x
, env
);
2727 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2734 switch (SCM_TYP7 (proc
))
2735 { /* have one argument in t.arg1 */
2736 case scm_tc7_subr_2o
:
2737 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2738 case scm_tc7_subr_1
:
2739 case scm_tc7_subr_1o
:
2740 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2742 if (SCM_SUBRF (proc
))
2744 if (SCM_INUMP (t
.arg1
))
2746 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2748 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2749 if (SCM_REALP (t
.arg1
))
2751 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2754 if (SCM_BIGP (t
.arg1
))
2756 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2760 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2761 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2763 proc
= SCM_SNAME (proc
);
2765 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2766 while ('c' != *--chrs
)
2768 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2769 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_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
)));
2785 if (!SCM_SMOB_APPLICABLE_P (proc
))
2787 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2791 proc
= SCM_CCLO_SUBR (proc
);
2793 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2794 debug
.info
->a
.proc
= proc
;
2798 proc
= SCM_PROCEDURE (proc
);
2800 debug
.info
->a
.proc
= proc
;
2802 if (!SCM_CLOSUREP (proc
))
2804 if (scm_badformalsp (proc
, 1))
2805 goto umwrongnumargs
;
2806 case scm_tcs_closures
:
2808 x
= SCM_CODE (proc
);
2810 env
= EXTEND_ENV (SCM_CAR (x
), debug
.info
->a
.args
, SCM_ENV (proc
));
2812 env
= EXTEND_ENV (SCM_CAR (x
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2814 goto nontoplevel_cdrxbegin
;
2815 case scm_tcs_cons_gloc
:
2816 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2818 x
= SCM_ENTITY_PROCEDURE (proc
);
2820 arg2
= debug
.info
->a
.args
;
2822 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2826 else if (!SCM_I_OPERATORP (proc
))
2832 proc
= (SCM_I_ENTITYP (proc
)
2833 ? SCM_ENTITY_PROCEDURE (proc
)
2834 : SCM_OPERATOR_PROCEDURE (proc
));
2836 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2837 debug
.info
->a
.proc
= proc
;
2839 if (SCM_NIMP (proc
))
2844 case scm_tc7_subr_2
:
2845 case scm_tc7_subr_0
:
2846 case scm_tc7_subr_3
:
2847 case scm_tc7_lsubr_2
:
2856 else if (SCM_CONSP (x
))
2858 if (SCM_IMP (SCM_CAR (x
)))
2859 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2861 arg2
= EVALCELLCAR (x
, env
);
2863 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2865 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2867 arg2
= SCM_CAR (x
); /* struct planted in code */
2869 arg2
= SCM_PACK (vcell
);
2874 arg2
= EVALCAR (x
, env
);
2876 { /* have two or more arguments */
2878 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2881 if (SCM_NULLP (x
)) {
2884 switch (SCM_TYP7 (proc
))
2885 { /* have two arguments */
2886 case scm_tc7_subr_2
:
2887 case scm_tc7_subr_2o
:
2888 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2891 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2893 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2895 case scm_tc7_lsubr_2
:
2896 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2897 case scm_tc7_rpsubr
:
2899 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2901 if (!SCM_SMOB_APPLICABLE_P (proc
))
2903 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2907 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2908 scm_cons (proc
, debug
.info
->a
.args
),
2911 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2912 scm_cons2 (proc
, t
.arg1
,
2919 case scm_tcs_cons_gloc
:
2920 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2922 x
= SCM_ENTITY_PROCEDURE (proc
);
2924 arg2
= debug
.info
->a
.args
;
2926 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2930 else if (!SCM_I_OPERATORP (proc
))
2936 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2937 ? SCM_ENTITY_PROCEDURE (proc
)
2938 : SCM_OPERATOR_PROCEDURE (proc
),
2939 scm_cons (proc
, debug
.info
->a
.args
),
2942 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2943 ? SCM_ENTITY_PROCEDURE (proc
)
2944 : SCM_OPERATOR_PROCEDURE (proc
),
2945 scm_cons2 (proc
, t
.arg1
,
2953 case scm_tc7_subr_0
:
2955 case scm_tc7_subr_1o
:
2956 case scm_tc7_subr_1
:
2957 case scm_tc7_subr_3
:
2962 proc
= SCM_PROCEDURE (proc
);
2964 debug
.info
->a
.proc
= proc
;
2966 if (!SCM_CLOSUREP (proc
))
2968 if (scm_badformalsp (proc
, 2))
2969 goto umwrongnumargs
;
2970 case scm_tcs_closures
:
2973 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2977 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
2978 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
2980 x
= SCM_CODE (proc
);
2981 goto nontoplevel_cdrxbegin
;
2985 if (SCM_IMP (x
) || SCM_NECONSP (x
))
2989 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
2990 scm_deval_args (x
, env
, proc
,
2991 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
2995 switch (SCM_TYP7 (proc
))
2996 { /* have 3 or more arguments */
2998 case scm_tc7_subr_3
:
2999 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3000 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3001 SCM_CADDR (debug
.info
->a
.args
)));
3003 #ifdef BUILTIN_RPASUBR
3004 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3005 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3008 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3009 arg2
= SCM_CDR (arg2
);
3011 while (SCM_NIMP (arg2
));
3013 #endif /* BUILTIN_RPASUBR */
3014 case scm_tc7_rpsubr
:
3015 #ifdef BUILTIN_RPASUBR
3016 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3018 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3021 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3023 arg2
= SCM_CAR (t
.arg1
);
3024 t
.arg1
= SCM_CDR (t
.arg1
);
3026 while (SCM_NIMP (t
.arg1
));
3028 #else /* BUILTIN_RPASUBR */
3029 RETURN (SCM_APPLY (proc
, t
.arg1
,
3031 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3033 #endif /* BUILTIN_RPASUBR */
3034 case scm_tc7_lsubr_2
:
3035 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3036 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3038 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3040 if (!SCM_SMOB_APPLICABLE_P (proc
))
3042 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3043 SCM_CDDR (debug
.info
->a
.args
)));
3047 proc
= SCM_PROCEDURE (proc
);
3048 debug
.info
->a
.proc
= proc
;
3049 if (!SCM_CLOSUREP (proc
))
3051 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), debug
.info
->a
.args
))
3052 goto umwrongnumargs
;
3053 case scm_tcs_closures
:
3054 SCM_SET_ARGSREADY (debug
);
3055 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3058 x
= SCM_CODE (proc
);
3059 goto nontoplevel_cdrxbegin
;
3061 case scm_tc7_subr_3
:
3062 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3063 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3065 #ifdef BUILTIN_RPASUBR
3066 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3069 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3072 while (SCM_NIMP (x
));
3074 #endif /* BUILTIN_RPASUBR */
3075 case scm_tc7_rpsubr
:
3076 #ifdef BUILTIN_RPASUBR
3077 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3081 t
.arg1
= EVALCAR (x
, env
);
3082 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3087 while (SCM_NIMP (x
));
3089 #else /* BUILTIN_RPASUBR */
3090 RETURN (SCM_APPLY (proc
, t
.arg1
,
3092 scm_eval_args (x
, env
, proc
),
3094 #endif /* BUILTIN_RPASUBR */
3095 case scm_tc7_lsubr_2
:
3096 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3098 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3100 scm_eval_args (x
, env
, proc
))));
3102 if (!SCM_SMOB_APPLICABLE_P (proc
))
3104 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3105 scm_eval_args (x
, env
, proc
)));
3109 proc
= SCM_PROCEDURE (proc
);
3110 if (!SCM_CLOSUREP (proc
))
3113 SCM formals
= SCM_CAR (SCM_CODE (proc
));
3114 if (SCM_NULLP (formals
)
3115 || (SCM_CONSP (formals
)
3116 && (SCM_NULLP (SCM_CDR (formals
))
3117 || (SCM_CONSP (SCM_CDR (formals
))
3118 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3119 goto umwrongnumargs
;
3121 case scm_tcs_closures
:
3123 SCM_SET_ARGSREADY (debug
);
3125 env
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)),
3128 scm_eval_args (x
, env
, proc
)),
3130 x
= SCM_CODE (proc
);
3131 goto nontoplevel_cdrxbegin
;
3133 case scm_tcs_cons_gloc
:
3134 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3137 arg2
= debug
.info
->a
.args
;
3139 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3141 x
= SCM_ENTITY_PROCEDURE (proc
);
3144 else if (!SCM_I_OPERATORP (proc
))
3148 case scm_tc7_subr_2
:
3149 case scm_tc7_subr_1o
:
3150 case scm_tc7_subr_2o
:
3151 case scm_tc7_subr_0
:
3153 case scm_tc7_subr_1
:
3161 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3162 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3164 SCM_CLEAR_TRACED_FRAME (debug
);
3165 if (SCM_CHEAPTRAPS_P
)
3166 t
.arg1
= scm_make_debugobj (&debug
);
3170 SCM val
= scm_make_continuation (&first
);
3180 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3183 scm_last_debug_frame
= debug
.prev
;
3189 /* SECTION: This code is compiled once.
3194 /* This code processes the arguments to apply:
3196 (apply PROC ARG1 ... ARGS)
3198 Given a list (ARG1 ... ARGS), this function conses the ARG1
3199 ... arguments onto the front of ARGS, and returns the resulting
3200 list. Note that ARGS is a list; thus, the argument to this
3201 function is a list whose last element is a list.
3203 Apply calls this function, and applies PROC to the elements of the
3204 result. apply:nconc2last takes care of building the list of
3205 arguments, given (ARG1 ... ARGS).
3207 Rather than do new consing, apply:nconc2last destroys its argument.
3208 On that topic, this code came into my care with the following
3209 beautifully cryptic comment on that topic: "This will only screw
3210 you if you do (scm_apply scm_apply '( ... ))" If you know what
3211 they're referring to, send me a patch to this comment. */
3213 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3215 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3216 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3217 "@var{args}, and returns the resulting list. Note that\n"
3218 "@var{args} is a list; thus, the argument to this function is\n"
3219 "a list whose last element is a list.\n"
3220 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3221 "destroys its argument, so use with care.")
3222 #define FUNC_NAME s_scm_nconc2last
3225 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3227 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3228 lloc
= SCM_CDRLOC (*lloc
);
3229 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3230 *lloc
= SCM_CAR (*lloc
);
3238 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3239 * It is compiled twice.
3245 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3252 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3257 /* Apply a function to a list of arguments.
3259 This function is exported to the Scheme level as taking two
3260 required arguments and a tail argument, as if it were:
3261 (lambda (proc arg1 . args) ...)
3262 Thus, if you just have a list of arguments to pass to a procedure,
3263 pass the list as ARG1, and '() for ARGS. If you have some fixed
3264 args, pass the first as ARG1, then cons any remaining fixed args
3265 onto the front of your argument list, and pass that as ARGS. */
3268 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3270 #ifdef DEBUG_EXTENSIONS
3272 scm_debug_frame debug
;
3273 scm_debug_info debug_vect_body
;
3274 debug
.prev
= scm_last_debug_frame
;
3275 debug
.status
= SCM_APPLYFRAME
;
3276 debug
.vect
= &debug_vect_body
;
3277 debug
.vect
[0].a
.proc
= proc
;
3278 debug
.vect
[0].a
.args
= SCM_EOL
;
3279 scm_last_debug_frame
= &debug
;
3282 return scm_dapply (proc
, arg1
, args
);
3286 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3288 /* If ARGS is the empty list, then we're calling apply with only two
3289 arguments --- ARG1 is the list of arguments for PROC. Whatever
3290 the case, futz with things so that ARG1 is the first argument to
3291 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3294 Setting the debug apply frame args this way is pretty messy.
3295 Perhaps we should store arg1 and args directly in the frame as
3296 received, and let scm_frame_arguments unpack them, because that's
3297 a relatively rare operation. This works for now; if the Guile
3298 developer archives are still around, see Mikael's post of
3300 if (SCM_NULLP (args
))
3302 if (SCM_NULLP (arg1
))
3304 arg1
= SCM_UNDEFINED
;
3306 debug
.vect
[0].a
.args
= SCM_EOL
;
3312 debug
.vect
[0].a
.args
= arg1
;
3314 args
= SCM_CDR (arg1
);
3315 arg1
= SCM_CAR (arg1
);
3320 args
= scm_nconc2last (args
);
3322 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3326 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3329 if (SCM_CHEAPTRAPS_P
)
3330 tmp
= scm_make_debugobj (&debug
);
3335 tmp
= scm_make_continuation (&first
);
3339 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3345 switch (SCM_TYP7 (proc
))
3347 case scm_tc7_subr_2o
:
3348 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3349 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3350 case scm_tc7_subr_2
:
3351 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3353 args
= SCM_CAR (args
);
3354 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3355 case scm_tc7_subr_0
:
3356 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3357 RETURN (SCM_SUBRF (proc
) ())
3358 case scm_tc7_subr_1
:
3359 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3360 case scm_tc7_subr_1o
:
3361 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3362 RETURN (SCM_SUBRF (proc
) (arg1
))
3364 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3365 if (SCM_SUBRF (proc
))
3367 if (SCM_INUMP (arg1
))
3369 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3371 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3372 if (SCM_REALP (arg1
))
3374 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3377 if (SCM_BIGP (arg1
))
3378 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3381 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3382 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3384 proc
= SCM_SNAME (proc
);
3386 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3387 while ('c' != *--chrs
)
3389 SCM_ASSERT (SCM_CONSP (arg1
),
3390 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3391 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3395 case scm_tc7_subr_3
:
3396 SCM_ASRTGO (SCM_NNULLP (args
)
3397 && SCM_NNULLP (SCM_CDR (args
))
3398 && SCM_NULLP (SCM_CDDR (args
)),
3400 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3403 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3405 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3407 case scm_tc7_lsubr_2
:
3408 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3409 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3411 if (SCM_NULLP (args
))
3412 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3413 while (SCM_NIMP (args
))
3415 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3416 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3417 args
= SCM_CDR (args
);
3420 case scm_tc7_rpsubr
:
3421 if (SCM_NULLP (args
))
3422 RETURN (SCM_BOOL_T
);
3423 while (SCM_NIMP (args
))
3425 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3426 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3427 RETURN (SCM_BOOL_F
);
3428 arg1
= SCM_CAR (args
);
3429 args
= SCM_CDR (args
);
3431 RETURN (SCM_BOOL_T
);
3432 case scm_tcs_closures
:
3434 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3436 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3438 #ifndef SCM_RECKLESS
3439 if (scm_badargsp (SCM_CAR (SCM_CODE (proc
)), arg1
))
3443 /* Copy argument list */
3448 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3449 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3451 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3455 SCM_SETCDR (tl
, arg1
);
3458 args
= EXTEND_ENV (SCM_CAR (SCM_CODE (proc
)), args
, SCM_ENV (proc
));
3459 proc
= SCM_CDR (SCM_CODE (proc
));
3462 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3464 if (SCM_IMP (SCM_CAR (proc
)))
3466 if (SCM_ISYMP (SCM_CAR (proc
)))
3468 proc
= scm_m_expand_body (proc
, args
);
3472 SCM_EVALIM2 (SCM_CAR (proc
));
3475 SCM_CEVAL (SCM_CAR (proc
), args
);
3478 RETURN (EVALCAR (proc
, args
));
3480 if (!SCM_SMOB_APPLICABLE_P (proc
))
3482 if (SCM_UNBNDP (arg1
))
3483 RETURN (SCM_SMOB_APPLY_0 (proc
))
3484 else if (SCM_NULLP (args
))
3485 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3486 else if (SCM_NULLP (SCM_CDR (args
)))
3487 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3489 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3492 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3494 proc
= SCM_CCLO_SUBR (proc
);
3495 debug
.vect
[0].a
.proc
= proc
;
3496 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3498 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3500 proc
= SCM_CCLO_SUBR (proc
);
3504 proc
= SCM_PROCEDURE (proc
);
3506 debug
.vect
[0].a
.proc
= proc
;
3509 case scm_tcs_cons_gloc
:
3510 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3513 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3515 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3517 RETURN (scm_apply_generic (proc
, args
));
3519 else if (!SCM_I_OPERATORP (proc
))
3524 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3526 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3529 proc
= (SCM_I_ENTITYP (proc
)
3530 ? SCM_ENTITY_PROCEDURE (proc
)
3531 : SCM_OPERATOR_PROCEDURE (proc
));
3533 debug
.vect
[0].a
.proc
= proc
;
3534 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3536 if (SCM_NIMP (proc
))
3542 scm_wrong_num_args (proc
);
3545 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3550 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3551 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3553 SCM_CLEAR_TRACED_FRAME (debug
);
3554 if (SCM_CHEAPTRAPS_P
)
3555 arg1
= scm_make_debugobj (&debug
);
3559 SCM val
= scm_make_continuation (&first
);
3569 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3572 scm_last_debug_frame
= debug
.prev
;
3578 /* SECTION: The rest of this file is only read once.
3583 /* Typechecking for multi-argument MAP and FOR-EACH.
3585 Verify that each element of the vector ARGV, except for the first,
3586 is a proper list whose length is LEN. Attribute errors to WHO,
3587 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3589 check_map_args (SCM argv
,
3596 SCM
*ve
= SCM_VELTS (argv
);
3599 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3601 int elt_len
= scm_ilength (ve
[i
]);
3606 scm_apply_generic (gf
, scm_cons (proc
, args
));
3608 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3612 scm_out_of_range (who
, ve
[i
]);
3615 scm_remember_upto_here_1 (argv
);
3619 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3621 /* Note: Currently, scm_map applies PROC to the argument list(s)
3622 sequentially, starting with the first element(s). This is used in
3623 evalext.c where the Scheme procedure `map-in-order', which guarantees
3624 sequential behaviour, is implemented using scm_map. If the
3625 behaviour changes, we need to update `map-in-order'.
3629 scm_map (SCM proc
, SCM arg1
, SCM args
)
3630 #define FUNC_NAME s_map
3635 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3637 len
= scm_ilength (arg1
);
3638 SCM_GASSERTn (len
>= 0,
3639 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3640 SCM_VALIDATE_REST_ARGUMENT (args
);
3641 if (SCM_NULLP (args
))
3643 while (SCM_NIMP (arg1
))
3645 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3647 pres
= SCM_CDRLOC (*pres
);
3648 arg1
= SCM_CDR (arg1
);
3652 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3653 ve
= SCM_VELTS (args
);
3654 #ifndef SCM_RECKLESS
3655 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3660 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3662 if (SCM_IMP (ve
[i
]))
3664 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3665 ve
[i
] = SCM_CDR (ve
[i
]);
3667 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3668 pres
= SCM_CDRLOC (*pres
);
3674 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3677 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3678 #define FUNC_NAME s_for_each
3680 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3682 len
= scm_ilength (arg1
);
3683 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3684 SCM_ARG2
, s_for_each
);
3685 SCM_VALIDATE_REST_ARGUMENT (args
);
3688 while SCM_NIMP (arg1
)
3690 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3691 arg1
= SCM_CDR (arg1
);
3693 return SCM_UNSPECIFIED
;
3695 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3696 ve
= SCM_VELTS (args
);
3697 #ifndef SCM_RECKLESS
3698 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3703 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3706 (ve
[i
]) return SCM_UNSPECIFIED
;
3707 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3708 ve
[i
] = SCM_CDR (ve
[i
]);
3710 scm_apply (proc
, arg1
, SCM_EOL
);
3717 scm_closure (SCM code
, SCM env
)
3721 SCM_SETCODE (z
, code
);
3722 SCM_SETENV (z
, env
);
3727 scm_bits_t scm_tc16_promise
;
3730 scm_makprom (SCM code
)
3732 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3738 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3740 int writingp
= SCM_WRITINGP (pstate
);
3741 scm_puts ("#<promise ", port
);
3742 SCM_SET_WRITINGP (pstate
, 1);
3743 scm_iprin1 (SCM_CDR (exp
), port
, pstate
);
3744 SCM_SET_WRITINGP (pstate
, writingp
);
3745 scm_putc ('>', port
);
3750 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3752 "If the promise @var{x} has not been computed yet, compute and\n"
3753 "return @var{x}, otherwise just return the previously computed\n"
3755 #define FUNC_NAME s_scm_force
3757 SCM_VALIDATE_SMOB (1, x
, promise
);
3758 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3760 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3761 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3764 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3765 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3769 return SCM_CELL_OBJECT_1 (x
);
3774 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3776 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3777 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3778 #define FUNC_NAME s_scm_promise_p
3780 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3785 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3786 (SCM xorig
, SCM x
, SCM y
),
3787 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3788 "Any source properties associated with @var{xorig} are also associated\n"
3789 "with the new pair.")
3790 #define FUNC_NAME s_scm_cons_source
3794 SCM_SET_CELL_OBJECT_0 (z
, x
);
3795 SCM_SET_CELL_OBJECT_1 (z
, y
);
3796 /* Copy source properties possibly associated with xorig. */
3797 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3799 scm_whash_insert (scm_source_whash
, z
, p
);
3805 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3807 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3808 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3809 "contents of both pairs and vectors (since both cons cells and vector\n"
3810 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3811 "any other object.")
3812 #define FUNC_NAME s_scm_copy_tree
3817 if (SCM_VECTORP (obj
))
3819 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3820 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3822 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3825 if (SCM_NCONSP (obj
))
3827 ans
= tl
= scm_cons_source (obj
,
3828 scm_copy_tree (SCM_CAR (obj
)),
3830 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3832 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3836 SCM_SETCDR (tl
, obj
);
3842 /* We have three levels of EVAL here:
3844 - scm_i_eval (exp, env)
3846 evaluates EXP in environment ENV. ENV is a lexical environment
3847 structure as used by the actual tree code evaluator. When ENV is
3848 a top-level environment, then changes to the current module are
3849 tracked by modifying ENV so that it continues to be in sync with
3852 - scm_primitive_eval (exp)
3854 evaluates EXP in the top-level environment as determined by the
3855 current module. This is done by constructing a suitable
3856 environment and calling scm_i_eval. Thus, changes to the
3857 top-level module are tracked normally.
3859 - scm_eval (exp, mod)
3861 evaluates EXP while MOD is the current module. Thius is done by
3862 setting the current module to MOD, invoking scm_primitive_eval on
3863 EXP, and then restoring the current module to the value it had
3864 previously. That is, while EXP is evaluated, changes to the
3865 current module are tracked, but these changes do not persist when
3868 For each level of evals, there are two variants, distinguished by a
3869 _x suffix: the ordinary variant does not modify EXP while the _x
3870 variant can destructively modify EXP into something completely
3871 unintelligible. A Scheme data structure passed as EXP to one of the
3872 _x variants should not ever be used again for anything. So when in
3873 doubt, use the ordinary variant.
3877 SCM scm_system_transformer
;
3879 /* XXX - scm_i_eval is meant to be useable for evaluation in
3880 non-toplevel environments, for example when used by the debugger.
3881 Can the system transform deal with this? */
3884 scm_i_eval_x (SCM exp
, SCM env
)
3886 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3887 if (SCM_NIMP (transformer
))
3888 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3889 return SCM_XEVAL (exp
, env
);
3893 scm_i_eval (SCM exp
, SCM env
)
3895 SCM transformer
= scm_fluid_ref (SCM_CDR (scm_system_transformer
));
3896 if (SCM_NIMP (transformer
))
3897 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3898 exp
= scm_copy_tree (exp
);
3899 return SCM_XEVAL (exp
, env
);
3903 scm_primitive_eval_x (SCM exp
)
3905 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3906 return scm_i_eval_x (exp
, env
);
3909 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3911 "Evaluate @var{exp} in the top-level environment specified by\n"
3912 "the current module.")
3913 #define FUNC_NAME s_scm_primitive_eval
3915 SCM env
= scm_top_level_env (scm_current_module_lookup_closure ());
3916 return scm_i_eval (exp
, env
);
3920 /* Eval does not take the second arg optionally. This is intentional
3921 * in order to be R5RS compatible, and to prepare for the new module
3922 * system, where we would like to make the choice of evaluation
3923 * environment explicit. */
3926 change_environment (void *data
)
3928 SCM pair
= SCM_PACK (data
);
3929 SCM new_module
= SCM_CAR (pair
);
3930 SCM old_module
= scm_current_module ();
3931 SCM_SETCDR (pair
, old_module
);
3932 scm_set_current_module (new_module
);
3937 restore_environment (void *data
)
3939 SCM pair
= SCM_PACK (data
);
3940 SCM old_module
= SCM_CDR (pair
);
3941 SCM new_module
= scm_current_module ();
3942 SCM_SETCAR (pair
, new_module
);
3943 scm_set_current_module (old_module
);
3947 inner_eval_x (void *data
)
3949 return scm_primitive_eval_x (SCM_PACK(data
));
3953 scm_eval_x (SCM exp
, SCM module
)
3954 #define FUNC_NAME "eval!"
3956 SCM_VALIDATE_MODULE (2, module
);
3958 return scm_internal_dynamic_wind
3959 (change_environment
, inner_eval_x
, restore_environment
,
3960 (void *) SCM_UNPACK (exp
),
3961 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3966 inner_eval (void *data
)
3968 return scm_primitive_eval (SCM_PACK(data
));
3971 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
3972 (SCM exp
, SCM module
),
3973 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
3974 "in the top-level environment specified by @var{module}.\n"
3975 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
3976 "@var{module} is made the current module. The current module\n"
3977 "is reset to its previous value when @var{eval} returns.")
3978 #define FUNC_NAME s_scm_eval
3980 SCM_VALIDATE_MODULE (2, module
);
3982 return scm_internal_dynamic_wind
3983 (change_environment
, inner_eval
, restore_environment
,
3984 (void *) SCM_UNPACK (exp
),
3985 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3989 #if (SCM_DEBUG_DEPRECATED == 0)
3991 /* Use scm_current_module () or scm_interaction_environment ()
3992 * instead. The former is the module selected during loading of code.
3993 * The latter is the module in which the user of this thread currently
3994 * types expressions.
3997 SCM scm_top_level_lookup_closure_var
;
3999 /* Avoid using this functionality altogether (except for implementing
4000 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4002 * Applications should use either C level scm_eval_x or Scheme
4003 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4006 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4009 return scm_i_eval (obj
, env
);
4011 return scm_i_eval_x (obj
, env
);
4014 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4015 (SCM obj
, SCM env_thunk
),
4016 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4017 "designated by @var{lookup}, a symbol-lookup function."
4018 "Do not use this version of eval, it does not play well\n"
4019 "with the module system. Use @code{eval} or\n"
4020 "@code{primitive-eval} instead.")
4021 #define FUNC_NAME s_scm_eval2
4023 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4027 #endif /* DEPRECATED */
4030 /* At this point, scm_deval and scm_dapply are generated.
4033 #ifdef DEBUG_EXTENSIONS
4043 scm_init_opts (scm_evaluator_traps
,
4044 scm_evaluator_trap_table
,
4045 SCM_N_EVALUATOR_TRAPS
);
4046 scm_init_opts (scm_eval_options_interface
,
4048 SCM_N_EVAL_OPTIONS
);
4050 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4051 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4052 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4054 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4055 scm_system_transformer
= scm_sysintern ("scm:eval-transformer",
4058 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
4059 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
4060 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
4061 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
4062 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
4063 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
4068 #if SCM_DEBUG_DEPRECATED == 0
4069 scm_top_level_lookup_closure_var
=
4070 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
4073 #ifndef SCM_MAGIC_SNARFER
4074 #include "libguile/eval.x"
4077 scm_add_feature ("delay");