1 /* Copyright (C) 1995,1996,1997,1998,1999,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"
103 #include "libguile/values.h"
105 #include "libguile/validate.h"
106 #include "libguile/eval.h"
110 /* The evaluator contains a plethora of EVAL symbols.
111 * This is an attempt at explanation.
113 * The following macros should be used in code which is read twice
114 * (where the choice of evaluator is hard soldered):
116 * SCM_CEVAL is the symbol used within one evaluator to call itself.
117 * Originally, it is defined to scm_ceval, but is redefined to
118 * scm_deval during the second pass.
120 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
121 * only side effects of expressions matter. All immediates are
124 * SCM_EVALIM is used when it is known that the expression is an
125 * immediate. (This macro never calls an evaluator.)
127 * EVALCAR evaluates the car of an expression.
129 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
130 * car is a lisp cell.
132 * The following macros should be used in code which is read once
133 * (where the choice of evaluator is dynamic):
135 * SCM_XEVAL takes care of immediates without calling an evaluator. It
136 * then calls scm_ceval *or* scm_deval, depending on the debugging
139 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
140 * depending on the debugging mode.
142 * The main motivation for keeping this plethora is efficiency
143 * together with maintainability (=> locality of code).
146 #define SCM_CEVAL scm_ceval
147 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
149 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env))
153 #define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \
154 ? (SCM_IMP (SCM_CAR (x)) \
155 ? SCM_EVALIM (SCM_CAR (x), env) \
156 : SCM_GLOC_VAL (SCM_CAR (x))) \
157 : EVALCELLCAR (x, env))
159 #define EXTEND_ENV SCM_EXTEND_ENV
161 #ifdef MEMOIZE_LOCALS
164 scm_ilookup (SCM iloc
, SCM env
)
166 register int ir
= SCM_IFRAME (iloc
);
167 register SCM er
= env
;
168 for (; 0 != ir
; --ir
)
171 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
173 if (SCM_ICDRP (iloc
))
174 return SCM_CDRLOC (er
);
175 return SCM_CARLOC (SCM_CDR (er
));
181 /* The Lookup Car Race
184 Memoization of variables and special forms is done while executing
185 the code for the first time. As long as there is only one thread
186 everything is fine, but as soon as two threads execute the same
187 code concurrently `for the first time' they can come into conflict.
189 This memoization includes rewriting variable references into more
190 efficient forms and expanding macros. Furthermore, macro expansion
191 includes `compiling' special forms like `let', `cond', etc. into
192 tree-code instructions.
194 There shouldn't normally be a problem with memoizing local and
195 global variable references (into ilocs and glocs), because all
196 threads will mutate the code in *exactly* the same way and (if I
197 read the C code correctly) it is not possible to observe a half-way
198 mutated cons cell. The lookup procedure can handle this
199 transparently without any critical sections.
201 It is different with macro expansion, because macro expansion
202 happens outside of the lookup procedure and can't be
203 undone. Therefore it can't cope with it. It has to indicate
204 failure when it detects a lost race and hope that the caller can
205 handle it. Luckily, it turns out that this is the case.
207 An example to illustrate this: Suppose that the follwing form will
208 be memoized concurrently by two threads
212 Let's first examine the lookup of X in the body. The first thread
213 decides that it has to find the symbol "x" in the environment and
214 starts to scan it. Then the other thread takes over and actually
215 overtakes the first. It looks up "x" and substitutes an
216 appropriate iloc for it. Now the first thread continues and
217 completes its lookup. It comes to exactly the same conclusions as
218 the second one and could - without much ado - just overwrite the
219 iloc with the same iloc.
221 But let's see what will happen when the race occurs while looking
222 up the symbol "let" at the start of the form. It could happen that
223 the second thread interrupts the lookup of the first thread and not
224 only substitutes a gloc for it but goes right ahead and replaces it
225 with the compiled form (#@let* (x 12) x). Now, when the first
226 thread completes its lookup, it would replace the #@let* with a
227 gloc pointing to the "let" binding, effectively reverting the form
228 to (let (x 12) x). This is wrong. It has to detect that it has
229 lost the race and the evaluator has to reconsider the changed form
232 This race condition could be resolved with some kind of traffic
233 light (like mutexes) around scm_lookupcar, but I think that it is
234 best to avoid them in this case. They would serialize memoization
235 completely and because lookup involves calling arbitrary Scheme
236 code (via the lookup-thunk), threads could be blocked for an
237 arbitrary amount of time or even deadlock. But with the current
238 solution a lot of unnecessary work is potentially done. */
240 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
241 return NULL to indicate a failed lookup due to some race conditions
242 between threads. This only happens when VLOC is the first cell of
243 a special form that will eventually be memoized (like `let', etc.)
244 In that case the whole lookup is bogus and the caller has to
245 reconsider the complete special form.
247 SCM_LOOKUPCAR is still there, of course. It just calls
248 SCM_LOOKUPCAR1 and aborts on recieving NULL. So SCM_LOOKUPCAR
249 should only be called when it is known that VLOC is not the first
250 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
251 for NULL. I think I've found the only places where this
254 #endif /* USE_THREADS */
256 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
260 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
263 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
267 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
269 register SCM var2
= var
;
271 #ifdef MEMOIZE_LOCALS
272 register SCM iloc
= SCM_ILOC00
;
274 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
276 if (!SCM_CONSP (SCM_CAR (env
)))
278 al
= SCM_CARLOC (env
);
279 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
283 if (SCM_EQ_P (fl
, var
))
285 #ifdef MEMOIZE_LOCALS
287 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
290 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
292 return SCM_CDRLOC (*al
);
297 al
= SCM_CDRLOC (*al
);
298 if (SCM_EQ_P (SCM_CAR (fl
), var
))
300 #ifdef MEMOIZE_LOCALS
301 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
302 if (SCM_UNBNDP (SCM_CAR (*al
)))
309 if (SCM_CAR (vloc
) != var
)
312 SCM_SETCAR (vloc
, iloc
);
314 return SCM_CARLOC (*al
);
316 #ifdef MEMOIZE_LOCALS
317 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
320 #ifdef MEMOIZE_LOCALS
321 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
325 SCM top_thunk
, vcell
;
328 top_thunk
= SCM_CAR (env
); /* env now refers to a top level env thunk */
332 top_thunk
= SCM_BOOL_F
;
333 vcell
= scm_sym2vcell (var
, top_thunk
, SCM_BOOL_F
);
334 if (SCM_FALSEP (vcell
))
340 if (SCM_NNULLP (env
) || SCM_UNBNDP (SCM_CDR (var
)))
344 /* scm_everr (vloc, genv,...) */
348 scm_error (scm_unbound_variable_key
, NULL
, "Unbound variable: ~S",
349 scm_cons (var
, SCM_EOL
), SCM_BOOL_F
);
351 scm_misc_error (NULL
, "Damaged environment: ~S",
352 scm_cons (var
, SCM_EOL
));
355 /* A variable could not be found, but we shall not throw an error. */
356 static SCM undef_object
= SCM_UNDEFINED
;
357 return &undef_object
;
362 if (SCM_CAR (vloc
) != var2
)
364 /* Some other thread has changed the very cell we are working
365 on. In effect, it must have done our job or messed it up
368 var
= SCM_CAR (vloc
);
369 if (SCM_ITAG3 (var
) == scm_tc3_cons_gloc
)
370 return SCM_GLOC_VAL_LOC (var
);
371 #ifdef MEMOIZE_LOCALS
372 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
373 return scm_ilookup (var
, genv
);
375 /* We can't cope with anything else than glocs and ilocs. When
376 a special form has been memoized (i.e. `let' into `#@let') we
377 return NULL and expect the calling function to do the right
378 thing. For the evaluator, this means going back and redoing
379 the dispatch on the car of the form. */
382 #endif /* USE_THREADS */
384 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (var
) + scm_tc3_cons_gloc
);
385 /* Except wait...what if the var is not a vcell,
386 * but syntax or something.... */
387 return SCM_CDRLOC (var
);
392 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
394 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
401 #define unmemocar scm_unmemocar
404 scm_unmemocar (SCM form
, SCM env
)
411 if (SCM_ITAG3 (c
) == scm_tc3_cons_gloc
)
412 SCM_SETCAR (form
, SCM_GLOC_SYM (c
));
413 #ifdef MEMOIZE_LOCALS
414 #ifdef DEBUG_EXTENSIONS
415 else if (SCM_ILOCP (c
))
419 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
421 env
= SCM_CAR (SCM_CAR (env
));
422 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
424 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
433 scm_eval_car (SCM pair
, SCM env
)
435 return SCM_XEVALCAR (pair
, env
);
440 * The following rewrite expressions and
441 * some memoized forms have different syntax
444 const char scm_s_expression
[] = "missing or extra expression";
445 const char scm_s_test
[] = "bad test";
446 const char scm_s_body
[] = "bad body";
447 const char scm_s_bindings
[] = "bad bindings";
448 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
449 const char scm_s_variable
[] = "bad variable";
450 const char scm_s_clauses
[] = "bad or missing clauses";
451 const char scm_s_formals
[] = "bad formals";
452 const char scm_s_duplicate_formals
[] = "duplicate formals";
454 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
455 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
456 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
457 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
458 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
462 #ifdef DEBUG_EXTENSIONS
463 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
464 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
465 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
466 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
470 /* Check that the body denoted by XORIG is valid and rewrite it into
471 its internal form. The internal form of a body is just the body
472 itself, but prefixed with an ISYM that denotes to what kind of
473 outer construct this body belongs. A lambda body starts with
474 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
475 etc. The one exception is a body that belongs to a letrec that has
476 been formed by rewriting internal defines: it starts with
479 /* XXX - Besides controlling the rewriting of internal defines, the
480 additional ISYM could be used for improved error messages.
481 This is not done yet. */
484 scm_m_body (SCM op
, SCM xorig
, const char *what
)
486 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_expression
, what
);
488 /* Don't add another ISYM if one is present already. */
489 if (SCM_ISYMP (SCM_CAR (xorig
)))
492 /* Retain possible doc string. */
493 if (!SCM_CONSP (SCM_CAR (xorig
)))
495 if (SCM_NNULLP (SCM_CDR(xorig
)))
496 return scm_cons (SCM_CAR (xorig
),
497 scm_m_body (op
, SCM_CDR(xorig
), what
));
501 return scm_cons (op
, xorig
);
504 SCM_SYNTAX(s_quote
,"quote", scm_makmmacro
, scm_m_quote
);
505 SCM_GLOBAL_SYMBOL(scm_sym_quote
, s_quote
);
508 scm_m_quote (SCM xorig
, SCM env
)
510 SCM x
= scm_copy_tree (SCM_CDR (xorig
));
512 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
513 return scm_cons (SCM_IM_QUOTE
, x
);
518 SCM_SYNTAX(s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
519 SCM_GLOBAL_SYMBOL(scm_sym_begin
, s_begin
);
522 scm_m_begin (SCM xorig
, SCM env
)
524 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 1, scm_s_expression
, s_begin
);
525 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
528 SCM_SYNTAX(s_if
, "if", scm_makmmacro
, scm_m_if
);
529 SCM_GLOBAL_SYMBOL(scm_sym_if
, s_if
);
532 scm_m_if (SCM xorig
, SCM env
)
534 int len
= scm_ilength (SCM_CDR (xorig
));
535 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, "if");
536 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
540 /* Will go into the RnRS module when Guile is factorized.
541 SCM_SYNTAX(scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
542 const char scm_s_set_x
[] = "set!";
543 SCM_GLOBAL_SYMBOL(scm_sym_set_x
, scm_s_set_x
);
546 scm_m_set_x (SCM xorig
, SCM env
)
548 SCM x
= SCM_CDR (xorig
);
549 SCM_ASSYNT (2 == scm_ilength (x
), scm_s_expression
, scm_s_set_x
);
550 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
551 return scm_cons (SCM_IM_SET_X
, x
);
555 SCM_SYNTAX(s_and
, "and", scm_makmmacro
, scm_m_and
);
556 SCM_GLOBAL_SYMBOL(scm_sym_and
, s_and
);
559 scm_m_and (SCM xorig
, SCM env
)
561 int len
= scm_ilength (SCM_CDR (xorig
));
562 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
564 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
569 SCM_SYNTAX(s_or
,"or", scm_makmmacro
, scm_m_or
);
570 SCM_GLOBAL_SYMBOL(scm_sym_or
,s_or
);
573 scm_m_or (SCM xorig
, SCM env
)
575 int len
= scm_ilength (SCM_CDR (xorig
));
576 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
578 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
584 SCM_SYNTAX(s_case
, "case", scm_makmmacro
, scm_m_case
);
585 SCM_GLOBAL_SYMBOL(scm_sym_case
, s_case
);
588 scm_m_case (SCM xorig
, SCM env
)
590 SCM proc
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
591 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_clauses
, s_case
);
592 while (SCM_NIMP (x
= SCM_CDR (x
)))
595 SCM_ASSYNT (scm_ilength (proc
) >= 2, scm_s_clauses
, s_case
);
596 SCM_ASSYNT (scm_ilength (SCM_CAR (proc
)) >= 0
597 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
))
598 && SCM_NULLP (SCM_CDR (x
))),
599 scm_s_clauses
, s_case
);
601 return scm_cons (SCM_IM_CASE
, cdrx
);
605 SCM_SYNTAX(s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
606 SCM_GLOBAL_SYMBOL(scm_sym_cond
, s_cond
);
610 scm_m_cond (SCM xorig
, SCM env
)
612 SCM arg1
, cdrx
= scm_list_copy (SCM_CDR (xorig
)), x
= cdrx
;
613 int len
= scm_ilength (x
);
614 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
618 len
= scm_ilength (arg1
);
619 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
620 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (arg1
)))
622 SCM_ASSYNT (SCM_NULLP (SCM_CDR (x
)) && len
>= 2,
623 "bad ELSE clause", s_cond
);
624 SCM_SETCAR (arg1
, SCM_BOOL_T
);
626 if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CAR (SCM_CDR (arg1
))))
627 SCM_ASSYNT (3 == len
&& SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1
)))),
628 "bad recipient", s_cond
);
631 return scm_cons (SCM_IM_COND
, cdrx
);
634 SCM_SYNTAX(s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
635 SCM_GLOBAL_SYMBOL(scm_sym_lambda
, s_lambda
);
637 /* Return #t if OBJ is `eq?' to one of the elements of LIST or to the
638 cdr of the last cons. (Thus, LIST is not required to be a proper
639 list and when OBJ also found in the improper ending.) */
642 scm_c_improper_memq (SCM obj
, SCM list
)
644 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
646 if (SCM_EQ_P (SCM_CAR (list
), obj
))
649 return SCM_EQ_P (list
, obj
);
653 scm_m_lambda (SCM xorig
, SCM env
)
655 SCM proc
, x
= SCM_CDR (xorig
);
656 if (scm_ilength (x
) < 2)
659 if (SCM_NULLP (proc
))
661 if (SCM_EQ_P (SCM_IM_LET
, proc
)) /* named let */
665 if (SCM_SYMBOLP (proc
))
667 if (SCM_NCONSP (proc
))
669 while (SCM_NIMP (proc
))
671 if (SCM_NCONSP (proc
))
673 if (!SCM_SYMBOLP (proc
))
678 if (!SCM_SYMBOLP (SCM_CAR (proc
)))
680 else if (scm_c_improper_memq (SCM_CAR(proc
), SCM_CDR(proc
)))
681 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
682 proc
= SCM_CDR (proc
);
684 if (SCM_NNULLP (proc
))
687 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
691 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
692 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
695 SCM_SYNTAX(s_letstar
,"let*", scm_makmmacro
, scm_m_letstar
);
696 SCM_GLOBAL_SYMBOL(scm_sym_letstar
,s_letstar
);
700 scm_m_letstar (SCM xorig
, SCM env
)
702 SCM x
= SCM_CDR (xorig
), arg1
, proc
, vars
= SCM_EOL
, *varloc
= &vars
;
703 int len
= scm_ilength (x
);
704 SCM_ASSYNT (len
>= 2, scm_s_body
, s_letstar
);
706 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_letstar
);
707 while (SCM_NIMP (proc
))
709 arg1
= SCM_CAR (proc
);
710 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_letstar
);
711 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_letstar
);
712 *varloc
= scm_cons2 (SCM_CAR (arg1
), SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
713 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
714 proc
= SCM_CDR (proc
);
716 x
= scm_cons (vars
, SCM_CDR (x
));
718 return scm_cons2 (SCM_IM_LETSTAR
, SCM_CAR (x
),
719 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
722 /* DO gets the most radically altered syntax
723 (do ((<var1> <init1> <step1>)
729 (do_mem (varn ... var2 var1)
730 (<init1> <init2> ... <initn>)
733 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
736 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
737 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
740 scm_m_do (SCM xorig
, SCM env
)
742 SCM x
= SCM_CDR (xorig
), arg1
, proc
;
743 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, steps
= SCM_EOL
;
744 SCM
*initloc
= &inits
, *steploc
= &steps
;
745 int len
= scm_ilength (x
);
746 SCM_ASSYNT (len
>= 2, scm_s_test
, "do");
748 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, "do");
749 while (SCM_NIMP(proc
))
751 arg1
= SCM_CAR (proc
);
752 len
= scm_ilength (arg1
);
753 SCM_ASSYNT (2 == len
|| 3 == len
, scm_s_bindings
, "do");
754 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, "do");
755 /* vars reversed here, inits and steps reversed at evaluation */
756 vars
= scm_cons (SCM_CAR (arg1
), vars
); /* variable */
757 arg1
= SCM_CDR (arg1
);
758 *initloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
); /* init */
759 initloc
= SCM_CDRLOC (*initloc
);
760 arg1
= SCM_CDR (arg1
);
761 *steploc
= scm_cons (SCM_IMP (arg1
) ? SCM_CAR (vars
) : SCM_CAR (arg1
), SCM_EOL
); /* step */
762 steploc
= SCM_CDRLOC (*steploc
);
763 proc
= SCM_CDR (proc
);
766 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
767 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
768 x
= scm_cons2 (vars
, inits
, x
);
769 return scm_cons (SCM_IM_DO
, x
);
772 /* evalcar is small version of inline EVALCAR when we don't care about
775 #define evalcar scm_eval_car
778 static SCM
iqq (SCM form
, SCM env
, int depth
);
780 SCM_SYNTAX(s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
781 SCM_GLOBAL_SYMBOL(scm_sym_quasiquote
, s_quasiquote
);
784 scm_m_quasiquote (SCM xorig
, SCM env
)
786 SCM x
= SCM_CDR (xorig
);
787 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
788 return iqq (SCM_CAR (x
), env
, 1);
793 iqq (SCM form
, SCM env
, int depth
)
799 if (SCM_VECTORP (form
))
801 long i
= SCM_VECTOR_LENGTH (form
);
802 SCM
*data
= SCM_VELTS (form
);
805 tmp
= scm_cons (data
[i
], tmp
);
806 return scm_vector (iqq (tmp
, env
, depth
));
808 if (!SCM_CONSP (form
))
810 tmp
= SCM_CAR (form
);
811 if (SCM_EQ_P (scm_sym_quasiquote
, tmp
))
816 if (SCM_EQ_P (scm_sym_unquote
, tmp
))
820 form
= SCM_CDR (form
);
821 SCM_ASSERT (SCM_ECONSP (form
) && SCM_NULLP (SCM_CDR (form
)),
822 form
, SCM_ARG1
, s_quasiquote
);
824 return evalcar (form
, env
);
825 return scm_cons2 (tmp
, iqq (SCM_CAR (form
), env
, depth
), SCM_EOL
);
827 if (SCM_CONSP (tmp
) && (SCM_EQ_P (scm_sym_uq_splicing
, SCM_CAR (tmp
))))
831 return scm_append (scm_cons2 (evalcar (tmp
, env
), iqq (SCM_CDR (form
), env
, depth
), SCM_EOL
));
833 return scm_cons (iqq (SCM_CAR (form
), env
, edepth
), iqq (SCM_CDR (form
), env
, depth
));
836 /* Here are acros which return values rather than code. */
838 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
839 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
842 scm_m_delay (SCM xorig
, SCM env
)
844 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
845 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
849 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
850 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
853 scm_m_define (SCM x
, SCM env
)
857 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
860 while (SCM_CONSP (proc
))
861 { /* nested define syntax */
862 x
= scm_cons (scm_cons2 (scm_sym_lambda
, SCM_CDR (proc
), x
), SCM_EOL
);
863 proc
= SCM_CAR (proc
);
865 SCM_ASSYNT (SCM_SYMBOLP (proc
), scm_s_variable
, s_define
);
866 SCM_ASSYNT (1 == scm_ilength (x
), scm_s_expression
, s_define
);
867 if (SCM_TOP_LEVEL (env
))
869 x
= evalcar (x
, env
);
870 #ifdef DEBUG_EXTENSIONS
871 if (SCM_REC_PROCNAMES_P
&& SCM_NIMP (x
))
875 if (SCM_CLOSUREP (arg1
)
876 /* Only the first definition determines the name. */
877 && SCM_FALSEP (scm_procedure_property (arg1
, scm_sym_name
)))
878 scm_set_procedure_property_x (arg1
, scm_sym_name
, proc
);
879 else if (SCM_MACROP (arg1
)
880 /* Dirk::FIXME: Does the following test make sense? */
881 && !SCM_EQ_P (SCM_MACRO_CODE (arg1
), arg1
))
883 arg1
= SCM_MACRO_CODE (arg1
);
888 arg1
= scm_sym2vcell (proc
, scm_env_top_level (env
), SCM_BOOL_T
);
889 SCM_SETCDR (arg1
, x
);
891 return scm_cons2 (scm_sym_quote
, SCM_CAR (arg1
), SCM_EOL
);
893 return SCM_UNSPECIFIED
;
896 return scm_cons2 (SCM_IM_DEFINE
, proc
, x
);
902 scm_m_letrec1 (SCM op
, SCM imm
, SCM xorig
, SCM env
)
904 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
905 char *what
= SCM_SYMBOL_CHARS (SCM_CAR (xorig
));
906 SCM x
= cdrx
, proc
, arg1
; /* structure traversers */
907 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *initloc
= &inits
;
910 SCM_ASSYNT (scm_ilength (proc
) >= 1, scm_s_bindings
, what
);
913 /* vars scm_list reversed here, inits reversed at evaluation */
914 arg1
= SCM_CAR (proc
);
915 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, what
);
916 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, what
);
917 if (scm_c_improper_memq (SCM_CAR (arg1
), vars
))
918 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
919 vars
= scm_cons (SCM_CAR (arg1
), vars
);
920 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
921 initloc
= SCM_CDRLOC (*initloc
);
923 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
925 return scm_cons2 (op
, vars
,
926 scm_cons (inits
, scm_m_body (imm
, SCM_CDR (x
), what
)));
929 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
930 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
933 scm_m_letrec (SCM xorig
, SCM env
)
935 SCM x
= SCM_CDR (xorig
);
936 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_letrec
);
938 if (SCM_NULLP (SCM_CAR (x
))) /* null binding, let* faster */
939 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
,
940 scm_m_body (SCM_IM_LETREC
,
945 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LETREC
, xorig
, env
);
948 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
949 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
952 scm_m_let (SCM xorig
, SCM env
)
954 SCM cdrx
= SCM_CDR (xorig
); /* locally mutable version of form */
955 SCM x
= cdrx
, proc
, arg1
, name
; /* structure traversers */
956 SCM vars
= SCM_EOL
, inits
= SCM_EOL
, *varloc
= &vars
, *initloc
= &inits
;
958 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
962 && SCM_CONSP (SCM_CAR (proc
)) && SCM_NULLP (SCM_CDR (proc
))))
964 /* null or single binding, let* is faster */
965 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), proc
,
966 scm_m_body (SCM_IM_LET
,
972 SCM_ASSYNT (SCM_NIMP (proc
), scm_s_bindings
, s_let
);
973 if (SCM_CONSP (proc
))
975 /* plain let, proc is <bindings> */
976 return scm_m_letrec1 (SCM_IM_LET
, SCM_IM_LET
, xorig
, env
);
979 if (!SCM_SYMBOLP (proc
))
980 scm_misc_error (s_let
, scm_s_bindings
, SCM_EOL
); /* bad let */
981 name
= proc
; /* named let, build equiv letrec */
983 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_body
, s_let
);
984 proc
= SCM_CAR (x
); /* bindings list */
985 SCM_ASSYNT (scm_ilength (proc
) >= 0, scm_s_bindings
, s_let
);
986 while (SCM_NIMP (proc
))
987 { /* vars and inits both in order */
988 arg1
= SCM_CAR (proc
);
989 SCM_ASSYNT (2 == scm_ilength (arg1
), scm_s_bindings
, s_let
);
990 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (arg1
)), scm_s_variable
, s_let
);
991 *varloc
= scm_cons (SCM_CAR (arg1
), SCM_EOL
);
992 varloc
= SCM_CDRLOC (*varloc
);
993 *initloc
= scm_cons (SCM_CAR (SCM_CDR (arg1
)), SCM_EOL
);
994 initloc
= SCM_CDRLOC (*initloc
);
995 proc
= SCM_CDR (proc
);
998 proc
= scm_cons2 (scm_sym_lambda
, vars
,
999 scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let"));
1000 proc
= scm_cons2 (scm_sym_let
, scm_cons (scm_cons2 (name
, proc
, SCM_EOL
),
1002 scm_acons (name
, inits
, SCM_EOL
));
1003 return scm_m_letrec1 (SCM_IM_LETREC
, SCM_IM_LET
, proc
, env
);
1007 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1008 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1009 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1012 scm_m_apply (SCM xorig
, SCM env
)
1014 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1015 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1019 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1020 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1024 scm_m_cont (SCM xorig
, SCM env
)
1026 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1027 scm_s_expression
, s_atcall_cc
);
1028 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1031 /* Multi-language support */
1036 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1039 scm_m_nil_cond (SCM xorig
, SCM env
)
1041 int len
= scm_ilength (SCM_CDR (xorig
));
1042 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1043 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1046 SCM_SYNTAX (s_nil_ify
, "nil-ify", scm_makmmacro
, scm_m_nil_ify
);
1049 scm_m_nil_ify (SCM xorig
, SCM env
)
1051 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "nil-ify");
1052 return scm_cons (SCM_IM_NIL_IFY
, SCM_CDR (xorig
));
1055 SCM_SYNTAX (s_t_ify
, "t-ify", scm_makmmacro
, scm_m_t_ify
);
1058 scm_m_t_ify (SCM xorig
, SCM env
)
1060 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "t-ify");
1061 return scm_cons (SCM_IM_T_IFY
, SCM_CDR (xorig
));
1064 SCM_SYNTAX (s_0_cond
, "0-cond", scm_makmmacro
, scm_m_0_cond
);
1067 scm_m_0_cond (SCM xorig
, SCM env
)
1069 int len
= scm_ilength (SCM_CDR (xorig
));
1070 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "0-cond");
1071 return scm_cons (SCM_IM_0_COND
, SCM_CDR (xorig
));
1074 SCM_SYNTAX (s_0_ify
, "0-ify", scm_makmmacro
, scm_m_0_ify
);
1077 scm_m_0_ify (SCM xorig
, SCM env
)
1079 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "0-ify");
1080 return scm_cons (SCM_IM_0_IFY
, SCM_CDR (xorig
));
1083 SCM_SYNTAX (s_1_ify
, "1-ify", scm_makmmacro
, scm_m_1_ify
);
1086 scm_m_1_ify (SCM xorig
, SCM env
)
1088 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, "1-ify");
1089 return scm_cons (SCM_IM_1_IFY
, SCM_CDR (xorig
));
1092 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1095 scm_m_atfop (SCM xorig
, SCM env
)
1097 SCM x
= SCM_CDR (xorig
), vcell
;
1098 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1099 vcell
= scm_symbol_fref (SCM_CAR (x
));
1100 SCM_ASSYNT (SCM_CONSP (vcell
),
1101 "Symbol's function definition is void", NULL
);
1102 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (vcell
) + scm_tc3_cons_gloc
);
1106 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1109 scm_m_atbind (SCM xorig
, SCM env
)
1111 SCM x
= SCM_CDR (xorig
);
1112 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, "@bind");
1118 while (SCM_NIMP (SCM_CDR (env
)))
1119 env
= SCM_CDR (env
);
1120 env
= SCM_CAR (env
);
1121 if (SCM_CONSP (env
))
1126 while (SCM_NIMP (x
))
1128 SCM_SET_CELL_WORD_0 (x
, SCM_UNPACK (scm_sym2vcell (SCM_CAR (x
), env
, SCM_BOOL_T
)) + scm_tc3_cons_gloc
);
1131 return scm_cons (SCM_IM_BIND
, SCM_CDR (xorig
));
1134 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1135 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1138 scm_m_at_call_with_values (SCM xorig
, SCM env
)
1140 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1141 scm_s_expression
, s_at_call_with_values
);
1142 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1146 scm_m_expand_body (SCM xorig
, SCM env
)
1148 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1149 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1151 while (SCM_NIMP (x
))
1153 SCM form
= SCM_CAR (x
);
1154 if (!SCM_CONSP (form
))
1156 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1159 form
= scm_macroexp (scm_cons_source (form
,
1164 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1166 defs
= scm_cons (SCM_CDR (form
), defs
);
1169 else if (!SCM_IMP (defs
))
1173 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1175 x
= scm_append (scm_cons2 (SCM_CDR (form
), SCM_CDR (x
), SCM_EOL
));
1179 x
= scm_cons (form
, SCM_CDR (x
));
1184 SCM_ASSYNT (SCM_NIMP (x
), scm_s_body
, what
);
1185 if (SCM_NIMP (defs
))
1187 x
= scm_cons (scm_m_letrec1 (SCM_IM_LETREC
,
1189 scm_cons2 (scm_sym_define
, defs
, x
),
1195 SCM_SETCAR (xorig
, SCM_CAR (x
));
1196 SCM_SETCDR (xorig
, SCM_CDR (x
));
1203 scm_macroexp (SCM x
, SCM env
)
1207 /* Don't bother to produce error messages here. We get them when we
1208 eventually execute the code for real. */
1211 if (!SCM_SYMBOLP (SCM_CAR (x
)))
1216 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1217 if (proc_ptr
== NULL
)
1219 /* We have lost the race. */
1225 proc
= *scm_lookupcar (x
, env
, 0);
1228 /* Only handle memoizing macros. `Acros' and `macros' are really
1229 special forms and should not be evaluated here. */
1231 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1235 res
= scm_apply (SCM_MACRO_CODE (proc
), x
, scm_cons (env
, scm_listofnull
));
1237 if (scm_ilength (res
) <= 0)
1238 res
= scm_cons2 (SCM_IM_BEGIN
, res
, SCM_EOL
);
1241 SCM_SETCAR (x
, SCM_CAR (res
));
1242 SCM_SETCDR (x
, SCM_CDR (res
));
1248 /* scm_unmemocopy takes a memoized expression together with its
1249 * environment and rewrites it to its original form. Thus, it is the
1250 * inversion of the rewrite rules above. The procedure is not
1251 * optimized for speed. It's used in scm_iprin1 when printing the
1252 * code of a closure, in scm_procedure_source, in display_frame when
1253 * generating the source for a stackframe in a backtrace, and in
1254 * display_expression.
1257 /* We should introduce an anti-macro interface so that it is possible
1258 * to plug in transformers in both directions from other compilation
1259 * units. unmemocopy could then dispatch to anti-macro transformers.
1260 * (Those transformers could perhaps be written in slightly more
1261 * readable style... :)
1264 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1267 unmemocopy (SCM x
, SCM env
)
1270 #ifdef DEBUG_EXTENSIONS
1273 if (SCM_NCELLP (x
) || SCM_NECONSP (x
))
1275 #ifdef DEBUG_EXTENSIONS
1276 p
= scm_whash_lookup (scm_source_whash
, x
);
1278 switch (SCM_TYP7 (x
))
1280 case SCM_BIT8(SCM_IM_AND
):
1281 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1283 case SCM_BIT8(SCM_IM_BEGIN
):
1284 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1286 case SCM_BIT8(SCM_IM_CASE
):
1287 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1289 case SCM_BIT8(SCM_IM_COND
):
1290 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1292 case SCM_BIT8(SCM_IM_DO
):
1293 ls
= scm_cons (scm_sym_do
, SCM_UNSPECIFIED
);
1295 case SCM_BIT8(SCM_IM_IF
):
1296 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1298 case SCM_BIT8(SCM_IM_LET
):
1299 ls
= scm_cons (scm_sym_let
, SCM_UNSPECIFIED
);
1301 case SCM_BIT8(SCM_IM_LETREC
):
1304 ls
= scm_cons (scm_sym_letrec
, SCM_UNSPECIFIED
);
1308 f
= v
= SCM_CAR (x
);
1310 z
= EXTEND_ENV (f
, SCM_EOL
, env
);
1312 e
= scm_reverse (unmemocopy (SCM_CAR (x
),
1313 SCM_EQ_P (SCM_CAR (ls
), scm_sym_letrec
) ? z
: env
));
1316 s
= SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
)
1317 ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x
))), env
))
1319 /* build transformed binding list */
1321 while (SCM_NIMP (v
))
1323 z
= scm_acons (SCM_CAR (v
),
1324 scm_cons (SCM_CAR (e
),
1325 SCM_EQ_P (SCM_CAR (s
), SCM_CAR (v
))
1327 : scm_cons (SCM_CAR (s
), SCM_EOL
)),
1333 z
= scm_cons (z
, SCM_UNSPECIFIED
);
1335 if (SCM_EQ_P (SCM_CAR (ls
), scm_sym_do
))
1339 SCM_SETCDR (z
, scm_cons (unmemocopy (SCM_CAR (x
), env
),
1342 x
= (SCM
) (SCM_CARLOC (SCM_CDR (x
)) - 1);
1343 /* body forms are now to be found in SCM_CDR (x)
1344 (this is how *real* code look like! :) */
1348 case SCM_BIT8(SCM_IM_LETSTAR
):
1356 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1359 y
= z
= scm_acons (SCM_CAR (b
),
1361 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1363 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1364 b
= SCM_CDR (SCM_CDR (b
));
1367 SCM_SETCDR (y
, SCM_EOL
);
1368 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1373 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1375 scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b
)), env
), SCM_EOL
), env
),
1378 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1379 b
= SCM_CDR (SCM_CDR (b
));
1381 while (SCM_NIMP (b
));
1382 SCM_SETCDR (z
, SCM_EOL
);
1384 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1387 case SCM_BIT8(SCM_IM_OR
):
1388 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1390 case SCM_BIT8(SCM_IM_LAMBDA
):
1392 ls
= scm_cons (scm_sym_lambda
,
1393 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
));
1394 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1396 case SCM_BIT8(SCM_IM_QUOTE
):
1397 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1399 case SCM_BIT8(SCM_IM_SET_X
):
1400 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1402 case SCM_BIT8(SCM_IM_DEFINE
):
1406 ls
= scm_cons (scm_sym_define
,
1407 z
= scm_cons (n
= SCM_CAR (x
), SCM_UNSPECIFIED
));
1408 if (SCM_NNULLP (env
))
1409 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAR (SCM_CAR (env
))));
1412 case SCM_BIT8(SCM_MAKISYM (0)):
1416 switch (SCM_ISYMNUM (z
))
1418 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1419 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1421 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1422 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1424 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1425 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1428 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1429 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1432 /* appease the Sun compiler god: */ ;
1436 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1441 while (SCM_CELLP (x
= SCM_CDR (x
)) && SCM_ECONSP (x
))
1443 if (SCM_ISYMP (SCM_CAR (x
)))
1444 /* skip body markers */
1446 SCM_SETCDR (z
, unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1452 #ifdef DEBUG_EXTENSIONS
1453 if (SCM_NFALSEP (p
))
1454 scm_whash_insert (scm_source_whash
, ls
, p
);
1461 scm_unmemocopy (SCM x
, SCM env
)
1463 if (SCM_NNULLP (env
))
1464 /* Make a copy of the lowest frame to protect it from
1465 modifications by SCM_IM_DEFINE */
1466 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1468 return unmemocopy (x
, env
);
1471 #ifndef SCM_RECKLESS
1474 scm_badargsp (SCM formals
, SCM args
)
1476 while (SCM_NIMP (formals
))
1478 if (SCM_NCONSP (formals
))
1482 formals
= SCM_CDR (formals
);
1483 args
= SCM_CDR (args
);
1485 return SCM_NNULLP (args
) ? 1 : 0;
1490 scm_badformalsp (SCM closure
, int n
)
1492 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1493 while (!SCM_NULLP (formals
))
1495 if (!SCM_CONSP (formals
))
1500 formals
= SCM_CDR (formals
);
1507 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1509 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1510 while (!SCM_IMP (l
))
1515 if (SCM_IMP (SCM_CAR (l
)))
1516 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1518 res
= EVALCELLCAR (l
, env
);
1520 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1522 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1524 res
= SCM_CAR (l
); /* struct planted in code */
1526 res
= SCM_PACK (vcell
);
1531 res
= EVALCAR (l
, env
);
1533 *lloc
= scm_cons (res
, SCM_EOL
);
1534 lloc
= SCM_CDRLOC (*lloc
);
1541 scm_wrong_num_args (proc
);
1548 scm_eval_body (SCM code
, SCM env
)
1553 while (SCM_NNULLP (next
= SCM_CDR (next
)))
1555 if (SCM_IMP (SCM_CAR (code
)))
1557 if (SCM_ISYMP (SCM_CAR (code
)))
1559 code
= scm_m_expand_body (code
, env
);
1564 SCM_XEVAL (SCM_CAR (code
), env
);
1567 return SCM_XEVALCAR (code
, env
);
1574 /* SECTION: This code is specific for the debugging support. One
1575 * branch is read when DEVAL isn't defined, the other when DEVAL is
1581 #define SCM_APPLY scm_apply
1582 #define PREP_APPLY(proc, args)
1584 #define RETURN(x) return x;
1585 #ifdef STACK_CHECKING
1586 #ifndef NO_CEVAL_STACK_CHECKING
1587 #define EVAL_STACK_CHECKING
1594 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1596 #define SCM_APPLY scm_dapply
1598 #define PREP_APPLY(p, l) \
1599 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1601 #define ENTER_APPLY \
1603 SCM_SET_ARGSREADY (debug);\
1604 if (CHECK_APPLY && SCM_TRAPS_P)\
1605 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1607 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1608 SCM_SET_TRACED_FRAME (debug); \
1609 if (SCM_CHEAPTRAPS_P)\
1611 tmp = scm_make_debugobj (&debug);\
1612 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1617 tmp = scm_make_continuation (&first);\
1619 scm_ithrow (scm_sym_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
1624 #define RETURN(e) {proc = (e); goto exit;}
1625 #ifdef STACK_CHECKING
1626 #ifndef EVAL_STACK_CHECKING
1627 #define EVAL_STACK_CHECKING
1631 /* scm_ceval_ptr points to the currently selected evaluator.
1632 * *fixme*: Although efficiency is important here, this state variable
1633 * should probably not be a global. It should be related to the
1638 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1640 /* scm_last_debug_frame contains a pointer to the last debugging
1641 * information stack frame. It is accessed very often from the
1642 * debugging evaluator, so it should probably not be indirectly
1643 * addressed. Better to save and restore it from the current root at
1648 scm_debug_frame
*scm_last_debug_frame
;
1651 /* scm_debug_eframe_size is the number of slots available for pseudo
1652 * stack frames at each real stack frame.
1655 int scm_debug_eframe_size
;
1657 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1661 scm_option scm_eval_opts
[] = {
1662 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1665 scm_option scm_debug_opts
[] = {
1666 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1667 "*Flyweight representation of the stack at traps." },
1668 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1669 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1670 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1671 "Record procedure names at definition." },
1672 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1673 "Display backtrace in anti-chronological order." },
1674 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1675 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1676 { SCM_OPTION_INTEGER
, "frames", 3,
1677 "Maximum number of tail-recursive frames in backtrace." },
1678 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1679 "Maximal number of stored backtrace frames." },
1680 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1681 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1682 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1683 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." }
1686 scm_option scm_evaluator_trap_table
[] = {
1687 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1688 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1689 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1690 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." }
1693 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1695 "Option interface for the evaluation options. Instead of using\n"
1696 "this procedure directly, use the procedures @code{eval-enable},\n"
1697 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1698 #define FUNC_NAME s_scm_eval_options_interface
1702 ans
= scm_options (setting
,
1706 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1712 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1714 "Option interface for the evaluator trap options.")
1715 #define FUNC_NAME s_scm_evaluator_traps
1719 ans
= scm_options (setting
,
1720 scm_evaluator_trap_table
,
1721 SCM_N_EVALUATOR_TRAPS
,
1723 SCM_RESET_DEBUG_MODE
;
1730 scm_deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1732 SCM
*results
= lloc
, res
;
1733 while (!SCM_IMP (l
))
1738 if (SCM_IMP (SCM_CAR (l
)))
1739 res
= SCM_EVALIM (SCM_CAR (l
), env
);
1741 res
= EVALCELLCAR (l
, env
);
1743 else if (SCM_TYP3 (l
) == scm_tc3_cons_gloc
)
1745 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (l
) [scm_vtable_index_vcell
];
1747 res
= SCM_CAR (l
); /* struct planted in code */
1749 res
= SCM_PACK (vcell
);
1754 res
= EVALCAR (l
, env
);
1756 *lloc
= scm_cons (res
, SCM_EOL
);
1757 lloc
= SCM_CDRLOC (*lloc
);
1764 scm_wrong_num_args (proc
);
1773 /* SECTION: Some local definitions for the evaluator.
1776 /* Update the toplevel environment frame ENV so that it refers to the
1779 #define UPDATE_TOPLEVEL_ENV(env) \
1781 SCM p = scm_current_module_lookup_closure (); \
1782 if (p != SCM_CAR(env)) \
1783 env = scm_top_level_env (p); \
1787 #define CHECK_EQVISH(A,B) (SCM_EQ_P ((A), (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
1790 #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
1792 /* SECTION: This is the evaluator. Like any real monster, it has
1793 * three heads. This code is compiled twice.
1799 scm_ceval (SCM x
, SCM env
)
1805 scm_deval (SCM x
, SCM env
)
1810 SCM_CEVAL (SCM x
, SCM env
)
1819 scm_debug_frame debug
;
1820 scm_debug_info
*debug_info_end
;
1821 debug
.prev
= scm_last_debug_frame
;
1822 debug
.status
= scm_debug_eframe_size
;
1824 * The debug.vect contains twice as much scm_debug_info frames as the
1825 * user has specified with (debug-set! frames <n>).
1827 * Even frames are eval frames, odd frames are apply frames.
1829 debug
.vect
= (scm_debug_info
*) alloca (scm_debug_eframe_size
1830 * sizeof (debug
.vect
[0]));
1831 debug
.info
= debug
.vect
;
1832 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1833 scm_last_debug_frame
= &debug
;
1835 #ifdef EVAL_STACK_CHECKING
1836 if (scm_stack_checking_enabled_p
1837 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1840 debug
.info
->e
.exp
= x
;
1841 debug
.info
->e
.env
= env
;
1843 scm_report_stack_overflow ();
1850 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1853 SCM_CLEAR_ARGSREADY (debug
);
1854 if (SCM_OVERFLOWP (debug
))
1857 * In theory, this should be the only place where it is necessary to
1858 * check for space in debug.vect since both eval frames and
1859 * available space are even.
1861 * For this to be the case, however, it is necessary that primitive
1862 * special forms which jump back to `loop', `begin' or some similar
1863 * label call PREP_APPLY. A convenient way to do this is to jump to
1864 * `loopnoap' or `cdrxnoap'.
1866 else if (++debug
.info
>= debug_info_end
)
1868 SCM_SET_OVERFLOW (debug
);
1872 debug
.info
->e
.exp
= x
;
1873 debug
.info
->e
.env
= env
;
1874 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1875 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1877 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1878 SCM_SET_TAILREC (debug
);
1879 if (SCM_CHEAPTRAPS_P
)
1880 t
.arg1
= scm_make_debugobj (&debug
);
1884 SCM val
= scm_make_continuation (&first
);
1896 /* This gives the possibility for the debugger to
1897 modify the source expression before evaluation. */
1901 scm_ithrow (scm_sym_enter_frame
,
1902 scm_cons2 (t
.arg1
, tail
,
1903 scm_cons (scm_unmemocopy (x
, env
), SCM_EOL
)),
1907 #if defined (USE_THREADS) || defined (DEVAL)
1911 switch (SCM_TYP7 (x
))
1913 case scm_tc7_symbol
:
1914 /* Only happens when called at top level.
1916 x
= scm_cons (x
, SCM_UNDEFINED
);
1919 case SCM_BIT8(SCM_IM_AND
):
1922 while (SCM_NNULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1923 if (SCM_FALSEP (EVALCAR (x
, env
)))
1925 RETURN (SCM_BOOL_F
);
1929 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1932 case SCM_BIT8(SCM_IM_BEGIN
):
1933 /* (currently unused)
1935 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1936 /* (currently unused)
1941 /* If we are on toplevel with a lookup closure, we need to sync
1942 with the current module. */
1943 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1946 UPDATE_TOPLEVEL_ENV (env
);
1947 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1951 UPDATE_TOPLEVEL_ENV (env
);
1956 goto nontoplevel_begin
;
1958 nontoplevel_cdrxnoap
:
1959 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1960 nontoplevel_cdrxbegin
:
1964 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
1966 if (SCM_IMP (SCM_CAR (x
)))
1968 if (SCM_ISYMP (SCM_CAR (x
)))
1970 x
= scm_m_expand_body (x
, env
);
1971 goto nontoplevel_begin
;
1974 SCM_EVALIM2 (SCM_CAR (x
));
1977 SCM_CEVAL (SCM_CAR (x
), env
);
1981 carloop
: /* scm_eval car of last form in list */
1982 if (!SCM_CELLP (SCM_CAR (x
)))
1985 RETURN (SCM_IMP (x
) ? SCM_EVALIM (x
, env
) : SCM_GLOC_VAL (x
))
1988 if (SCM_SYMBOLP (SCM_CAR (x
)))
1991 RETURN (*scm_lookupcar (x
, env
, 1))
1995 goto loop
; /* tail recurse */
1998 case SCM_BIT8(SCM_IM_CASE
):
2000 t
.arg1
= EVALCAR (x
, env
);
2001 while (SCM_NIMP (x
= SCM_CDR (x
)))
2004 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (proc
)))
2007 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2010 proc
= SCM_CAR (proc
);
2011 while (SCM_NIMP (proc
))
2013 if (CHECK_EQVISH (SCM_CAR (proc
), t
.arg1
))
2015 x
= SCM_CDR (SCM_CAR (x
));
2016 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2019 proc
= SCM_CDR (proc
);
2022 RETURN (SCM_UNSPECIFIED
)
2025 case SCM_BIT8(SCM_IM_COND
):
2026 while (!SCM_IMP (x
= SCM_CDR (x
)))
2029 t
.arg1
= EVALCAR (proc
, env
);
2030 if (SCM_NFALSEP (t
.arg1
))
2037 if (!SCM_EQ_P (scm_sym_arrow
, SCM_CAR (x
)))
2039 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2043 proc
= EVALCAR (proc
, env
);
2044 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2045 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2047 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2048 goto umwrongnumargs
;
2052 RETURN (SCM_UNSPECIFIED
)
2055 case SCM_BIT8(SCM_IM_DO
):
2057 proc
= SCM_CAR (SCM_CDR (x
)); /* inits */
2058 t
.arg1
= SCM_EOL
; /* values */
2059 while (SCM_NIMP (proc
))
2061 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2062 proc
= SCM_CDR (proc
);
2064 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2065 x
= SCM_CDR (SCM_CDR (x
));
2066 while (proc
= SCM_CAR (x
), SCM_FALSEP (EVALCAR (proc
, env
)))
2068 for (proc
= SCM_CADR (x
); SCM_NIMP (proc
); proc
= SCM_CDR (proc
))
2070 t
.arg1
= SCM_CAR (proc
); /* body */
2071 SIDEVAL (t
.arg1
, env
);
2073 for (t
.arg1
= SCM_EOL
, proc
= SCM_CDDR (x
);
2075 proc
= SCM_CDR (proc
))
2076 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
); /* steps */
2077 env
= EXTEND_ENV (SCM_CAR (SCM_CAR (env
)), t
.arg1
, SCM_CDR (env
));
2081 RETURN (SCM_UNSPECIFIED
);
2082 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2083 goto nontoplevel_begin
;
2086 case SCM_BIT8(SCM_IM_IF
):
2088 if (SCM_NFALSEP (EVALCAR (x
, env
)))
2090 else if (SCM_IMP (x
= SCM_CDR (SCM_CDR (x
))))
2092 RETURN (SCM_UNSPECIFIED
);
2094 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2098 case SCM_BIT8(SCM_IM_LET
):
2100 proc
= SCM_CAR (SCM_CDR (x
));
2104 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2106 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2107 env
= EXTEND_ENV (SCM_CAR (x
), t
.arg1
, env
);
2109 goto nontoplevel_cdrxnoap
;
2112 case SCM_BIT8(SCM_IM_LETREC
):
2114 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2120 t
.arg1
= scm_cons (EVALCAR (proc
, env
), t
.arg1
);
2122 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2123 SCM_SETCDR (SCM_CAR (env
), t
.arg1
);
2124 goto nontoplevel_cdrxnoap
;
2127 case SCM_BIT8(SCM_IM_LETSTAR
):
2132 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2133 goto nontoplevel_cdrxnoap
;
2137 t
.arg1
= SCM_CAR (proc
);
2138 proc
= SCM_CDR (proc
);
2139 env
= EXTEND_ENV (t
.arg1
, EVALCAR (proc
, env
), env
);
2141 while (SCM_NIMP (proc
= SCM_CDR (proc
)));
2142 goto nontoplevel_cdrxnoap
;
2144 case SCM_BIT8(SCM_IM_OR
):
2147 while (!SCM_NULLP (t
.arg1
= SCM_CDR (t
.arg1
)))
2149 x
= EVALCAR (x
, env
);
2150 if (!SCM_FALSEP (x
))
2156 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2160 case SCM_BIT8(SCM_IM_LAMBDA
):
2161 RETURN (scm_closure (SCM_CDR (x
), env
));
2164 case SCM_BIT8(SCM_IM_QUOTE
):
2165 RETURN (SCM_CAR (SCM_CDR (x
)));
2168 case SCM_BIT8(SCM_IM_SET_X
):
2171 switch (SCM_ITAG3 (proc
))
2174 t
.lloc
= scm_lookupcar (x
, env
, 1);
2176 case scm_tc3_cons_gloc
:
2177 t
.lloc
= SCM_GLOC_VAL_LOC (proc
);
2179 #ifdef MEMOIZE_LOCALS
2181 t
.lloc
= scm_ilookup (proc
, env
);
2186 *t
.lloc
= EVALCAR (x
, env
);
2190 RETURN (SCM_UNSPECIFIED
);
2194 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2195 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2197 /* new syntactic forms go here. */
2198 case SCM_BIT8(SCM_MAKISYM (0)):
2200 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2201 switch SCM_ISYMNUM (proc
)
2203 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2205 proc
= EVALCAR (proc
, env
);
2206 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2207 if (SCM_CLOSUREP (proc
))
2210 PREP_APPLY (proc
, SCM_EOL
);
2211 t
.arg1
= SCM_CDR (SCM_CDR (x
));
2212 t
.arg1
= EVALCAR (t
.arg1
, env
);
2214 /* Go here to tail-call a closure. PROC is the closure
2215 and T.ARG1 is the list of arguments. Do not forget to
2218 debug
.info
->a
.args
= t
.arg1
;
2220 #ifndef SCM_RECKLESS
2221 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2225 /* Copy argument list */
2226 if (SCM_IMP (t
.arg1
))
2230 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2231 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2232 && SCM_CONSP (t
.arg1
))
2234 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2238 SCM_SETCDR (tl
, t
.arg1
);
2241 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2242 x
= SCM_CODE (proc
);
2243 goto nontoplevel_cdrxbegin
;
2248 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2251 SCM val
= scm_make_continuation (&first
);
2259 proc
= evalcar (proc
, env
);
2260 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2261 PREP_APPLY (proc
, scm_cons (t
.arg1
, SCM_EOL
));
2263 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2264 goto umwrongnumargs
;
2267 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2268 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)))
2270 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2271 proc
= SCM_CADR (x
); /* unevaluated operands */
2272 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2274 arg2
= *scm_ilookup (proc
, env
);
2275 else if (SCM_NCONSP (proc
))
2277 if (SCM_NCELLP (proc
))
2278 arg2
= SCM_GLOC_VAL (proc
);
2280 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2284 arg2
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2285 t
.lloc
= SCM_CDRLOC (arg2
);
2286 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2288 *t
.lloc
= scm_cons (EVALCAR (proc
, env
), SCM_EOL
);
2289 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2294 /* The type dispatch code is duplicated here
2295 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2296 * cuts down execution time for type dispatch to 50%.
2299 int i
, n
, end
, mask
;
2300 SCM z
= SCM_CDDR (x
);
2301 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2302 proc
= SCM_CADR (z
);
2304 if (SCM_NIMP (proc
))
2306 /* Prepare for linear search */
2309 end
= SCM_VECTOR_LENGTH (proc
);
2313 /* Compute a hash value */
2314 int hashset
= SCM_INUM (proc
);
2316 mask
= SCM_INUM (SCM_CAR (z
= SCM_CDDR (z
)));
2317 proc
= SCM_CADR (z
);
2320 if (SCM_NIMP (t
.arg1
))
2323 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2324 [scm_si_hashsets
+ hashset
];
2325 t
.arg1
= SCM_CDR (t
.arg1
);
2327 while (j
-- && SCM_NIMP (t
.arg1
));
2332 /* Search for match */
2336 z
= SCM_VELTS (proc
)[i
];
2337 t
.arg1
= arg2
; /* list of arguments */
2338 if (SCM_NIMP (t
.arg1
))
2341 /* More arguments than specifiers => CLASS != ENV */
2342 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2344 t
.arg1
= SCM_CDR (t
.arg1
);
2347 while (j
-- && SCM_NIMP (t
.arg1
));
2348 /* Fewer arguments than specifiers => CAR != ENV */
2349 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2352 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2354 SCM_CMETHOD_ENV (z
));
2355 x
= SCM_CMETHOD_CODE (z
);
2356 goto nontoplevel_cdrxbegin
;
2361 z
= scm_memoize_method (x
, arg2
);
2365 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2367 t
.arg1
= EVALCAR (x
, env
);
2368 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]))
2370 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2372 t
.arg1
= EVALCAR (x
, env
);
2375 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2376 = SCM_UNPACK (EVALCAR (proc
, env
));
2377 RETURN (SCM_UNSPECIFIED
)
2379 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2381 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2383 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2384 || SCM_EQ_P (t
.arg1
, scm_lisp_nil
)))
2386 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2388 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2394 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2397 case (SCM_ISYMNUM (SCM_IM_NIL_IFY
)):
2399 RETURN ((SCM_FALSEP (proc
= EVALCAR (x
, env
)) || SCM_NULLP (proc
))
2403 case (SCM_ISYMNUM (SCM_IM_T_IFY
)):
2405 RETURN (SCM_NFALSEP (EVALCAR (x
, env
)) ? scm_lisp_t
: scm_lisp_nil
)
2407 case (SCM_ISYMNUM (SCM_IM_0_COND
)):
2409 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2411 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2412 || SCM_EQ_P (t
.arg1
, SCM_INUM0
)))
2414 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2416 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2422 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2425 case (SCM_ISYMNUM (SCM_IM_0_IFY
)):
2427 RETURN (SCM_FALSEP (proc
= EVALCAR (x
, env
))
2431 case (SCM_ISYMNUM (SCM_IM_1_IFY
)):
2433 RETURN (SCM_NFALSEP (EVALCAR (x
, env
))
2437 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2440 t
.arg1
= SCM_CAR (x
);
2441 arg2
= SCM_CDAR (env
);
2442 while (SCM_NIMP (arg2
))
2444 proc
= SCM_GLOC_VAL (SCM_CAR (t
.arg1
));
2445 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2447 SCM_SETCAR (arg2
, proc
);
2448 t
.arg1
= SCM_CDR (t
.arg1
);
2449 arg2
= SCM_CDR (arg2
);
2451 t
.arg1
= SCM_CAR (x
);
2452 scm_dynwinds
= scm_acons (t
.arg1
, SCM_CDAR (env
), scm_dynwinds
);
2454 arg2
= x
= SCM_CDR (x
);
2455 while (SCM_NNULLP (arg2
= SCM_CDR (arg2
)))
2457 SIDEVAL (SCM_CAR (x
), env
);
2460 proc
= EVALCAR (x
, env
);
2462 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2463 arg2
= SCM_CDAR (env
);
2464 while (SCM_NIMP (arg2
))
2466 SCM_SETCDR (SCM_PACK (SCM_UNPACK (SCM_CAR (t
.arg1
)) - 1L),
2468 t
.arg1
= SCM_CDR (t
.arg1
);
2469 arg2
= SCM_CDR (arg2
);
2474 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2477 x
= EVALCAR (proc
, env
);
2478 proc
= SCM_CDR (proc
);
2479 proc
= EVALCAR (proc
, env
);
2480 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2481 if (SCM_VALUESP (t
.arg1
))
2482 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2484 t
.arg1
= scm_cons (t
.arg1
, SCM_EOL
);
2485 if (SCM_CLOSUREP (proc
))
2487 PREP_APPLY (proc
, t
.arg1
);
2490 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2500 /* scm_everr (x, env,...) */
2501 scm_misc_error (NULL
, "Wrong type to apply: ~S", SCM_LIST1 (proc
));
2502 case scm_tc7_vector
:
2506 case scm_tc7_byvect
:
2513 #ifdef HAVE_LONG_LONGS
2514 case scm_tc7_llvect
:
2517 case scm_tc7_string
:
2518 case scm_tc7_substring
:
2520 case scm_tcs_closures
:
2526 #ifdef MEMOIZE_LOCALS
2527 case SCM_BIT8(SCM_ILOC00
):
2528 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2529 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2530 #ifndef SCM_RECKLESS
2536 #endif /* ifdef MEMOIZE_LOCALS */
2539 case scm_tcs_cons_gloc
: {
2540 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2542 /* This is a struct implanted in the code, not a gloc. */
2545 proc
= SCM_PACK (vcell
);
2546 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2547 #ifndef SCM_RECKLESS
2556 case scm_tcs_cons_nimcar
:
2557 if (SCM_SYMBOLP (SCM_CAR (x
)))
2560 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2563 /* we have lost the race, start again. */
2568 proc
= *scm_lookupcar (x
, env
, 1);
2576 if (SCM_MACROP (proc
))
2582 /* Set a flag during macro expansion so that macro
2583 application frames can be deleted from the backtrace. */
2584 SCM_SET_MACROEXP (debug
);
2586 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2587 scm_cons (env
, scm_listofnull
));
2590 SCM_CLEAR_MACROEXP (debug
);
2592 switch (SCM_MACRO_TYPE (proc
))
2595 if (scm_ilength (t
.arg1
) <= 0)
2596 t
.arg1
= scm_cons2 (SCM_IM_BEGIN
, t
.arg1
, SCM_EOL
);
2598 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2601 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2602 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2606 /* Prevent memoizing of debug info expression. */
2607 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2612 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2613 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2617 if (SCM_NIMP (x
= t
.arg1
))
2625 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2626 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2627 #ifndef SCM_RECKLESS
2631 if (SCM_CLOSUREP (proc
))
2633 arg2
= SCM_CLOSURE_FORMALS (proc
);
2634 t
.arg1
= SCM_CDR (x
);
2635 while (!SCM_NULLP (arg2
))
2637 if (!SCM_CONSP (arg2
))
2639 if (SCM_IMP (t
.arg1
))
2640 goto umwrongnumargs
;
2641 arg2
= SCM_CDR (arg2
);
2642 t
.arg1
= SCM_CDR (t
.arg1
);
2644 if (!SCM_NULLP (t
.arg1
))
2645 goto umwrongnumargs
;
2647 else if (SCM_MACROP (proc
))
2648 goto handle_a_macro
;
2654 PREP_APPLY (proc
, SCM_EOL
);
2655 if (SCM_NULLP (SCM_CDR (x
))) {
2658 switch (SCM_TYP7 (proc
))
2659 { /* no arguments given */
2660 case scm_tc7_subr_0
:
2661 RETURN (SCM_SUBRF (proc
) ());
2662 case scm_tc7_subr_1o
:
2663 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2665 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2666 case scm_tc7_rpsubr
:
2667 RETURN (SCM_BOOL_T
);
2669 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2671 if (!SCM_SMOB_APPLICABLE_P (proc
))
2673 RETURN (SCM_SMOB_APPLY_0 (proc
));
2676 proc
= SCM_CCLO_SUBR (proc
);
2678 debug
.info
->a
.proc
= proc
;
2679 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2683 proc
= SCM_PROCEDURE (proc
);
2685 debug
.info
->a
.proc
= proc
;
2687 if (!SCM_CLOSUREP (proc
))
2689 if (scm_badformalsp (proc
, 0))
2690 goto umwrongnumargs
;
2691 case scm_tcs_closures
:
2692 x
= SCM_CODE (proc
);
2693 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2694 goto nontoplevel_cdrxbegin
;
2695 case scm_tcs_cons_gloc
:
2696 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2698 x
= SCM_ENTITY_PROCEDURE (proc
);
2702 else if (!SCM_I_OPERATORP (proc
))
2707 proc
= (SCM_I_ENTITYP (proc
)
2708 ? SCM_ENTITY_PROCEDURE (proc
)
2709 : SCM_OPERATOR_PROCEDURE (proc
));
2711 debug
.info
->a
.proc
= proc
;
2712 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2714 if (SCM_NIMP (proc
))
2719 case scm_tc7_subr_1
:
2720 case scm_tc7_subr_2
:
2721 case scm_tc7_subr_2o
:
2723 case scm_tc7_subr_3
:
2724 case scm_tc7_lsubr_2
:
2728 /* scm_everr (x, env,...) */
2729 scm_wrong_num_args (proc
);
2731 /* handle macros here */
2736 /* must handle macros by here */
2741 else if (SCM_CONSP (x
))
2743 if (SCM_IMP (SCM_CAR (x
)))
2744 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2746 t
.arg1
= EVALCELLCAR (x
, env
);
2748 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2750 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2752 t
.arg1
= SCM_CAR (x
); /* struct planted in code */
2754 t
.arg1
= SCM_PACK (vcell
);
2759 t
.arg1
= EVALCAR (x
, env
);
2762 debug
.info
->a
.args
= scm_cons (t
.arg1
, SCM_EOL
);
2769 switch (SCM_TYP7 (proc
))
2770 { /* have one argument in t.arg1 */
2771 case scm_tc7_subr_2o
:
2772 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2773 case scm_tc7_subr_1
:
2774 case scm_tc7_subr_1o
:
2775 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2777 if (SCM_SUBRF (proc
))
2779 if (SCM_INUMP (t
.arg1
))
2781 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2783 SCM_ASRTGO (SCM_NIMP (t
.arg1
), floerr
);
2784 if (SCM_REALP (t
.arg1
))
2786 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2789 if (SCM_BIGP (t
.arg1
))
2791 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (t
.arg1
))));
2795 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2796 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2798 proc
= SCM_SNAME (proc
);
2800 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2801 while ('c' != *--chrs
)
2803 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2804 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2805 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2809 case scm_tc7_rpsubr
:
2810 RETURN (SCM_BOOL_T
);
2812 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2815 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2817 RETURN (SCM_SUBRF (proc
) (scm_cons (t
.arg1
, SCM_EOL
)));
2820 if (!SCM_SMOB_APPLICABLE_P (proc
))
2822 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2826 proc
= SCM_CCLO_SUBR (proc
);
2828 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2829 debug
.info
->a
.proc
= proc
;
2833 proc
= SCM_PROCEDURE (proc
);
2835 debug
.info
->a
.proc
= proc
;
2837 if (!SCM_CLOSUREP (proc
))
2839 if (scm_badformalsp (proc
, 1))
2840 goto umwrongnumargs
;
2841 case scm_tcs_closures
:
2843 x
= SCM_CODE (proc
);
2845 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2847 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_cons (t
.arg1
, SCM_EOL
), SCM_ENV (proc
));
2849 goto nontoplevel_cdrxbegin
;
2850 case scm_tcs_cons_gloc
:
2851 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2853 x
= SCM_ENTITY_PROCEDURE (proc
);
2855 arg2
= debug
.info
->a
.args
;
2857 arg2
= scm_cons (t
.arg1
, SCM_EOL
);
2861 else if (!SCM_I_OPERATORP (proc
))
2867 proc
= (SCM_I_ENTITYP (proc
)
2868 ? SCM_ENTITY_PROCEDURE (proc
)
2869 : SCM_OPERATOR_PROCEDURE (proc
));
2871 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2872 debug
.info
->a
.proc
= proc
;
2874 if (SCM_NIMP (proc
))
2879 case scm_tc7_subr_2
:
2880 case scm_tc7_subr_0
:
2881 case scm_tc7_subr_3
:
2882 case scm_tc7_lsubr_2
:
2891 else if (SCM_CONSP (x
))
2893 if (SCM_IMP (SCM_CAR (x
)))
2894 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2896 arg2
= EVALCELLCAR (x
, env
);
2898 else if (SCM_TYP3 (x
) == scm_tc3_cons_gloc
)
2900 scm_bits_t vcell
= SCM_STRUCT_VTABLE_DATA (x
) [scm_vtable_index_vcell
];
2902 arg2
= SCM_CAR (x
); /* struct planted in code */
2904 arg2
= SCM_PACK (vcell
);
2909 arg2
= EVALCAR (x
, env
);
2911 { /* have two or more arguments */
2913 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2916 if (SCM_NULLP (x
)) {
2919 switch (SCM_TYP7 (proc
))
2920 { /* have two arguments */
2921 case scm_tc7_subr_2
:
2922 case scm_tc7_subr_2o
:
2923 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2926 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
2928 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
, arg2
, SCM_EOL
)));
2930 case scm_tc7_lsubr_2
:
2931 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
2932 case scm_tc7_rpsubr
:
2934 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
2936 if (!SCM_SMOB_APPLICABLE_P (proc
))
2938 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
2942 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2943 scm_cons (proc
, debug
.info
->a
.args
),
2946 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
2947 scm_cons2 (proc
, t
.arg1
,
2954 case scm_tcs_cons_gloc
:
2955 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2957 x
= SCM_ENTITY_PROCEDURE (proc
);
2959 arg2
= debug
.info
->a
.args
;
2961 arg2
= scm_cons2 (t
.arg1
, arg2
, SCM_EOL
);
2965 else if (!SCM_I_OPERATORP (proc
))
2971 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2972 ? SCM_ENTITY_PROCEDURE (proc
)
2973 : SCM_OPERATOR_PROCEDURE (proc
),
2974 scm_cons (proc
, debug
.info
->a
.args
),
2977 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
2978 ? SCM_ENTITY_PROCEDURE (proc
)
2979 : SCM_OPERATOR_PROCEDURE (proc
),
2980 scm_cons2 (proc
, t
.arg1
,
2988 case scm_tc7_subr_0
:
2990 case scm_tc7_subr_1o
:
2991 case scm_tc7_subr_1
:
2992 case scm_tc7_subr_3
:
2997 proc
= SCM_PROCEDURE (proc
);
2999 debug
.info
->a
.proc
= proc
;
3001 if (!SCM_CLOSUREP (proc
))
3003 if (scm_badformalsp (proc
, 2))
3004 goto umwrongnumargs
;
3005 case scm_tcs_closures
:
3008 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3012 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3013 scm_cons2 (t
.arg1
, arg2
, SCM_EOL
), SCM_ENV (proc
));
3015 x
= SCM_CODE (proc
);
3016 goto nontoplevel_cdrxbegin
;
3020 if (SCM_IMP (x
) || SCM_NECONSP (x
))
3024 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3025 scm_deval_args (x
, env
, proc
,
3026 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3030 switch (SCM_TYP7 (proc
))
3031 { /* have 3 or more arguments */
3033 case scm_tc7_subr_3
:
3034 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3035 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3036 SCM_CADDR (debug
.info
->a
.args
)));
3038 #ifdef BUILTIN_RPASUBR
3039 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3040 arg2
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3043 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3044 arg2
= SCM_CDR (arg2
);
3046 while (SCM_NIMP (arg2
));
3048 #endif /* BUILTIN_RPASUBR */
3049 case scm_tc7_rpsubr
:
3050 #ifdef BUILTIN_RPASUBR
3051 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3053 t
.arg1
= SCM_CDR (SCM_CDR (debug
.info
->a
.args
));
3056 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3058 arg2
= SCM_CAR (t
.arg1
);
3059 t
.arg1
= SCM_CDR (t
.arg1
);
3061 while (SCM_NIMP (t
.arg1
));
3063 #else /* BUILTIN_RPASUBR */
3064 RETURN (SCM_APPLY (proc
, t
.arg1
,
3066 SCM_CDR (SCM_CDR (debug
.info
->a
.args
)),
3068 #endif /* BUILTIN_RPASUBR */
3069 case scm_tc7_lsubr_2
:
3070 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3071 SCM_CDR (SCM_CDR (debug
.info
->a
.args
))))
3073 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
))
3075 if (!SCM_SMOB_APPLICABLE_P (proc
))
3077 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3078 SCM_CDDR (debug
.info
->a
.args
)));
3082 proc
= SCM_PROCEDURE (proc
);
3083 debug
.info
->a
.proc
= proc
;
3084 if (!SCM_CLOSUREP (proc
))
3086 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3087 goto umwrongnumargs
;
3088 case scm_tcs_closures
:
3089 SCM_SET_ARGSREADY (debug
);
3090 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3093 x
= SCM_CODE (proc
);
3094 goto nontoplevel_cdrxbegin
;
3096 case scm_tc7_subr_3
:
3097 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3098 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3100 #ifdef BUILTIN_RPASUBR
3101 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3104 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3107 while (SCM_NIMP (x
));
3109 #endif /* BUILTIN_RPASUBR */
3110 case scm_tc7_rpsubr
:
3111 #ifdef BUILTIN_RPASUBR
3112 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3116 t
.arg1
= EVALCAR (x
, env
);
3117 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3122 while (SCM_NIMP (x
));
3124 #else /* BUILTIN_RPASUBR */
3125 RETURN (SCM_APPLY (proc
, t
.arg1
,
3127 scm_eval_args (x
, env
, proc
),
3129 #endif /* BUILTIN_RPASUBR */
3130 case scm_tc7_lsubr_2
:
3131 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3133 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3135 scm_eval_args (x
, env
, proc
))));
3137 if (!SCM_SMOB_APPLICABLE_P (proc
))
3139 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3140 scm_eval_args (x
, env
, proc
)));
3144 proc
= SCM_PROCEDURE (proc
);
3145 if (!SCM_CLOSUREP (proc
))
3148 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3149 if (SCM_NULLP (formals
)
3150 || (SCM_CONSP (formals
)
3151 && (SCM_NULLP (SCM_CDR (formals
))
3152 || (SCM_CONSP (SCM_CDR (formals
))
3153 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3154 goto umwrongnumargs
;
3156 case scm_tcs_closures
:
3158 SCM_SET_ARGSREADY (debug
);
3160 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3163 scm_eval_args (x
, env
, proc
)),
3165 x
= SCM_CODE (proc
);
3166 goto nontoplevel_cdrxbegin
;
3168 case scm_tcs_cons_gloc
:
3169 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3172 arg2
= debug
.info
->a
.args
;
3174 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3176 x
= SCM_ENTITY_PROCEDURE (proc
);
3179 else if (!SCM_I_OPERATORP (proc
))
3183 case scm_tc7_subr_2
:
3184 case scm_tc7_subr_1o
:
3185 case scm_tc7_subr_2o
:
3186 case scm_tc7_subr_0
:
3188 case scm_tc7_subr_1
:
3196 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3197 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3199 SCM_CLEAR_TRACED_FRAME (debug
);
3200 if (SCM_CHEAPTRAPS_P
)
3201 t
.arg1
= scm_make_debugobj (&debug
);
3205 SCM val
= scm_make_continuation (&first
);
3215 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (t
.arg1
, proc
, SCM_EOL
), 0);
3218 scm_last_debug_frame
= debug
.prev
;
3224 /* SECTION: This code is compiled once.
3229 /* This code processes the arguments to apply:
3231 (apply PROC ARG1 ... ARGS)
3233 Given a list (ARG1 ... ARGS), this function conses the ARG1
3234 ... arguments onto the front of ARGS, and returns the resulting
3235 list. Note that ARGS is a list; thus, the argument to this
3236 function is a list whose last element is a list.
3238 Apply calls this function, and applies PROC to the elements of the
3239 result. apply:nconc2last takes care of building the list of
3240 arguments, given (ARG1 ... ARGS).
3242 Rather than do new consing, apply:nconc2last destroys its argument.
3243 On that topic, this code came into my care with the following
3244 beautifully cryptic comment on that topic: "This will only screw
3245 you if you do (scm_apply scm_apply '( ... ))" If you know what
3246 they're referring to, send me a patch to this comment. */
3248 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3250 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3251 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3252 "@var{args}, and returns the resulting list. Note that\n"
3253 "@var{args} is a list; thus, the argument to this function is\n"
3254 "a list whose last element is a list.\n"
3255 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3256 "destroys its argument, so use with care.")
3257 #define FUNC_NAME s_scm_nconc2last
3260 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3262 while (SCM_NNULLP (SCM_CDR (*lloc
)))
3263 lloc
= SCM_CDRLOC (*lloc
);
3264 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3265 *lloc
= SCM_CAR (*lloc
);
3273 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3274 * It is compiled twice.
3280 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3287 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3292 /* Apply a function to a list of arguments.
3294 This function is exported to the Scheme level as taking two
3295 required arguments and a tail argument, as if it were:
3296 (lambda (proc arg1 . args) ...)
3297 Thus, if you just have a list of arguments to pass to a procedure,
3298 pass the list as ARG1, and '() for ARGS. If you have some fixed
3299 args, pass the first as ARG1, then cons any remaining fixed args
3300 onto the front of your argument list, and pass that as ARGS. */
3303 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3305 #ifdef DEBUG_EXTENSIONS
3307 scm_debug_frame debug
;
3308 scm_debug_info debug_vect_body
;
3309 debug
.prev
= scm_last_debug_frame
;
3310 debug
.status
= SCM_APPLYFRAME
;
3311 debug
.vect
= &debug_vect_body
;
3312 debug
.vect
[0].a
.proc
= proc
;
3313 debug
.vect
[0].a
.args
= SCM_EOL
;
3314 scm_last_debug_frame
= &debug
;
3317 return scm_dapply (proc
, arg1
, args
);
3321 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3323 /* If ARGS is the empty list, then we're calling apply with only two
3324 arguments --- ARG1 is the list of arguments for PROC. Whatever
3325 the case, futz with things so that ARG1 is the first argument to
3326 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3329 Setting the debug apply frame args this way is pretty messy.
3330 Perhaps we should store arg1 and args directly in the frame as
3331 received, and let scm_frame_arguments unpack them, because that's
3332 a relatively rare operation. This works for now; if the Guile
3333 developer archives are still around, see Mikael's post of
3335 if (SCM_NULLP (args
))
3337 if (SCM_NULLP (arg1
))
3339 arg1
= SCM_UNDEFINED
;
3341 debug
.vect
[0].a
.args
= SCM_EOL
;
3347 debug
.vect
[0].a
.args
= arg1
;
3349 args
= SCM_CDR (arg1
);
3350 arg1
= SCM_CAR (arg1
);
3355 args
= scm_nconc2last (args
);
3357 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3361 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3364 if (SCM_CHEAPTRAPS_P
)
3365 tmp
= scm_make_debugobj (&debug
);
3370 tmp
= scm_make_continuation (&first
);
3374 scm_ithrow (scm_sym_enter_frame
, scm_cons (tmp
, SCM_EOL
), 0);
3380 switch (SCM_TYP7 (proc
))
3382 case scm_tc7_subr_2o
:
3383 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3384 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3385 case scm_tc7_subr_2
:
3386 SCM_ASRTGO (SCM_NNULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3388 args
= SCM_CAR (args
);
3389 RETURN (SCM_SUBRF (proc
) (arg1
, args
))
3390 case scm_tc7_subr_0
:
3391 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3392 RETURN (SCM_SUBRF (proc
) ())
3393 case scm_tc7_subr_1
:
3394 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3395 case scm_tc7_subr_1o
:
3396 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3397 RETURN (SCM_SUBRF (proc
) (arg1
))
3399 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3400 if (SCM_SUBRF (proc
))
3402 if (SCM_INUMP (arg1
))
3404 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3406 SCM_ASRTGO (SCM_NIMP (arg1
), floerr
);
3407 if (SCM_REALP (arg1
))
3409 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3412 if (SCM_BIGP (arg1
))
3413 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_big2dbl (arg1
))))
3416 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3417 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3419 proc
= SCM_SNAME (proc
);
3421 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3422 while ('c' != *--chrs
)
3424 SCM_ASSERT (SCM_CONSP (arg1
),
3425 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3426 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3430 case scm_tc7_subr_3
:
3431 SCM_ASRTGO (SCM_NNULLP (args
)
3432 && SCM_NNULLP (SCM_CDR (args
))
3433 && SCM_NULLP (SCM_CDDR (args
)),
3435 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CAR (SCM_CDR (args
))))
3438 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
))
3440 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)))
3442 case scm_tc7_lsubr_2
:
3443 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3444 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)))
3446 if (SCM_NULLP (args
))
3447 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
))
3448 while (SCM_NIMP (args
))
3450 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3451 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3452 args
= SCM_CDR (args
);
3455 case scm_tc7_rpsubr
:
3456 if (SCM_NULLP (args
))
3457 RETURN (SCM_BOOL_T
);
3458 while (SCM_NIMP (args
))
3460 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3461 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3462 RETURN (SCM_BOOL_F
);
3463 arg1
= SCM_CAR (args
);
3464 args
= SCM_CDR (args
);
3466 RETURN (SCM_BOOL_T
);
3467 case scm_tcs_closures
:
3469 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3471 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3473 #ifndef SCM_RECKLESS
3474 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3478 /* Copy argument list */
3483 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3484 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3486 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3490 SCM_SETCDR (tl
, arg1
);
3493 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3494 proc
= SCM_CDR (SCM_CODE (proc
));
3497 while (SCM_NNULLP (arg1
= SCM_CDR (arg1
)))
3499 if (SCM_IMP (SCM_CAR (proc
)))
3501 if (SCM_ISYMP (SCM_CAR (proc
)))
3503 proc
= scm_m_expand_body (proc
, args
);
3507 SCM_EVALIM2 (SCM_CAR (proc
));
3510 SCM_CEVAL (SCM_CAR (proc
), args
);
3513 RETURN (EVALCAR (proc
, args
));
3515 if (!SCM_SMOB_APPLICABLE_P (proc
))
3517 if (SCM_UNBNDP (arg1
))
3518 RETURN (SCM_SMOB_APPLY_0 (proc
))
3519 else if (SCM_NULLP (args
))
3520 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
))
3521 else if (SCM_NULLP (SCM_CDR (args
)))
3522 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)))
3524 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3527 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3529 proc
= SCM_CCLO_SUBR (proc
);
3530 debug
.vect
[0].a
.proc
= proc
;
3531 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3533 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3535 proc
= SCM_CCLO_SUBR (proc
);
3539 proc
= SCM_PROCEDURE (proc
);
3541 debug
.vect
[0].a
.proc
= proc
;
3544 case scm_tcs_cons_gloc
:
3545 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3548 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3550 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3552 RETURN (scm_apply_generic (proc
, args
));
3554 else if (!SCM_I_OPERATORP (proc
))
3559 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3561 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3564 proc
= (SCM_I_ENTITYP (proc
)
3565 ? SCM_ENTITY_PROCEDURE (proc
)
3566 : SCM_OPERATOR_PROCEDURE (proc
));
3568 debug
.vect
[0].a
.proc
= proc
;
3569 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3571 if (SCM_NIMP (proc
))
3577 scm_wrong_num_args (proc
);
3580 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3585 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3586 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3588 SCM_CLEAR_TRACED_FRAME (debug
);
3589 if (SCM_CHEAPTRAPS_P
)
3590 arg1
= scm_make_debugobj (&debug
);
3594 SCM val
= scm_make_continuation (&first
);
3604 scm_ithrow (scm_sym_exit_frame
, scm_cons2 (arg1
, proc
, SCM_EOL
), 0);
3607 scm_last_debug_frame
= debug
.prev
;
3613 /* SECTION: The rest of this file is only read once.
3618 /* Typechecking for multi-argument MAP and FOR-EACH.
3620 Verify that each element of the vector ARGV, except for the first,
3621 is a proper list whose length is LEN. Attribute errors to WHO,
3622 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3624 check_map_args (SCM argv
,
3631 SCM
*ve
= SCM_VELTS (argv
);
3634 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3636 int elt_len
= scm_ilength (ve
[i
]);
3641 scm_apply_generic (gf
, scm_cons (proc
, args
));
3643 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3647 scm_out_of_range (who
, ve
[i
]);
3650 scm_remember_upto_here_1 (argv
);
3654 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3656 /* Note: Currently, scm_map applies PROC to the argument list(s)
3657 sequentially, starting with the first element(s). This is used in
3658 evalext.c where the Scheme procedure `map-in-order', which guarantees
3659 sequential behaviour, is implemented using scm_map. If the
3660 behaviour changes, we need to update `map-in-order'.
3664 scm_map (SCM proc
, SCM arg1
, SCM args
)
3665 #define FUNC_NAME s_map
3670 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3672 len
= scm_ilength (arg1
);
3673 SCM_GASSERTn (len
>= 0,
3674 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3675 SCM_VALIDATE_REST_ARGUMENT (args
);
3676 if (SCM_NULLP (args
))
3678 while (SCM_NIMP (arg1
))
3680 *pres
= scm_cons (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
),
3682 pres
= SCM_CDRLOC (*pres
);
3683 arg1
= SCM_CDR (arg1
);
3687 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3688 ve
= SCM_VELTS (args
);
3689 #ifndef SCM_RECKLESS
3690 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3695 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3697 if (SCM_IMP (ve
[i
]))
3699 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3700 ve
[i
] = SCM_CDR (ve
[i
]);
3702 *pres
= scm_cons (scm_apply (proc
, arg1
, SCM_EOL
), SCM_EOL
);
3703 pres
= SCM_CDRLOC (*pres
);
3709 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3712 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3713 #define FUNC_NAME s_for_each
3715 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3717 len
= scm_ilength (arg1
);
3718 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3719 SCM_ARG2
, s_for_each
);
3720 SCM_VALIDATE_REST_ARGUMENT (args
);
3723 while SCM_NIMP (arg1
)
3725 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3726 arg1
= SCM_CDR (arg1
);
3728 return SCM_UNSPECIFIED
;
3730 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3731 ve
= SCM_VELTS (args
);
3732 #ifndef SCM_RECKLESS
3733 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3738 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3741 (ve
[i
]) return SCM_UNSPECIFIED
;
3742 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3743 ve
[i
] = SCM_CDR (ve
[i
]);
3745 scm_apply (proc
, arg1
, SCM_EOL
);
3752 scm_closure (SCM code
, SCM env
)
3756 SCM_SETCODE (z
, code
);
3757 SCM_SETENV (z
, env
);
3762 scm_bits_t scm_tc16_promise
;
3765 scm_makprom (SCM code
)
3767 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3773 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3775 int writingp
= SCM_WRITINGP (pstate
);
3776 scm_puts ("#<promise ", port
);
3777 SCM_SET_WRITINGP (pstate
, 1);
3778 scm_iprin1 (SCM_CELL_WORD_1 (exp
), port
, pstate
);
3779 SCM_SET_WRITINGP (pstate
, writingp
);
3780 scm_putc ('>', port
);
3785 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3787 "If the promise @var{x} has not been computed yet, compute and\n"
3788 "return @var{x}, otherwise just return the previously computed\n"
3790 #define FUNC_NAME s_scm_force
3792 SCM_VALIDATE_SMOB (1, x
, promise
);
3793 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3795 SCM ans
= scm_apply (SCM_CELL_OBJECT_1 (x
), SCM_EOL
, SCM_EOL
);
3796 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3799 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3800 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3804 return SCM_CELL_OBJECT_1 (x
);
3809 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3811 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3812 "(@pxref{Delayed evaluation,,,r4rs.info,The Revised^4 Report on Scheme}).")
3813 #define FUNC_NAME s_scm_promise_p
3815 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3820 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3821 (SCM xorig
, SCM x
, SCM y
),
3822 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3823 "Any source properties associated with @var{xorig} are also associated\n"
3824 "with the new pair.")
3825 #define FUNC_NAME s_scm_cons_source
3829 SCM_SET_CELL_OBJECT_0 (z
, x
);
3830 SCM_SET_CELL_OBJECT_1 (z
, y
);
3831 /* Copy source properties possibly associated with xorig. */
3832 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3834 scm_whash_insert (scm_source_whash
, z
, p
);
3840 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3842 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3843 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3844 "contents of both pairs and vectors (since both cons cells and vector\n"
3845 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3846 "any other object.")
3847 #define FUNC_NAME s_scm_copy_tree
3852 if (SCM_VECTORP (obj
))
3854 scm_sizet i
= SCM_VECTOR_LENGTH (obj
);
3855 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3857 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
3860 if (SCM_NCONSP (obj
))
3862 ans
= tl
= scm_cons_source (obj
,
3863 scm_copy_tree (SCM_CAR (obj
)),
3865 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3867 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3871 SCM_SETCDR (tl
, obj
);
3877 /* We have three levels of EVAL here:
3879 - scm_i_eval (exp, env)
3881 evaluates EXP in environment ENV. ENV is a lexical environment
3882 structure as used by the actual tree code evaluator. When ENV is
3883 a top-level environment, then changes to the current module are
3884 tracked by updating ENV so that it continues to be in sync with
3887 - scm_primitive_eval (exp)
3889 evaluates EXP in the top-level environment as determined by the
3890 current module. This is done by constructing a suitable
3891 environment and calling scm_i_eval. Thus, changes to the
3892 top-level module are tracked normally.
3894 - scm_eval (exp, mod)
3896 evaluates EXP while MOD is the current module. This is done by
3897 setting the current module to MOD, invoking scm_primitive_eval on
3898 EXP, and then restoring the current module to the value it had
3899 previously. That is, while EXP is evaluated, changes to the
3900 current module are tracked, but these changes do not persist when
3903 For each level of evals, there are two variants, distinguished by a
3904 _x suffix: the ordinary variant does not modify EXP while the _x
3905 variant can destructively modify EXP into something completely
3906 unintelligible. A Scheme data structure passed as EXP to one of the
3907 _x variants should not ever be used again for anything. So when in
3908 doubt, use the ordinary variant.
3913 scm_i_eval_x (SCM exp
, SCM env
)
3915 return SCM_XEVAL (exp
, env
);
3919 scm_i_eval (SCM exp
, SCM env
)
3921 return SCM_XEVAL (exp
, env
);
3925 scm_primitive_eval_x (SCM exp
)
3928 SCM transformer
= scm_current_module_transformer ();
3929 if (SCM_NIMP (transformer
))
3930 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3931 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3932 return scm_i_eval_x (exp
, env
);
3935 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
3937 "Evaluate @var{exp} in the top-level environment specified by\n"
3938 "the current module.")
3939 #define FUNC_NAME s_scm_primitive_eval
3942 SCM transformer
= scm_current_module_transformer ();
3943 if (SCM_NIMP (transformer
))
3944 exp
= scm_apply (transformer
, exp
, scm_listofnull
);
3945 env
= scm_top_level_env (scm_current_module_lookup_closure ());
3946 return scm_i_eval (exp
, env
);
3950 /* Eval does not take the second arg optionally. This is intentional
3951 * in order to be R5RS compatible, and to prepare for the new module
3952 * system, where we would like to make the choice of evaluation
3953 * environment explicit. */
3956 change_environment (void *data
)
3958 SCM pair
= SCM_PACK (data
);
3959 SCM new_module
= SCM_CAR (pair
);
3960 SCM old_module
= scm_current_module ();
3961 SCM_SETCDR (pair
, old_module
);
3962 scm_set_current_module (new_module
);
3967 restore_environment (void *data
)
3969 SCM pair
= SCM_PACK (data
);
3970 SCM old_module
= SCM_CDR (pair
);
3971 SCM new_module
= scm_current_module ();
3972 SCM_SETCAR (pair
, new_module
);
3973 scm_set_current_module (old_module
);
3977 inner_eval_x (void *data
)
3979 return scm_primitive_eval_x (SCM_PACK(data
));
3983 scm_eval_x (SCM exp
, SCM module
)
3984 #define FUNC_NAME "eval!"
3986 SCM_VALIDATE_MODULE (2, module
);
3988 return scm_internal_dynamic_wind
3989 (change_environment
, inner_eval_x
, restore_environment
,
3990 (void *) SCM_UNPACK (exp
),
3991 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
3996 inner_eval (void *data
)
3998 return scm_primitive_eval (SCM_PACK(data
));
4001 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4002 (SCM exp
, SCM module
),
4003 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4004 "in the top-level environment specified by @var{module}.\n"
4005 "While @var{exp} is evaluated (using @var{primitive-eval}),\n"
4006 "@var{module} is made the current module. The current module\n"
4007 "is reset to its previous value when @var{eval} returns.")
4008 #define FUNC_NAME s_scm_eval
4010 SCM_VALIDATE_MODULE (2, module
);
4012 return scm_internal_dynamic_wind
4013 (change_environment
, inner_eval
, restore_environment
,
4014 (void *) SCM_UNPACK (exp
),
4015 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4019 #if (SCM_DEBUG_DEPRECATED == 0)
4021 /* Use scm_current_module () or scm_interaction_environment ()
4022 * instead. The former is the module selected during loading of code.
4023 * The latter is the module in which the user of this thread currently
4024 * types expressions.
4027 SCM scm_top_level_lookup_closure_var
;
4028 SCM scm_system_transformer
;
4030 /* Avoid using this functionality altogether (except for implementing
4031 * libguile, where you can use scm_i_eval or scm_i_eval_x).
4033 * Applications should use either C level scm_eval_x or Scheme
4034 * scm_eval; or scm_primitive_eval_x or scm_primitive_eval. */
4037 scm_eval_3 (SCM obj
, int copyp
, SCM env
)
4040 return scm_i_eval (obj
, env
);
4042 return scm_i_eval_x (obj
, env
);
4045 SCM_DEFINE (scm_eval2
, "eval2", 2, 0, 0,
4046 (SCM obj
, SCM env_thunk
),
4047 "Evaluate @var{exp}, a Scheme expression, in the environment\n"
4048 "designated by @var{lookup}, a symbol-lookup function."
4049 "Do not use this version of eval, it does not play well\n"
4050 "with the module system. Use @code{eval} or\n"
4051 "@code{primitive-eval} instead.")
4052 #define FUNC_NAME s_scm_eval2
4054 return scm_i_eval (obj
, scm_top_level_env (env_thunk
));
4058 #endif /* DEPRECATED */
4061 /* At this point, scm_deval and scm_dapply are generated.
4064 #ifdef DEBUG_EXTENSIONS
4074 scm_init_opts (scm_evaluator_traps
,
4075 scm_evaluator_trap_table
,
4076 SCM_N_EVALUATOR_TRAPS
);
4077 scm_init_opts (scm_eval_options_interface
,
4079 SCM_N_EVAL_OPTIONS
);
4081 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4082 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4083 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4085 scm_f_apply
= scm_make_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4087 scm_lisp_nil
= scm_sysintern ("nil", SCM_UNDEFINED
);
4088 SCM_SETCDR (scm_lisp_nil
, SCM_CAR (scm_lisp_nil
));
4089 scm_lisp_nil
= SCM_CAR (scm_lisp_nil
);
4090 scm_lisp_t
= scm_sysintern ("t", SCM_UNDEFINED
);
4091 SCM_SETCDR (scm_lisp_t
, SCM_CAR (scm_lisp_t
));
4092 scm_lisp_t
= SCM_CAR (scm_lisp_t
);
4097 #if SCM_DEBUG_DEPRECATED == 0
4098 scm_top_level_lookup_closure_var
=
4099 scm_sysintern ("*top-level-lookup-closure*", scm_make_fluid ());
4100 scm_system_transformer
=
4101 scm_sysintern ("scm:eval-transformer", scm_make_fluid ());
4104 #ifndef SCM_MAGIC_SNARFER
4105 #include "libguile/eval.x"
4108 scm_add_feature ("delay");