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. */
44 /* This file is read twice in order to produce debugging versions of
45 * scm_ceval and scm_apply. These functions, scm_deval and
46 * scm_dapply, are produced when we define the preprocessor macro
47 * DEVAL. The file is divided into sections which are treated
48 * differently with respect to DEVAL. The heads of these sections are
49 * marked with the string "SECTION:".
52 /* SECTION: This code is compiled once.
57 /* We need this to get the definitions for HAVE_ALLOCA_H, etc. */
58 #include "libguile/scmconfig.h"
60 /* AIX requires this to be the first thing in the file. The #pragma
61 directive is indented so pre-ANSI compilers will ignore it, rather
70 # ifndef alloca /* predefined by HP cc +Olibcalls */
77 #include "libguile/_scm.h"
78 #include "libguile/debug.h"
79 #include "libguile/dynwind.h"
80 #include "libguile/alist.h"
81 #include "libguile/eq.h"
82 #include "libguile/continuations.h"
83 #include "libguile/throw.h"
84 #include "libguile/smob.h"
85 #include "libguile/macros.h"
86 #include "libguile/procprop.h"
87 #include "libguile/hashtab.h"
88 #include "libguile/hash.h"
89 #include "libguile/srcprop.h"
90 #include "libguile/stackchk.h"
91 #include "libguile/objects.h"
92 #include "libguile/async.h"
93 #include "libguile/feature.h"
94 #include "libguile/modules.h"
95 #include "libguile/ports.h"
96 #include "libguile/root.h"
97 #include "libguile/vectors.h"
98 #include "libguile/fluids.h"
99 #include "libguile/values.h"
101 #include "libguile/validate.h"
102 #include "libguile/eval.h"
103 #include "libguile/lang.h"
107 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
109 if (SCM_EQ_P ((x), SCM_EOL)) \
110 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
115 /* The evaluator contains a plethora of EVAL symbols.
116 * This is an attempt at explanation.
118 * The following macros should be used in code which is read twice
119 * (where the choice of evaluator is hard soldered):
121 * SCM_CEVAL is the symbol used within one evaluator to call itself.
122 * Originally, it is defined to scm_ceval, but is redefined to
123 * scm_deval during the second pass.
125 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
126 * only side effects of expressions matter. All immediates are
129 * SCM_EVALIM is used when it is known that the expression is an
130 * immediate. (This macro never calls an evaluator.)
132 * EVALCAR evaluates the car of an expression.
134 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
135 * car is a lisp cell.
137 * The following macros should be used in code which is read once
138 * (where the choice of evaluator is dynamic):
140 * SCM_XEVAL takes care of immediates without calling an evaluator. It
141 * then calls scm_ceval *or* scm_deval, depending on the debugging
144 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
145 * depending on the debugging mode.
147 * The main motivation for keeping this plethora is efficiency
148 * together with maintainability (=> locality of code).
151 #define SCM_CEVAL scm_ceval
152 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
154 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
155 ? *scm_lookupcar (x, env, 1) \
156 : SCM_CEVAL (SCM_CAR (x), env))
158 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
159 ? SCM_EVALIM (SCM_CAR (x), env) \
160 : EVALCELLCAR (x, env))
162 #define EXTEND_ENV SCM_EXTEND_ENV
164 #ifdef MEMOIZE_LOCALS
167 scm_ilookup (SCM iloc
, SCM env
)
169 register long ir
= SCM_IFRAME (iloc
);
170 register SCM er
= env
;
171 for (; 0 != ir
; --ir
)
174 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
176 if (SCM_ICDRP (iloc
))
177 return SCM_CDRLOC (er
);
178 return SCM_CARLOC (SCM_CDR (er
));
184 /* The Lookup Car Race
187 Memoization of variables and special forms is done while executing
188 the code for the first time. As long as there is only one thread
189 everything is fine, but as soon as two threads execute the same
190 code concurrently `for the first time' they can come into conflict.
192 This memoization includes rewriting variable references into more
193 efficient forms and expanding macros. Furthermore, macro expansion
194 includes `compiling' special forms like `let', `cond', etc. into
195 tree-code instructions.
197 There shouldn't normally be a problem with memoizing local and
198 global variable references (into ilocs and variables), because all
199 threads will mutate the code in *exactly* the same way and (if I
200 read the C code correctly) it is not possible to observe a half-way
201 mutated cons cell. The lookup procedure can handle this
202 transparently without any critical sections.
204 It is different with macro expansion, because macro expansion
205 happens outside of the lookup procedure and can't be
206 undone. Therefore the lookup procedure can't cope with it. It has
207 to indicate failure when it detects a lost race and hope that the
208 caller can handle it. Luckily, it turns out that this is the case.
210 An example to illustrate this: Suppose that the following form will
211 be memoized concurrently by two threads
215 Let's first examine the lookup of X in the body. The first thread
216 decides that it has to find the symbol "x" in the environment and
217 starts to scan it. Then the other thread takes over and actually
218 overtakes the first. It looks up "x" and substitutes an
219 appropriate iloc for it. Now the first thread continues and
220 completes its lookup. It comes to exactly the same conclusions as
221 the second one and could - without much ado - just overwrite the
222 iloc with the same iloc.
224 But let's see what will happen when the race occurs while looking
225 up the symbol "let" at the start of the form. It could happen that
226 the second thread interrupts the lookup of the first thread and not
227 only substitutes a variable for it but goes right ahead and
228 replaces it with the compiled form (#@let* (x 12) x). Now, when
229 the first thread completes its lookup, it would replace the #@let*
230 with a variable containing the "let" binding, effectively reverting
231 the form to (let (x 12) x). This is wrong. It has to detect that
232 it has lost the race and the evaluator has to reconsider the
233 changed form completely.
235 This race condition could be resolved with some kind of traffic
236 light (like mutexes) around scm_lookupcar, but I think that it is
237 best to avoid them in this case. They would serialize memoization
238 completely and because lookup involves calling arbitrary Scheme
239 code (via the lookup-thunk), threads could be blocked for an
240 arbitrary amount of time or even deadlock. But with the current
241 solution a lot of unnecessary work is potentially done. */
243 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
244 return NULL to indicate a failed lookup due to some race conditions
245 between threads. This only happens when VLOC is the first cell of
246 a special form that will eventually be memoized (like `let', etc.)
247 In that case the whole lookup is bogus and the caller has to
248 reconsider the complete special form.
250 SCM_LOOKUPCAR is still there, of course. It just calls
251 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
252 should only be called when it is known that VLOC is not the first
253 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
254 for NULL. I think I've found the only places where this
257 #endif /* USE_THREADS */
259 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
263 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
266 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
270 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
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_EQ_P (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
, real_var
;
328 top_thunk
= SCM_CAR (env
); /* env now refers to a
329 top level env thunk */
333 top_thunk
= SCM_BOOL_F
;
334 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
335 if (SCM_FALSEP (real_var
))
339 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
345 scm_error (scm_unbound_variable_key
, NULL
,
346 "Unbound variable: ~S",
347 scm_list_1 (var
), SCM_BOOL_F
);
349 scm_misc_error (NULL
, "Damaged environment: ~S",
354 /* A variable could not be found, but we shall
355 not throw an error. */
356 static SCM undef_object
= SCM_UNDEFINED
;
357 return &undef_object
;
363 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
365 /* Some other thread has changed the very cell we are working
366 on. In effect, it must have done our job or messed it up
369 var
= SCM_CAR (vloc
);
370 if (SCM_VARIABLEP (var
))
371 return SCM_VARIABLE_LOC (var
);
372 #ifdef MEMOIZE_LOCALS
373 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
374 return scm_ilookup (var
, genv
);
376 /* We can't cope with anything else than variables and ilocs. When
377 a special form has been memoized (i.e. `let' into `#@let') we
378 return NULL and expect the calling function to do the right
379 thing. For the evaluator, this means going back and redoing
380 the dispatch on the car of the form. */
383 #endif /* USE_THREADS */
385 SCM_SETCAR (vloc
, real_var
);
386 return SCM_VARIABLE_LOC (real_var
);
392 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
394 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
401 #define unmemocar scm_unmemocar
403 SCM_SYMBOL (sym_three_question_marks
, "???");
406 scm_unmemocar (SCM form
, SCM env
)
408 if (!SCM_CONSP (form
))
412 SCM c
= SCM_CAR (form
);
413 if (SCM_VARIABLEP (c
))
415 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
416 if (SCM_FALSEP (sym
))
417 sym
= sym_three_question_marks
;
418 SCM_SETCAR (form
, sym
);
420 #ifdef MEMOIZE_LOCALS
421 else if (SCM_ILOCP (c
))
423 unsigned long int ir
;
425 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
427 env
= SCM_CAAR (env
);
428 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
430 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
439 scm_eval_car (SCM pair
, SCM env
)
441 return SCM_XEVALCAR (pair
, env
);
446 * The following rewrite expressions and
447 * some memoized forms have different syntax
450 const char scm_s_expression
[] = "missing or extra expression";
451 const char scm_s_test
[] = "bad test";
452 const char scm_s_body
[] = "bad body";
453 const char scm_s_bindings
[] = "bad bindings";
454 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
455 const char scm_s_variable
[] = "bad variable";
456 const char scm_s_clauses
[] = "bad or missing clauses";
457 const char scm_s_formals
[] = "bad formals";
458 const char scm_s_duplicate_formals
[] = "duplicate formals";
459 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
461 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
462 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
463 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
464 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
465 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
469 #ifdef DEBUG_EXTENSIONS
470 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
471 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
472 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
473 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
477 /* Check that the body denoted by XORIG is valid and rewrite it into
478 its internal form. The internal form of a body is just the body
479 itself, but prefixed with an ISYM that denotes to what kind of
480 outer construct this body belongs. A lambda body starts with
481 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
482 etc. The one exception is a body that belongs to a letrec that has
483 been formed by rewriting internal defines: it starts with
486 /* XXX - Besides controlling the rewriting of internal defines, the
487 additional ISYM could be used for improved error messages.
488 This is not done yet. */
491 scm_m_body (SCM op
, SCM xorig
, const char *what
)
493 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
495 /* Don't add another ISYM if one is present already. */
496 if (SCM_ISYMP (SCM_CAR (xorig
)))
499 /* Retain possible doc string. */
500 if (!SCM_CONSP (SCM_CAR (xorig
)))
502 if (!SCM_NULLP (SCM_CDR (xorig
)))
503 return scm_cons (SCM_CAR (xorig
),
504 scm_m_body (op
, SCM_CDR (xorig
), what
));
508 return scm_cons (op
, xorig
);
512 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
513 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
516 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
518 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
519 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
523 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
524 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
527 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
529 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
530 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
534 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
535 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
538 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
540 long len
= scm_ilength (SCM_CDR (xorig
));
541 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
542 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
546 /* Will go into the RnRS module when Guile is factorized.
547 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
548 const char scm_s_set_x
[] = "set!";
549 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
552 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
554 SCM x
= SCM_CDR (xorig
);
555 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
556 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
557 return scm_cons (SCM_IM_SET_X
, x
);
561 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
562 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
565 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
567 long len
= scm_ilength (SCM_CDR (xorig
));
568 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
570 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
576 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
577 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
580 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
582 long len
= scm_ilength (SCM_CDR (xorig
));
583 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
585 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
591 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
592 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
595 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
598 SCM cdrx
= SCM_CDR (xorig
);
599 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
600 clauses
= SCM_CDR (cdrx
);
601 while (!SCM_NULLP (clauses
))
603 SCM clause
= SCM_CAR (clauses
);
604 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
605 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
606 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
607 && SCM_NULLP (SCM_CDR (clauses
))),
608 scm_s_clauses
, s_case
);
609 clauses
= SCM_CDR (clauses
);
611 return scm_cons (SCM_IM_CASE
, cdrx
);
615 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
616 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
619 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
621 SCM cdrx
= SCM_CDR (xorig
);
623 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
624 while (!SCM_NULLP (clauses
))
626 SCM clause
= SCM_CAR (clauses
);
627 long len
= scm_ilength (clause
);
628 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
629 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
631 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
632 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
634 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
636 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
637 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
639 clauses
= SCM_CDR (clauses
);
641 return scm_cons (SCM_IM_COND
, cdrx
);
645 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
646 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
648 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
649 * cdr of the last cons. (Thus, LIST is not required to be a proper
650 * list and OBJ can also be found in the improper ending.) */
652 scm_c_improper_memq (SCM obj
, SCM list
)
654 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
656 if (SCM_EQ_P (SCM_CAR (list
), obj
))
659 return SCM_EQ_P (list
, obj
);
663 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
666 SCM x
= SCM_CDR (xorig
);
668 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
670 formals
= SCM_CAR (x
);
671 while (SCM_CONSP (formals
))
673 SCM formal
= SCM_CAR (formals
);
674 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
675 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
676 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
677 formals
= SCM_CDR (formals
);
679 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
680 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
682 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
683 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
687 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
688 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
690 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
691 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
693 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
696 SCM x
= SCM_CDR (xorig
);
700 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
702 bindings
= SCM_CAR (x
);
703 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
704 while (!SCM_NULLP (bindings
))
706 SCM binding
= SCM_CAR (bindings
);
707 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
708 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
709 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
710 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
711 bindings
= SCM_CDR (bindings
);
714 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
715 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
719 /* DO gets the most radically altered syntax. The order of the vars is
720 * reversed here. In contrast, the order of the inits and steps is reversed
721 * during the evaluation:
723 (do ((<var1> <init1> <step1>)
731 (#@do (varn ... var2 var1)
732 (<init1> <init2> ... <initn>)
735 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
738 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
739 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
742 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
745 SCM x
= SCM_CDR (xorig
);
748 SCM
*initloc
= &inits
;
750 SCM
*steploc
= &steps
;
751 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
752 bindings
= SCM_CAR (x
);
753 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
754 while (!SCM_NULLP (bindings
))
756 SCM binding
= SCM_CAR (bindings
);
757 long len
= scm_ilength (binding
);
758 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
760 SCM name
= SCM_CAR (binding
);
761 SCM init
= SCM_CADR (binding
);
762 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
763 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
764 vars
= scm_cons (name
, vars
);
765 *initloc
= scm_list_1 (init
);
766 initloc
= SCM_CDRLOC (*initloc
);
767 *steploc
= scm_list_1 (step
);
768 steploc
= SCM_CDRLOC (*steploc
);
769 bindings
= SCM_CDR (bindings
);
773 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
774 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
775 x
= scm_cons2 (vars
, inits
, x
);
776 return scm_cons (SCM_IM_DO
, x
);
780 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
781 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
783 /* Internal function to handle a quasiquotation: 'form' is the parameter in
784 * the call (quasiquotation form), 'env' is the environment where unquoted
785 * expressions will be evaluated, and 'depth' is the current quasiquotation
786 * nesting level and is known to be greater than zero. */
788 iqq (SCM form
, SCM env
, unsigned long int depth
)
790 if (SCM_CONSP (form
))
792 SCM tmp
= SCM_CAR (form
);
793 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
795 SCM args
= SCM_CDR (form
);
796 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
797 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
799 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
801 SCM args
= SCM_CDR (form
);
802 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
804 return scm_eval_car (args
, env
);
806 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
808 else if (SCM_CONSP (tmp
)
809 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
811 SCM args
= SCM_CDR (tmp
);
812 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
815 SCM list
= scm_eval_car (args
, env
);
816 SCM rest
= SCM_CDR (form
);
817 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
818 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
821 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
822 iqq (SCM_CDR (form
), env
, depth
));
825 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
826 iqq (SCM_CDR (form
), env
, depth
));
828 else if (SCM_VECTORP (form
))
830 size_t i
= SCM_VECTOR_LENGTH (form
);
831 SCM
*data
= SCM_VELTS (form
);
834 tmp
= scm_cons (data
[--i
], tmp
);
835 scm_remember_upto_here_1 (form
);
836 return scm_vector (iqq (tmp
, env
, depth
));
843 scm_m_quasiquote (SCM xorig
, SCM env
)
845 SCM x
= SCM_CDR (xorig
);
846 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
847 return iqq (SCM_CAR (x
), env
, 1);
851 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
852 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
854 /* Promises are implemented as closures with an empty parameter list. Thus,
855 * (delay <expression>) is transformed into (#@delay '() <expression>), where
856 * the empty list represents the empty parameter list. This representation
857 * allows for easy creation of the closure during evaluation. */
859 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
861 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
862 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
866 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
867 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
869 /* Guile provides an extension to R5RS' define syntax to represent function
870 * currying in a compact way. With this extension, it is allowed to write
871 * (define <nested-variable> <body>), where <nested-variable> has of one of
872 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
873 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
874 * should be either a sequence of zero or more variables, or a sequence of one
875 * or more variables followed by a space-delimited period and another
876 * variable. Each level of argument nesting wraps the <body> within another
877 * lambda expression. For example, the following forms are allowed, each one
878 * followed by an equivalent, more explicit implementation.
880 * (define ((a b . c) . d) <body>) is equivalent to
881 * (define a (lambda (b . c) (lambda d <body>)))
883 * (define (((a) b) c . d) <body>) is equivalent to
884 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
886 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
887 * module that does not implement this extension. */
889 scm_m_define (SCM x
, SCM env
)
893 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
896 while (SCM_CONSP (name
))
898 /* This while loop realizes function currying by variable nesting. */
899 SCM formals
= SCM_CDR (name
);
900 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
901 name
= SCM_CAR (name
);
903 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
904 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
905 if (SCM_TOP_LEVEL (env
))
908 x
= scm_eval_car (x
, env
);
909 if (SCM_REC_PROCNAMES_P
)
912 while (SCM_MACROP (tmp
))
913 tmp
= SCM_MACRO_CODE (tmp
);
914 if (SCM_CLOSUREP (tmp
)
915 /* Only the first definition determines the name. */
916 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
917 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
919 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
920 SCM_VARIABLE_SET (var
, x
);
921 return SCM_UNSPECIFIED
;
924 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
928 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
929 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
930 * reversed here, the list of inits gets reversed during evaluation. */
932 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
938 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
942 SCM binding
= SCM_CAR (bindings
);
943 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
944 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
945 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
946 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
947 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
948 *initloc
= scm_list_1 (SCM_CADR (binding
));
949 initloc
= SCM_CDRLOC (*initloc
);
950 bindings
= SCM_CDR (bindings
);
952 while (!SCM_NULLP (bindings
));
958 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
959 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
962 scm_m_letrec (SCM xorig
, SCM env
)
964 SCM x
= SCM_CDR (xorig
);
965 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
967 if (SCM_NULLP (SCM_CAR (x
)))
969 /* null binding, let* faster */
970 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
971 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
975 SCM rvars
, inits
, body
;
976 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
977 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
978 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
983 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
984 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
987 scm_m_let (SCM xorig
, SCM env
)
989 SCM x
= SCM_CDR (xorig
);
992 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
995 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
997 /* null or single binding, let* is faster */
999 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
1000 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
1002 else if (SCM_CONSP (temp
))
1005 SCM bindings
= temp
;
1006 SCM rvars
, inits
, body
;
1007 transform_bindings (bindings
, &rvars
, &inits
, "let");
1008 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1009 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1013 /* named let: Transform (let name ((var init) ...) body ...) into
1014 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1018 SCM
*varloc
= &vars
;
1019 SCM inits
= SCM_EOL
;
1020 SCM
*initloc
= &inits
;
1023 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1025 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1026 bindings
= SCM_CAR (x
);
1027 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1028 while (!SCM_NULLP (bindings
))
1029 { /* vars and inits both in order */
1030 SCM binding
= SCM_CAR (bindings
);
1031 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1032 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1033 *varloc
= scm_list_1 (SCM_CAR (binding
));
1034 varloc
= SCM_CDRLOC (*varloc
);
1035 *initloc
= scm_list_1 (SCM_CADR (binding
));
1036 initloc
= SCM_CDRLOC (*initloc
);
1037 bindings
= SCM_CDR (bindings
);
1041 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1042 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1043 SCM rvar
= scm_list_1 (name
);
1044 SCM init
= scm_list_1 (lambda_form
);
1045 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1046 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1047 return scm_cons (letrec
, inits
);
1053 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1054 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1055 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1058 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1060 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1061 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1065 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1066 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1070 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1072 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1073 scm_s_expression
, s_atcall_cc
);
1074 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1077 #ifdef SCM_ENABLE_ELISP
1079 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1082 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1084 long len
= scm_ilength (SCM_CDR (xorig
));
1085 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1086 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1089 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1092 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1094 SCM x
= SCM_CDR (xorig
), var
;
1095 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1096 var
= scm_symbol_fref (SCM_CAR (x
));
1097 /* Passing the symbol name as the `subr' arg here isn't really
1098 right, but without it it can be very difficult to work out from
1099 the error message which function definition was missing. In any
1100 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1101 something equivalent to (signal void-function (list SYM)) in
1103 SCM_ASSYNT (SCM_VARIABLEP (var
),
1104 "Symbol's function definition is void",
1105 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1106 /* Support `defalias'. */
1107 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1109 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1110 SCM_ASSYNT (SCM_VARIABLEP (var
),
1111 "Symbol's function definition is void",
1112 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1114 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1115 former allows for automatically picking up redefinitions of the
1116 corresponding symbol. */
1117 SCM_SETCAR (x
, var
);
1118 /* If the variable contains a procedure, leave the
1119 `transformer-macro' in place so that the procedure's arguments
1120 get properly transformed, and change the initial @fop to
1122 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1124 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1127 /* Otherwise (the variable contains a macro), the arguments should
1128 not be transformed, so cut the `transformer-macro' out and return
1129 the resulting expression starting with the variable. */
1130 SCM_SETCDR (x
, SCM_CDADR (x
));
1134 #endif /* SCM_ENABLE_ELISP */
1136 /* (@bind ((var exp) ...) body ...)
1138 This will assign the values of the `exp's to the global variables
1139 named by `var's (symbols, not evaluated), creating them if they
1140 don't exist, executes body, and then restores the previous values of
1141 the `var's. Additionally, whenever control leaves body, the values
1142 of the `var's are saved and restored when control returns. It is an
1143 error when a symbol appears more than once among the `var's.
1144 All `exp's are evaluated before any `var' is set.
1146 Think of this as `let' for dynamic scope.
1148 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1150 XXX - also implement `@bind*'.
1153 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1156 scm_m_atbind (SCM xorig
, SCM env
)
1158 SCM x
= SCM_CDR (xorig
);
1159 SCM top_level
= scm_env_top_level (env
);
1160 SCM vars
= SCM_EOL
, var
;
1163 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1166 while (SCM_NIMP (x
))
1169 SCM sym_exp
= SCM_CAR (x
);
1170 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1171 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1173 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1174 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1175 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1176 /* The first call to scm_sym2var will look beyond the current
1177 module, while the second call wont. */
1178 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1179 if (SCM_FALSEP (var
))
1180 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1181 vars
= scm_cons (var
, vars
);
1182 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1184 return scm_cons (SCM_IM_BIND
,
1185 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1189 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1190 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1193 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1195 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1196 scm_s_expression
, s_at_call_with_values
);
1197 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1201 scm_m_expand_body (SCM xorig
, SCM env
)
1203 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1204 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1206 while (SCM_NIMP (x
))
1208 SCM form
= SCM_CAR (x
);
1209 if (!SCM_CONSP (form
))
1211 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1214 form
= scm_macroexp (scm_cons_source (form
,
1219 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1221 defs
= scm_cons (SCM_CDR (form
), defs
);
1224 else if (!SCM_IMP (defs
))
1228 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1230 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1234 x
= scm_cons (form
, SCM_CDR (x
));
1239 if (!SCM_NULLP (defs
))
1241 SCM rvars
, inits
, body
, letrec
;
1242 transform_bindings (defs
, &rvars
, &inits
, what
);
1243 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1244 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1245 SCM_SETCAR (xorig
, letrec
);
1246 SCM_SETCDR (xorig
, SCM_EOL
);
1250 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1251 SCM_SETCAR (xorig
, SCM_CAR (x
));
1252 SCM_SETCDR (xorig
, SCM_CDR (x
));
1259 scm_macroexp (SCM x
, SCM env
)
1261 SCM res
, proc
, orig_sym
;
1263 /* Don't bother to produce error messages here. We get them when we
1264 eventually execute the code for real. */
1267 orig_sym
= SCM_CAR (x
);
1268 if (!SCM_SYMBOLP (orig_sym
))
1273 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1274 if (proc_ptr
== NULL
)
1276 /* We have lost the race. */
1282 proc
= *scm_lookupcar (x
, env
, 0);
1285 /* Only handle memoizing macros. `Acros' and `macros' are really
1286 special forms and should not be evaluated here. */
1288 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1291 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1292 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1294 if (scm_ilength (res
) <= 0)
1295 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1298 SCM_SETCAR (x
, SCM_CAR (res
));
1299 SCM_SETCDR (x
, SCM_CDR (res
));
1305 /* scm_unmemocopy takes a memoized expression together with its
1306 * environment and rewrites it to its original form. Thus, it is the
1307 * inversion of the rewrite rules above. The procedure is not
1308 * optimized for speed. It's used in scm_iprin1 when printing the
1309 * code of a closure, in scm_procedure_source, in display_frame when
1310 * generating the source for a stackframe in a backtrace, and in
1311 * display_expression.
1313 * Unmemoizing is not a reliable process. You cannot in general
1314 * expect to get the original source back.
1316 * However, GOOPS currently relies on this for method compilation.
1317 * This ought to change.
1320 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1323 build_binding_list (SCM names
, SCM inits
)
1325 SCM bindings
= SCM_EOL
;
1326 while (!SCM_NULLP (names
))
1328 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1329 bindings
= scm_cons (binding
, bindings
);
1330 names
= SCM_CDR (names
);
1331 inits
= SCM_CDR (inits
);
1337 unmemocopy (SCM x
, SCM env
)
1340 #ifdef DEBUG_EXTENSIONS
1345 #ifdef DEBUG_EXTENSIONS
1346 p
= scm_whash_lookup (scm_source_whash
, x
);
1348 switch (SCM_ITAG7 (SCM_CAR (x
)))
1350 case SCM_BIT8(SCM_IM_AND
):
1351 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1353 case SCM_BIT8(SCM_IM_BEGIN
):
1354 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1356 case SCM_BIT8(SCM_IM_CASE
):
1357 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1359 case SCM_BIT8(SCM_IM_COND
):
1360 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1362 case SCM_BIT8 (SCM_IM_DO
):
1364 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1365 * where nx is the name of a local variable, ix is an initializer for
1366 * the local variable, test is the test clause of the do loop, body is
1367 * the body of the do loop and sx are the step clauses for the local
1369 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1372 names
= SCM_CAR (x
);
1374 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1375 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1377 test
= unmemocopy (SCM_CAR (x
), env
);
1379 memoized_body
= SCM_CAR (x
);
1381 steps
= scm_reverse (unmemocopy (x
, env
));
1383 /* build transformed binding list */
1385 while (!SCM_NULLP (names
))
1387 SCM name
= SCM_CAR (names
);
1388 SCM init
= SCM_CAR (inits
);
1389 SCM step
= SCM_CAR (steps
);
1390 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1392 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1394 names
= SCM_CDR (names
);
1395 inits
= SCM_CDR (inits
);
1396 steps
= SCM_CDR (steps
);
1398 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1399 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1401 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1404 case SCM_BIT8(SCM_IM_IF
):
1405 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1407 case SCM_BIT8 (SCM_IM_LET
):
1409 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1410 * where nx is the name of a local variable, ix is an initializer for
1411 * the local variable and by are the body clauses. */
1412 SCM names
, inits
, bindings
;
1415 names
= SCM_CAR (x
);
1417 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1418 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1420 bindings
= build_binding_list (names
, inits
);
1421 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1422 ls
= scm_cons (scm_sym_let
, z
);
1425 case SCM_BIT8 (SCM_IM_LETREC
):
1427 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1428 * where nx is the name of a local variable, ix is an initializer for
1429 * the local variable and by are the body clauses. */
1430 SCM names
, inits
, bindings
;
1433 names
= SCM_CAR (x
);
1434 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1436 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1438 bindings
= build_binding_list (names
, inits
);
1439 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1440 ls
= scm_cons (scm_sym_letrec
, z
);
1443 case SCM_BIT8(SCM_IM_LETSTAR
):
1451 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1454 y
= z
= scm_acons (SCM_CAR (b
),
1456 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1458 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1462 SCM_SETCDR (y
, SCM_EOL
);
1463 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1468 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1470 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1473 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1476 while (SCM_NIMP (b
));
1477 SCM_SETCDR (z
, SCM_EOL
);
1479 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1482 case SCM_BIT8(SCM_IM_OR
):
1483 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1485 case SCM_BIT8(SCM_IM_LAMBDA
):
1487 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1488 ls
= scm_cons (scm_sym_lambda
, z
);
1489 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1491 case SCM_BIT8(SCM_IM_QUOTE
):
1492 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1494 case SCM_BIT8(SCM_IM_SET_X
):
1495 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1497 case SCM_BIT8(SCM_IM_DEFINE
):
1502 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1503 ls
= scm_cons (scm_sym_define
, z
);
1504 if (!SCM_NULLP (env
))
1505 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1508 case SCM_BIT8(SCM_MAKISYM (0)):
1512 switch (SCM_ISYMNUM (z
))
1514 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1515 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1517 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1518 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1520 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1521 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1524 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1525 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1528 /* appease the Sun compiler god: */ ;
1532 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1538 while (SCM_CONSP (x
))
1540 SCM form
= SCM_CAR (x
);
1541 if (!SCM_ISYMP (form
))
1543 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1544 SCM_SETCDR (z
, unmemocar (copy
, env
));
1550 #ifdef DEBUG_EXTENSIONS
1551 if (!SCM_FALSEP (p
))
1552 scm_whash_insert (scm_source_whash
, ls
, p
);
1559 scm_unmemocopy (SCM x
, SCM env
)
1561 if (!SCM_NULLP (env
))
1562 /* Make a copy of the lowest frame to protect it from
1563 modifications by SCM_IM_DEFINE */
1564 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1566 return unmemocopy (x
, env
);
1569 #ifndef SCM_RECKLESS
1572 scm_badargsp (SCM formals
, SCM args
)
1574 while (!SCM_NULLP (formals
))
1576 if (!SCM_CONSP (formals
))
1578 if (SCM_NULLP (args
))
1580 formals
= SCM_CDR (formals
);
1581 args
= SCM_CDR (args
);
1583 return !SCM_NULLP (args
) ? 1 : 0;
1589 scm_badformalsp (SCM closure
, int n
)
1591 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1592 while (!SCM_NULLP (formals
))
1594 if (!SCM_CONSP (formals
))
1599 formals
= SCM_CDR (formals
);
1606 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1608 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1609 while (SCM_CONSP (l
))
1611 res
= EVALCAR (l
, env
);
1613 *lloc
= scm_list_1 (res
);
1614 lloc
= SCM_CDRLOC (*lloc
);
1619 scm_wrong_num_args (proc
);
1625 scm_eval_body (SCM code
, SCM env
)
1629 next
= SCM_CDR (code
);
1630 while (!SCM_NULLP (next
))
1632 if (SCM_IMP (SCM_CAR (code
)))
1634 if (SCM_ISYMP (SCM_CAR (code
)))
1636 code
= scm_m_expand_body (code
, env
);
1641 SCM_XEVAL (SCM_CAR (code
), env
);
1643 next
= SCM_CDR (code
);
1645 return SCM_XEVALCAR (code
, env
);
1652 /* SECTION: This code is specific for the debugging support. One
1653 * branch is read when DEVAL isn't defined, the other when DEVAL is
1659 #define SCM_APPLY scm_apply
1660 #define PREP_APPLY(proc, args)
1662 #define RETURN(x) do { return x; } while (0)
1663 #ifdef STACK_CHECKING
1664 #ifndef NO_CEVAL_STACK_CHECKING
1665 #define EVAL_STACK_CHECKING
1672 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1674 #define SCM_APPLY scm_dapply
1676 #define PREP_APPLY(p, l) \
1677 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1679 #define ENTER_APPLY \
1681 SCM_SET_ARGSREADY (debug);\
1682 if (CHECK_APPLY && SCM_TRAPS_P)\
1683 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1685 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1686 SCM_SET_TRACED_FRAME (debug); \
1688 if (SCM_CHEAPTRAPS_P)\
1690 tmp = scm_make_debugobj (&debug);\
1691 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1696 tmp = scm_make_continuation (&first);\
1698 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1704 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1705 #ifdef STACK_CHECKING
1706 #ifndef EVAL_STACK_CHECKING
1707 #define EVAL_STACK_CHECKING
1711 /* scm_ceval_ptr points to the currently selected evaluator.
1712 * *fixme*: Although efficiency is important here, this state variable
1713 * should probably not be a global. It should be related to the
1718 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1720 /* scm_last_debug_frame contains a pointer to the last debugging
1721 * information stack frame. It is accessed very often from the
1722 * debugging evaluator, so it should probably not be indirectly
1723 * addressed. Better to save and restore it from the current root at
1728 scm_t_debug_frame
*scm_last_debug_frame
;
1731 /* scm_debug_eframe_size is the number of slots available for pseudo
1732 * stack frames at each real stack frame.
1735 long scm_debug_eframe_size
;
1737 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1739 long scm_eval_stack
;
1741 scm_t_option scm_eval_opts
[] = {
1742 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1745 scm_t_option scm_debug_opts
[] = {
1746 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1747 "*Flyweight representation of the stack at traps." },
1748 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1749 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1750 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1751 "Record procedure names at definition." },
1752 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1753 "Display backtrace in anti-chronological order." },
1754 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1755 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1756 { SCM_OPTION_INTEGER
, "frames", 3,
1757 "Maximum number of tail-recursive frames in backtrace." },
1758 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1759 "Maximal number of stored backtrace frames." },
1760 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1761 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1762 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1763 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1764 { SCM_OPTION_SCM
, "show-file-name", (unsigned long)SCM_BOOL_T
, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."}
1767 scm_t_option scm_evaluator_trap_table
[] = {
1768 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1769 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1770 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1771 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1772 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1773 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1774 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1777 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1779 "Option interface for the evaluation options. Instead of using\n"
1780 "this procedure directly, use the procedures @code{eval-enable},\n"
1781 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1782 #define FUNC_NAME s_scm_eval_options_interface
1786 ans
= scm_options (setting
,
1790 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1796 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1798 "Option interface for the evaluator trap options.")
1799 #define FUNC_NAME s_scm_evaluator_traps
1803 ans
= scm_options (setting
,
1804 scm_evaluator_trap_table
,
1805 SCM_N_EVALUATOR_TRAPS
,
1807 SCM_RESET_DEBUG_MODE
;
1814 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1816 SCM
*results
= lloc
, res
;
1817 while (SCM_CONSP (l
))
1819 res
= EVALCAR (l
, env
);
1821 *lloc
= scm_list_1 (res
);
1822 lloc
= SCM_CDRLOC (*lloc
);
1827 scm_wrong_num_args (proc
);
1835 /* SECTION: This code is compiled twice.
1839 /* Update the toplevel environment frame ENV so that it refers to the
1840 * current module. */
1841 #define UPDATE_TOPLEVEL_ENV(env) \
1843 SCM p = scm_current_module_lookup_closure (); \
1844 if (p != SCM_CAR(env)) \
1845 env = scm_top_level_env (p); \
1849 /* This is the evaluator. Like any real monster, it has three heads:
1851 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1852 * version. Both are implemented using a common code base, using the
1853 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1854 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1855 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1856 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1857 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1858 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1859 * are enclosed within #ifdef DEVAL ... #endif.
1861 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1862 * take two input parameters, x and env: x is a single expression to be
1863 * evalutated. env is the environment in which bindings are searched.
1865 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1866 * is a single expression, it is necessarily in a tail position. If x is just
1867 * a call to another function like in the expression (foo exp1 exp2 ...), the
1868 * realization of that call therefore _must_not_ increase stack usage (the
1869 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1870 * making extensive use of 'goto' statements within the evaluator: The gotos
1871 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1872 * that SCM_CEVAL was already using. If, however, x represents some form that
1873 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1874 * then recursive calls to SCM_CEVAL are performed for all but the last
1875 * expression of that sequence. */
1879 scm_ceval (SCM x
, SCM env
)
1885 scm_deval (SCM x
, SCM env
)
1890 SCM_CEVAL (SCM x
, SCM env
)
1897 SCM proc
, arg2
, orig_sym
;
1899 scm_t_debug_frame debug
;
1900 scm_t_debug_info
*debug_info_end
;
1901 debug
.prev
= scm_last_debug_frame
;
1902 debug
.status
= scm_debug_eframe_size
;
1904 * The debug.vect contains twice as much scm_t_debug_info frames as the
1905 * user has specified with (debug-set! frames <n>).
1907 * Even frames are eval frames, odd frames are apply frames.
1909 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1910 * sizeof (scm_t_debug_info
));
1911 debug
.info
= debug
.vect
;
1912 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1913 scm_last_debug_frame
= &debug
;
1915 #ifdef EVAL_STACK_CHECKING
1916 if (scm_stack_checking_enabled_p
1917 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1920 debug
.info
->e
.exp
= x
;
1921 debug
.info
->e
.env
= env
;
1923 scm_report_stack_overflow ();
1932 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1935 SCM_CLEAR_ARGSREADY (debug
);
1936 if (SCM_OVERFLOWP (debug
))
1939 * In theory, this should be the only place where it is necessary to
1940 * check for space in debug.vect since both eval frames and
1941 * available space are even.
1943 * For this to be the case, however, it is necessary that primitive
1944 * special forms which jump back to `loop', `begin' or some similar
1945 * label call PREP_APPLY. A convenient way to do this is to jump to
1946 * `loopnoap' or `cdrxnoap'.
1948 else if (++debug
.info
>= debug_info_end
)
1950 SCM_SET_OVERFLOW (debug
);
1955 debug
.info
->e
.exp
= x
;
1956 debug
.info
->e
.env
= env
;
1957 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1958 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1960 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1961 SCM_SET_TAILREC (debug
);
1962 if (SCM_CHEAPTRAPS_P
)
1963 t
.arg1
= scm_make_debugobj (&debug
);
1967 SCM val
= scm_make_continuation (&first
);
1977 /* This gives the possibility for the debugger to
1978 modify the source expression before evaluation. */
1983 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1984 scm_sym_enter_frame
,
1987 scm_unmemocopy (x
, env
));
1991 #if defined (USE_THREADS) || defined (DEVAL)
1995 switch (SCM_TYP7 (x
))
1997 case scm_tc7_symbol
:
1998 /* Only happens when called at top level. */
1999 x
= scm_cons (x
, SCM_UNDEFINED
);
2000 RETURN (*scm_lookupcar (x
, env
, 1));
2002 case SCM_BIT8 (SCM_IM_AND
):
2004 while (!SCM_NULLP (SCM_CDR (x
)))
2006 SCM test_result
= EVALCAR (x
, env
);
2007 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2008 RETURN (SCM_BOOL_F
);
2012 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2015 case SCM_BIT8 (SCM_IM_BEGIN
):
2016 if (SCM_NULLP (SCM_CDR (x
)))
2017 RETURN (SCM_UNSPECIFIED
);
2019 /* (currently unused)
2021 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2022 /* (currently unused)
2027 /* If we are on toplevel with a lookup closure, we need to sync
2028 with the current module. */
2029 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2031 UPDATE_TOPLEVEL_ENV (env
);
2032 while (!SCM_NULLP (SCM_CDR (x
)))
2035 UPDATE_TOPLEVEL_ENV (env
);
2041 goto nontoplevel_begin
;
2043 nontoplevel_cdrxnoap
:
2044 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2045 nontoplevel_cdrxbegin
:
2048 while (!SCM_NULLP (SCM_CDR (x
)))
2050 SCM form
= SCM_CAR (x
);
2053 if (SCM_ISYMP (form
))
2055 x
= scm_m_expand_body (x
, env
);
2056 goto nontoplevel_begin
;
2059 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2062 SCM_CEVAL (form
, env
);
2068 /* scm_eval last form in list */
2069 SCM last_form
= SCM_CAR (x
);
2071 if (SCM_CONSP (last_form
))
2073 /* This is by far the most frequent case. */
2075 goto loop
; /* tail recurse */
2077 else if (SCM_IMP (last_form
))
2078 RETURN (SCM_EVALIM (last_form
, env
));
2079 else if (SCM_VARIABLEP (last_form
))
2080 RETURN (SCM_VARIABLE_REF (last_form
));
2081 else if (SCM_SYMBOLP (last_form
))
2082 RETURN (*scm_lookupcar (x
, env
, 1));
2088 case SCM_BIT8 (SCM_IM_CASE
):
2091 SCM key
= EVALCAR (x
, env
);
2093 while (!SCM_NULLP (x
))
2095 SCM clause
= SCM_CAR (x
);
2096 SCM labels
= SCM_CAR (clause
);
2097 if (SCM_EQ_P (labels
, scm_sym_else
))
2099 x
= SCM_CDR (clause
);
2100 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2103 while (!SCM_NULLP (labels
))
2105 SCM label
= SCM_CAR (labels
);
2106 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2108 x
= SCM_CDR (clause
);
2109 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2112 labels
= SCM_CDR (labels
);
2117 RETURN (SCM_UNSPECIFIED
);
2120 case SCM_BIT8 (SCM_IM_COND
):
2122 while (!SCM_NULLP (x
))
2124 SCM clause
= SCM_CAR (x
);
2125 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2127 x
= SCM_CDR (clause
);
2128 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2133 t
.arg1
= EVALCAR (clause
, env
);
2134 if (!SCM_FALSEP (t
.arg1
) && !SCM_NILP (t
.arg1
))
2136 x
= SCM_CDR (clause
);
2139 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2141 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2147 proc
= EVALCAR (proc
, env
);
2148 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2149 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2151 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2152 goto umwrongnumargs
;
2160 RETURN (SCM_UNSPECIFIED
);
2163 case SCM_BIT8 (SCM_IM_DO
):
2166 /* Compute the initialization values and the initial environment. */
2167 SCM init_forms
= SCM_CADR (x
);
2168 SCM init_values
= SCM_EOL
;
2169 while (!SCM_NULLP (init_forms
))
2171 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2172 init_forms
= SCM_CDR (init_forms
);
2174 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2178 SCM test_form
= SCM_CAR (x
);
2179 SCM body_forms
= SCM_CADR (x
);
2180 SCM step_forms
= SCM_CDDR (x
);
2182 SCM test_result
= EVALCAR (test_form
, env
);
2184 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2187 /* Evaluate body forms. */
2189 for (temp_forms
= body_forms
;
2190 !SCM_NULLP (temp_forms
);
2191 temp_forms
= SCM_CDR (temp_forms
))
2193 SCM form
= SCM_CAR (temp_forms
);
2194 /* Dirk:FIXME: We only need to eval forms, that may have a
2195 * side effect here. This is only true for forms that start
2196 * with a pair. All others are just constants. However,
2197 * since in the common case there is no constant expression
2198 * in a body of a do form, we just check for immediates here
2199 * and have SCM_CEVAL take care of other cases. In the long
2200 * run it would make sense to get rid of this test and have
2201 * the macro transformer of 'do' eliminate all forms that
2202 * have no sideeffect. */
2203 if (!SCM_IMP (form
))
2204 SCM_CEVAL (form
, env
);
2209 /* Evaluate the step expressions. */
2211 SCM step_values
= SCM_EOL
;
2212 for (temp_forms
= step_forms
;
2213 !SCM_NULLP (temp_forms
);
2214 temp_forms
= SCM_CDR (temp_forms
))
2216 SCM value
= EVALCAR (temp_forms
, env
);
2217 step_values
= scm_cons (value
, step_values
);
2219 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2222 test_result
= EVALCAR (test_form
, env
);
2227 RETURN (SCM_UNSPECIFIED
);
2228 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2229 goto nontoplevel_begin
;
2232 case SCM_BIT8 (SCM_IM_IF
):
2235 SCM test_result
= EVALCAR (x
, env
);
2236 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2242 RETURN (SCM_UNSPECIFIED
);
2245 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2249 case SCM_BIT8 (SCM_IM_LET
):
2252 SCM init_forms
= SCM_CADR (x
);
2253 SCM init_values
= SCM_EOL
;
2256 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2257 init_forms
= SCM_CDR (init_forms
);
2259 while (!SCM_NULLP (init_forms
));
2260 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2263 goto nontoplevel_cdrxnoap
;
2266 case SCM_BIT8 (SCM_IM_LETREC
):
2268 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2271 SCM init_forms
= SCM_CAR (x
);
2272 SCM init_values
= SCM_EOL
;
2275 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2276 init_forms
= SCM_CDR (init_forms
);
2278 while (!SCM_NULLP (init_forms
));
2279 SCM_SETCDR (SCM_CAR (env
), init_values
);
2281 goto nontoplevel_cdrxnoap
;
2284 case SCM_BIT8 (SCM_IM_LETSTAR
):
2287 SCM bindings
= SCM_CAR (x
);
2288 if (SCM_NULLP (bindings
))
2289 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2294 SCM name
= SCM_CAR (bindings
);
2295 SCM init
= SCM_CDR (bindings
);
2296 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2297 bindings
= SCM_CDR (init
);
2299 while (!SCM_NULLP (bindings
));
2302 goto nontoplevel_cdrxnoap
;
2305 case SCM_BIT8 (SCM_IM_OR
):
2307 while (!SCM_NULLP (SCM_CDR (x
)))
2309 SCM val
= EVALCAR (x
, env
);
2310 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2315 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2319 case SCM_BIT8 (SCM_IM_LAMBDA
):
2320 RETURN (scm_closure (SCM_CDR (x
), env
));
2323 case SCM_BIT8 (SCM_IM_QUOTE
):
2324 RETURN (SCM_CADR (x
));
2327 case SCM_BIT8 (SCM_IM_SET_X
):
2331 SCM variable
= SCM_CAR (x
);
2332 if (SCM_VARIABLEP (variable
))
2333 location
= SCM_VARIABLE_LOC (variable
);
2334 #ifdef MEMOIZE_LOCALS
2335 else if (SCM_ILOCP (variable
))
2336 location
= scm_ilookup (variable
, env
);
2338 else /* (SCM_SYMBOLP (variable)) is known to be true */
2339 location
= scm_lookupcar (x
, env
, 1);
2341 *location
= EVALCAR (x
, env
);
2343 RETURN (SCM_UNSPECIFIED
);
2346 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2347 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2350 /* new syntactic forms go here. */
2351 case SCM_BIT8(SCM_MAKISYM (0)):
2353 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2354 switch (SCM_ISYMNUM (proc
))
2356 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2358 proc
= EVALCAR (proc
, env
);
2359 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2360 if (SCM_CLOSUREP (proc
))
2363 PREP_APPLY (proc
, SCM_EOL
);
2364 t
.arg1
= SCM_CDDR (x
);
2365 t
.arg1
= EVALCAR (t
.arg1
, env
);
2367 /* Go here to tail-call a closure. PROC is the closure
2368 and T.ARG1 is the list of arguments. Do not forget to
2371 debug
.info
->a
.args
= t
.arg1
;
2373 #ifndef SCM_RECKLESS
2374 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), t
.arg1
))
2378 /* Copy argument list */
2379 if (SCM_IMP (t
.arg1
))
2383 argl
= tl
= scm_cons (SCM_CAR (t
.arg1
), SCM_UNSPECIFIED
);
2384 while (SCM_NIMP (t
.arg1
= SCM_CDR (t
.arg1
))
2385 && SCM_CONSP (t
.arg1
))
2387 SCM_SETCDR (tl
, scm_cons (SCM_CAR (t
.arg1
),
2391 SCM_SETCDR (tl
, t
.arg1
);
2394 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), argl
, SCM_ENV (proc
));
2395 x
= SCM_CLOSURE_BODY (proc
);
2396 goto nontoplevel_begin
;
2401 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2404 SCM val
= scm_make_continuation (&first
);
2412 proc
= scm_eval_car (proc
, env
);
2413 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2414 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2416 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2417 goto umwrongnumargs
;
2420 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2421 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2423 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2424 proc
= SCM_CADR (x
); /* unevaluated operands */
2425 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2427 arg2
= *scm_ilookup (proc
, env
);
2428 else if (!SCM_CONSP (proc
))
2430 if (SCM_VARIABLEP (proc
))
2431 arg2
= SCM_VARIABLE_REF (proc
);
2433 arg2
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2437 arg2
= scm_list_1 (EVALCAR (proc
, env
));
2438 t
.lloc
= SCM_CDRLOC (arg2
);
2439 while (SCM_NIMP (proc
= SCM_CDR (proc
)))
2441 *t
.lloc
= scm_list_1 (EVALCAR (proc
, env
));
2442 t
.lloc
= SCM_CDRLOC (*t
.lloc
);
2447 /* The type dispatch code is duplicated here
2448 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2449 * cuts down execution time for type dispatch to 50%.
2452 long i
, n
, end
, mask
;
2453 SCM z
= SCM_CDDR (x
);
2454 n
= SCM_INUM (SCM_CAR (z
)); /* maximum number of specializers */
2455 proc
= SCM_CADR (z
);
2457 if (SCM_NIMP (proc
))
2459 /* Prepare for linear search */
2462 end
= SCM_VECTOR_LENGTH (proc
);
2466 /* Compute a hash value */
2467 long hashset
= SCM_INUM (proc
);
2470 mask
= SCM_INUM (SCM_CAR (z
));
2471 proc
= SCM_CADR (z
);
2474 if (SCM_NIMP (t
.arg1
))
2477 i
+= SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t
.arg1
)))
2478 [scm_si_hashsets
+ hashset
];
2479 t
.arg1
= SCM_CDR (t
.arg1
);
2481 while (j
-- && SCM_NIMP (t
.arg1
));
2486 /* Search for match */
2490 z
= SCM_VELTS (proc
)[i
];
2491 t
.arg1
= arg2
; /* list of arguments */
2492 if (SCM_NIMP (t
.arg1
))
2495 /* More arguments than specifiers => CLASS != ENV */
2496 if (! SCM_EQ_P (scm_class_of (SCM_CAR (t
.arg1
)), SCM_CAR (z
)))
2498 t
.arg1
= SCM_CDR (t
.arg1
);
2501 while (j
-- && SCM_NIMP (t
.arg1
));
2502 /* Fewer arguments than specifiers => CAR != ENV */
2503 if (!(SCM_IMP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
))))
2506 env
= EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (z
)),
2508 SCM_CMETHOD_ENV (z
));
2509 x
= SCM_CMETHOD_CODE (z
);
2510 goto nontoplevel_cdrxbegin
;
2515 z
= scm_memoize_method (x
, arg2
);
2519 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2521 t
.arg1
= EVALCAR (x
, env
);
2522 RETURN (SCM_PACK (SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CADR (x
))]));
2524 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2526 t
.arg1
= EVALCAR (x
, env
);
2529 SCM_STRUCT_DATA (t
.arg1
) [SCM_INUM (SCM_CAR (x
))]
2530 = SCM_UNPACK (EVALCAR (proc
, env
));
2531 RETURN (SCM_UNSPECIFIED
);
2533 #ifdef SCM_ENABLE_ELISP
2535 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2537 while (SCM_NIMP (x
= SCM_CDR (proc
)))
2539 if (!(SCM_FALSEP (t
.arg1
= EVALCAR (proc
, env
))
2540 || SCM_NILP (t
.arg1
)
2541 || SCM_NULLP (t
.arg1
)))
2543 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2545 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2551 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2554 #endif /* SCM_ENABLE_ELISP */
2556 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2558 SCM vars
, exps
, vals
;
2561 vars
= SCM_CAAR (x
);
2562 exps
= SCM_CDAR (x
);
2566 while (SCM_NIMP (exps
))
2568 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2569 exps
= SCM_CDR (exps
);
2572 scm_swap_bindings (vars
, vals
);
2573 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2575 arg2
= x
= SCM_CDR (x
);
2576 while (!SCM_NULLP (arg2
= SCM_CDR (arg2
)))
2578 SIDEVAL (SCM_CAR (x
), env
);
2581 proc
= EVALCAR (x
, env
);
2583 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2584 scm_swap_bindings (vars
, vals
);
2589 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2592 x
= EVALCAR (proc
, env
);
2593 proc
= SCM_CDR (proc
);
2594 proc
= EVALCAR (proc
, env
);
2595 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2596 if (SCM_VALUESP (t
.arg1
))
2597 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2599 t
.arg1
= scm_list_1 (t
.arg1
);
2600 if (SCM_CLOSUREP (proc
))
2602 PREP_APPLY (proc
, t
.arg1
);
2605 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2615 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2616 case scm_tc7_vector
:
2620 case scm_tc7_byvect
:
2627 #ifdef HAVE_LONG_LONGS
2628 case scm_tc7_llvect
:
2631 case scm_tc7_string
:
2633 case scm_tcs_closures
:
2637 case scm_tcs_struct
:
2640 case scm_tc7_variable
:
2641 RETURN (SCM_VARIABLE_REF(x
));
2643 #ifdef MEMOIZE_LOCALS
2644 case SCM_BIT8(SCM_ILOC00
):
2645 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2646 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2647 #ifndef SCM_RECKLESS
2653 #endif /* ifdef MEMOIZE_LOCALS */
2655 case scm_tcs_cons_nimcar
:
2656 orig_sym
= SCM_CAR (x
);
2657 if (SCM_SYMBOLP (orig_sym
))
2660 t
.lloc
= scm_lookupcar1 (x
, env
, 1);
2663 /* we have lost the race, start again. */
2668 proc
= *scm_lookupcar (x
, env
, 1);
2673 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2677 if (SCM_MACROP (proc
))
2679 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2683 /* Set a flag during macro expansion so that macro
2684 application frames can be deleted from the backtrace. */
2685 SCM_SET_MACROEXP (debug
);
2687 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2688 scm_cons (env
, scm_listofnull
));
2691 SCM_CLEAR_MACROEXP (debug
);
2693 switch (SCM_MACRO_TYPE (proc
))
2696 if (scm_ilength (t
.arg1
) <= 0)
2697 t
.arg1
= scm_list_2 (SCM_IM_BEGIN
, t
.arg1
);
2699 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2702 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2703 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2707 /* Prevent memoizing of debug info expression. */
2708 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2713 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2714 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2718 if (SCM_NIMP (x
= t
.arg1
))
2726 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2727 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2728 #ifndef SCM_RECKLESS
2732 if (SCM_CLOSUREP (proc
))
2734 arg2
= SCM_CLOSURE_FORMALS (proc
);
2735 t
.arg1
= SCM_CDR (x
);
2736 while (!SCM_NULLP (arg2
))
2738 if (!SCM_CONSP (arg2
))
2740 if (SCM_IMP (t
.arg1
))
2741 goto umwrongnumargs
;
2742 arg2
= SCM_CDR (arg2
);
2743 t
.arg1
= SCM_CDR (t
.arg1
);
2745 if (!SCM_NULLP (t
.arg1
))
2746 goto umwrongnumargs
;
2748 else if (SCM_MACROP (proc
))
2749 goto handle_a_macro
;
2755 PREP_APPLY (proc
, SCM_EOL
);
2756 if (SCM_NULLP (SCM_CDR (x
))) {
2759 switch (SCM_TYP7 (proc
))
2760 { /* no arguments given */
2761 case scm_tc7_subr_0
:
2762 RETURN (SCM_SUBRF (proc
) ());
2763 case scm_tc7_subr_1o
:
2764 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2766 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2767 case scm_tc7_rpsubr
:
2768 RETURN (SCM_BOOL_T
);
2770 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2772 if (!SCM_SMOB_APPLICABLE_P (proc
))
2774 RETURN (SCM_SMOB_APPLY_0 (proc
));
2777 proc
= SCM_CCLO_SUBR (proc
);
2779 debug
.info
->a
.proc
= proc
;
2780 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2784 proc
= SCM_PROCEDURE (proc
);
2786 debug
.info
->a
.proc
= proc
;
2788 if (!SCM_CLOSUREP (proc
))
2790 if (scm_badformalsp (proc
, 0))
2791 goto umwrongnumargs
;
2792 case scm_tcs_closures
:
2793 x
= SCM_CLOSURE_BODY (proc
);
2794 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2795 goto nontoplevel_begin
;
2796 case scm_tcs_struct
:
2797 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2799 x
= SCM_ENTITY_PROCEDURE (proc
);
2803 else if (!SCM_I_OPERATORP (proc
))
2808 proc
= (SCM_I_ENTITYP (proc
)
2809 ? SCM_ENTITY_PROCEDURE (proc
)
2810 : SCM_OPERATOR_PROCEDURE (proc
));
2812 debug
.info
->a
.proc
= proc
;
2813 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2815 if (SCM_NIMP (proc
))
2820 case scm_tc7_subr_1
:
2821 case scm_tc7_subr_2
:
2822 case scm_tc7_subr_2o
:
2824 case scm_tc7_subr_3
:
2825 case scm_tc7_lsubr_2
:
2829 scm_wrong_num_args (proc
);
2831 /* handle macros here */
2836 /* must handle macros by here */
2841 else if (SCM_CONSP (x
))
2843 if (SCM_IMP (SCM_CAR (x
)))
2844 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2846 t
.arg1
= EVALCELLCAR (x
, env
);
2851 t
.arg1
= EVALCAR (x
, env
);
2854 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2861 switch (SCM_TYP7 (proc
))
2862 { /* have one argument in t.arg1 */
2863 case scm_tc7_subr_2o
:
2864 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2865 case scm_tc7_subr_1
:
2866 case scm_tc7_subr_1o
:
2867 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2869 if (SCM_SUBRF (proc
))
2871 if (SCM_INUMP (t
.arg1
))
2873 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2875 else if (SCM_REALP (t
.arg1
))
2877 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2880 else if (SCM_BIGP (t
.arg1
))
2882 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2885 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2886 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2888 proc
= SCM_SNAME (proc
);
2890 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2891 while ('c' != *--chrs
)
2893 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2894 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2895 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2899 case scm_tc7_rpsubr
:
2900 RETURN (SCM_BOOL_T
);
2902 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2905 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2907 RETURN (SCM_SUBRF (proc
) (scm_list_1 (t
.arg1
)));
2910 if (!SCM_SMOB_APPLICABLE_P (proc
))
2912 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
2916 proc
= SCM_CCLO_SUBR (proc
);
2918 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2919 debug
.info
->a
.proc
= proc
;
2923 proc
= SCM_PROCEDURE (proc
);
2925 debug
.info
->a
.proc
= proc
;
2927 if (!SCM_CLOSUREP (proc
))
2929 if (scm_badformalsp (proc
, 1))
2930 goto umwrongnumargs
;
2931 case scm_tcs_closures
:
2933 x
= SCM_CLOSURE_BODY (proc
);
2935 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2937 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (t
.arg1
), SCM_ENV (proc
));
2939 goto nontoplevel_begin
;
2940 case scm_tcs_struct
:
2941 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2943 x
= SCM_ENTITY_PROCEDURE (proc
);
2945 arg2
= debug
.info
->a
.args
;
2947 arg2
= scm_list_1 (t
.arg1
);
2951 else if (!SCM_I_OPERATORP (proc
))
2957 proc
= (SCM_I_ENTITYP (proc
)
2958 ? SCM_ENTITY_PROCEDURE (proc
)
2959 : SCM_OPERATOR_PROCEDURE (proc
));
2961 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
2962 debug
.info
->a
.proc
= proc
;
2964 if (SCM_NIMP (proc
))
2969 case scm_tc7_subr_2
:
2970 case scm_tc7_subr_0
:
2971 case scm_tc7_subr_3
:
2972 case scm_tc7_lsubr_2
:
2981 else if (SCM_CONSP (x
))
2983 if (SCM_IMP (SCM_CAR (x
)))
2984 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
2986 arg2
= EVALCELLCAR (x
, env
);
2991 arg2
= EVALCAR (x
, env
);
2993 { /* have two or more arguments */
2995 debug
.info
->a
.args
= scm_list_2 (t
.arg1
, arg2
);
2998 if (SCM_NULLP (x
)) {
3001 switch (SCM_TYP7 (proc
))
3002 { /* have two arguments */
3003 case scm_tc7_subr_2
:
3004 case scm_tc7_subr_2o
:
3005 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
3008 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3010 RETURN (SCM_SUBRF (proc
) (scm_list_2 (t
.arg1
, arg2
)));
3012 case scm_tc7_lsubr_2
:
3013 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
3014 case scm_tc7_rpsubr
:
3016 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
3018 if (!SCM_SMOB_APPLICABLE_P (proc
))
3020 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
3024 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3025 scm_cons (proc
, debug
.info
->a
.args
),
3028 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3029 scm_cons2 (proc
, t
.arg1
,
3036 case scm_tcs_struct
:
3037 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3039 x
= SCM_ENTITY_PROCEDURE (proc
);
3041 arg2
= debug
.info
->a
.args
;
3043 arg2
= scm_list_2 (t
.arg1
, arg2
);
3047 else if (!SCM_I_OPERATORP (proc
))
3053 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3054 ? SCM_ENTITY_PROCEDURE (proc
)
3055 : SCM_OPERATOR_PROCEDURE (proc
),
3056 scm_cons (proc
, debug
.info
->a
.args
),
3059 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3060 ? SCM_ENTITY_PROCEDURE (proc
)
3061 : SCM_OPERATOR_PROCEDURE (proc
),
3062 scm_cons2 (proc
, t
.arg1
,
3070 case scm_tc7_subr_0
:
3072 case scm_tc7_subr_1o
:
3073 case scm_tc7_subr_1
:
3074 case scm_tc7_subr_3
:
3079 proc
= SCM_PROCEDURE (proc
);
3081 debug
.info
->a
.proc
= proc
;
3083 if (!SCM_CLOSUREP (proc
))
3085 if (scm_badformalsp (proc
, 2))
3086 goto umwrongnumargs
;
3087 case scm_tcs_closures
:
3090 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3094 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3095 scm_list_2 (t
.arg1
, arg2
), SCM_ENV (proc
));
3097 x
= SCM_CLOSURE_BODY (proc
);
3098 goto nontoplevel_begin
;
3102 if (SCM_IMP (x
) || !SCM_CONSP (x
))
3106 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3107 deval_args (x
, env
, proc
, SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3111 switch (SCM_TYP7 (proc
))
3112 { /* have 3 or more arguments */
3114 case scm_tc7_subr_3
:
3115 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3116 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3117 SCM_CADDR (debug
.info
->a
.args
)));
3119 #ifdef BUILTIN_RPASUBR
3120 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3121 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3124 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3125 arg2
= SCM_CDR (arg2
);
3127 while (SCM_NIMP (arg2
));
3129 #endif /* BUILTIN_RPASUBR */
3130 case scm_tc7_rpsubr
:
3131 #ifdef BUILTIN_RPASUBR
3132 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3133 RETURN (SCM_BOOL_F
);
3134 t
.arg1
= SCM_CDDR (debug
.info
->a
.args
);
3137 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3138 RETURN (SCM_BOOL_F
);
3139 arg2
= SCM_CAR (t
.arg1
);
3140 t
.arg1
= SCM_CDR (t
.arg1
);
3142 while (SCM_NIMP (t
.arg1
));
3143 RETURN (SCM_BOOL_T
);
3144 #else /* BUILTIN_RPASUBR */
3145 RETURN (SCM_APPLY (proc
, t
.arg1
,
3147 SCM_CDDR (debug
.info
->a
.args
),
3149 #endif /* BUILTIN_RPASUBR */
3150 case scm_tc7_lsubr_2
:
3151 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3152 SCM_CDDR (debug
.info
->a
.args
)));
3154 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3156 if (!SCM_SMOB_APPLICABLE_P (proc
))
3158 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3159 SCM_CDDR (debug
.info
->a
.args
)));
3163 proc
= SCM_PROCEDURE (proc
);
3164 debug
.info
->a
.proc
= proc
;
3165 if (!SCM_CLOSUREP (proc
))
3167 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3168 goto umwrongnumargs
;
3169 case scm_tcs_closures
:
3170 SCM_SET_ARGSREADY (debug
);
3171 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3174 x
= SCM_CLOSURE_BODY (proc
);
3175 goto nontoplevel_begin
;
3177 case scm_tc7_subr_3
:
3178 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3179 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3181 #ifdef BUILTIN_RPASUBR
3182 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3185 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3188 while (SCM_NIMP (x
));
3190 #endif /* BUILTIN_RPASUBR */
3191 case scm_tc7_rpsubr
:
3192 #ifdef BUILTIN_RPASUBR
3193 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3194 RETURN (SCM_BOOL_F
);
3197 t
.arg1
= EVALCAR (x
, env
);
3198 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3199 RETURN (SCM_BOOL_F
);
3203 while (SCM_NIMP (x
));
3204 RETURN (SCM_BOOL_T
);
3205 #else /* BUILTIN_RPASUBR */
3206 RETURN (SCM_APPLY (proc
, t
.arg1
,
3208 scm_eval_args (x
, env
, proc
),
3210 #endif /* BUILTIN_RPASUBR */
3211 case scm_tc7_lsubr_2
:
3212 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3214 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3216 scm_eval_args (x
, env
, proc
))));
3218 if (!SCM_SMOB_APPLICABLE_P (proc
))
3220 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3221 scm_eval_args (x
, env
, proc
)));
3225 proc
= SCM_PROCEDURE (proc
);
3226 if (!SCM_CLOSUREP (proc
))
3229 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3230 if (SCM_NULLP (formals
)
3231 || (SCM_CONSP (formals
)
3232 && (SCM_NULLP (SCM_CDR (formals
))
3233 || (SCM_CONSP (SCM_CDR (formals
))
3234 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3235 goto umwrongnumargs
;
3237 case scm_tcs_closures
:
3239 SCM_SET_ARGSREADY (debug
);
3241 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3244 scm_eval_args (x
, env
, proc
)),
3246 x
= SCM_CLOSURE_BODY (proc
);
3247 goto nontoplevel_begin
;
3249 case scm_tcs_struct
:
3250 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3253 arg2
= debug
.info
->a
.args
;
3255 arg2
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3257 x
= SCM_ENTITY_PROCEDURE (proc
);
3260 else if (!SCM_I_OPERATORP (proc
))
3264 case scm_tc7_subr_2
:
3265 case scm_tc7_subr_1o
:
3266 case scm_tc7_subr_2o
:
3267 case scm_tc7_subr_0
:
3269 case scm_tc7_subr_1
:
3277 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3278 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3280 SCM_CLEAR_TRACED_FRAME (debug
);
3281 if (SCM_CHEAPTRAPS_P
)
3282 t
.arg1
= scm_make_debugobj (&debug
);
3286 SCM val
= scm_make_continuation (&first
);
3297 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3301 scm_last_debug_frame
= debug
.prev
;
3307 /* SECTION: This code is compiled once.
3313 /* Simple procedure calls
3317 scm_call_0 (SCM proc
)
3319 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3323 scm_call_1 (SCM proc
, SCM arg1
)
3325 return scm_apply (proc
, arg1
, scm_listofnull
);
3329 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3331 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3335 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3337 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3341 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3343 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3344 scm_cons (arg4
, scm_listofnull
)));
3347 /* Simple procedure applies
3351 scm_apply_0 (SCM proc
, SCM args
)
3353 return scm_apply (proc
, args
, SCM_EOL
);
3357 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3359 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3363 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3365 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3369 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3371 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3375 /* This code processes the arguments to apply:
3377 (apply PROC ARG1 ... ARGS)
3379 Given a list (ARG1 ... ARGS), this function conses the ARG1
3380 ... arguments onto the front of ARGS, and returns the resulting
3381 list. Note that ARGS is a list; thus, the argument to this
3382 function is a list whose last element is a list.
3384 Apply calls this function, and applies PROC to the elements of the
3385 result. apply:nconc2last takes care of building the list of
3386 arguments, given (ARG1 ... ARGS).
3388 Rather than do new consing, apply:nconc2last destroys its argument.
3389 On that topic, this code came into my care with the following
3390 beautifully cryptic comment on that topic: "This will only screw
3391 you if you do (scm_apply scm_apply '( ... ))" If you know what
3392 they're referring to, send me a patch to this comment. */
3394 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3396 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3397 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3398 "@var{args}, and returns the resulting list. Note that\n"
3399 "@var{args} is a list; thus, the argument to this function is\n"
3400 "a list whose last element is a list.\n"
3401 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3402 "destroys its argument, so use with care.")
3403 #define FUNC_NAME s_scm_nconc2last
3406 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3408 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3409 SCM_NULL_OR_NIL_P, but not
3410 needed in 99.99% of cases,
3411 and it could seriously hurt
3412 performance. - Neil */
3413 lloc
= SCM_CDRLOC (*lloc
);
3414 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3415 *lloc
= SCM_CAR (*lloc
);
3423 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3424 * It is compiled twice.
3429 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3435 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3440 /* Apply a function to a list of arguments.
3442 This function is exported to the Scheme level as taking two
3443 required arguments and a tail argument, as if it were:
3444 (lambda (proc arg1 . args) ...)
3445 Thus, if you just have a list of arguments to pass to a procedure,
3446 pass the list as ARG1, and '() for ARGS. If you have some fixed
3447 args, pass the first as ARG1, then cons any remaining fixed args
3448 onto the front of your argument list, and pass that as ARGS. */
3451 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3453 #ifdef DEBUG_EXTENSIONS
3455 scm_t_debug_frame debug
;
3456 scm_t_debug_info debug_vect_body
;
3457 debug
.prev
= scm_last_debug_frame
;
3458 debug
.status
= SCM_APPLYFRAME
;
3459 debug
.vect
= &debug_vect_body
;
3460 debug
.vect
[0].a
.proc
= proc
;
3461 debug
.vect
[0].a
.args
= SCM_EOL
;
3462 scm_last_debug_frame
= &debug
;
3465 return scm_dapply (proc
, arg1
, args
);
3469 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3471 /* If ARGS is the empty list, then we're calling apply with only two
3472 arguments --- ARG1 is the list of arguments for PROC. Whatever
3473 the case, futz with things so that ARG1 is the first argument to
3474 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3477 Setting the debug apply frame args this way is pretty messy.
3478 Perhaps we should store arg1 and args directly in the frame as
3479 received, and let scm_frame_arguments unpack them, because that's
3480 a relatively rare operation. This works for now; if the Guile
3481 developer archives are still around, see Mikael's post of
3483 if (SCM_NULLP (args
))
3485 if (SCM_NULLP (arg1
))
3487 arg1
= SCM_UNDEFINED
;
3489 debug
.vect
[0].a
.args
= SCM_EOL
;
3495 debug
.vect
[0].a
.args
= arg1
;
3497 args
= SCM_CDR (arg1
);
3498 arg1
= SCM_CAR (arg1
);
3503 args
= scm_nconc2last (args
);
3505 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3509 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3512 if (SCM_CHEAPTRAPS_P
)
3513 tmp
= scm_make_debugobj (&debug
);
3518 tmp
= scm_make_continuation (&first
);
3523 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3530 switch (SCM_TYP7 (proc
))
3532 case scm_tc7_subr_2o
:
3533 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3534 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3535 case scm_tc7_subr_2
:
3536 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3538 args
= SCM_CAR (args
);
3539 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3540 case scm_tc7_subr_0
:
3541 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3542 RETURN (SCM_SUBRF (proc
) ());
3543 case scm_tc7_subr_1
:
3544 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3545 case scm_tc7_subr_1o
:
3546 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3547 RETURN (SCM_SUBRF (proc
) (arg1
));
3549 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3550 if (SCM_SUBRF (proc
))
3552 if (SCM_INUMP (arg1
))
3554 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3556 else if (SCM_REALP (arg1
))
3558 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3561 else if (SCM_BIGP (arg1
))
3562 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3564 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3565 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3567 proc
= SCM_SNAME (proc
);
3569 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3570 while ('c' != *--chrs
)
3572 SCM_ASSERT (SCM_CONSP (arg1
),
3573 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3574 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3578 case scm_tc7_subr_3
:
3579 SCM_ASRTGO (!SCM_NULLP (args
)
3580 && !SCM_NULLP (SCM_CDR (args
))
3581 && SCM_NULLP (SCM_CDDR (args
)),
3583 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3586 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3588 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3590 case scm_tc7_lsubr_2
:
3591 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3592 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3594 if (SCM_NULLP (args
))
3595 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3596 while (SCM_NIMP (args
))
3598 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3599 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3600 args
= SCM_CDR (args
);
3603 case scm_tc7_rpsubr
:
3604 if (SCM_NULLP (args
))
3605 RETURN (SCM_BOOL_T
);
3606 while (SCM_NIMP (args
))
3608 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3609 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3610 RETURN (SCM_BOOL_F
);
3611 arg1
= SCM_CAR (args
);
3612 args
= SCM_CDR (args
);
3614 RETURN (SCM_BOOL_T
);
3615 case scm_tcs_closures
:
3617 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3619 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3621 #ifndef SCM_RECKLESS
3622 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3626 /* Copy argument list */
3631 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3632 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3634 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3638 SCM_SETCDR (tl
, arg1
);
3641 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3642 proc
= SCM_CLOSURE_BODY (proc
);
3645 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3647 if (SCM_IMP (SCM_CAR (proc
)))
3649 if (SCM_ISYMP (SCM_CAR (proc
)))
3651 proc
= scm_m_expand_body (proc
, args
);
3655 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3658 SCM_CEVAL (SCM_CAR (proc
), args
);
3661 RETURN (EVALCAR (proc
, args
));
3663 if (!SCM_SMOB_APPLICABLE_P (proc
))
3665 if (SCM_UNBNDP (arg1
))
3666 RETURN (SCM_SMOB_APPLY_0 (proc
));
3667 else if (SCM_NULLP (args
))
3668 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3669 else if (SCM_NULLP (SCM_CDR (args
)))
3670 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3672 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3675 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3677 proc
= SCM_CCLO_SUBR (proc
);
3678 debug
.vect
[0].a
.proc
= proc
;
3679 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3681 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3683 proc
= SCM_CCLO_SUBR (proc
);
3687 proc
= SCM_PROCEDURE (proc
);
3689 debug
.vect
[0].a
.proc
= proc
;
3692 case scm_tcs_struct
:
3693 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3696 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3698 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3700 RETURN (scm_apply_generic (proc
, args
));
3702 else if (!SCM_I_OPERATORP (proc
))
3707 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3709 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3712 proc
= (SCM_I_ENTITYP (proc
)
3713 ? SCM_ENTITY_PROCEDURE (proc
)
3714 : SCM_OPERATOR_PROCEDURE (proc
));
3716 debug
.vect
[0].a
.proc
= proc
;
3717 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3719 if (SCM_NIMP (proc
))
3725 scm_wrong_num_args (proc
);
3728 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3733 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3734 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3736 SCM_CLEAR_TRACED_FRAME (debug
);
3737 if (SCM_CHEAPTRAPS_P
)
3738 arg1
= scm_make_debugobj (&debug
);
3742 SCM val
= scm_make_continuation (&first
);
3753 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3757 scm_last_debug_frame
= debug
.prev
;
3763 /* SECTION: The rest of this file is only read once.
3768 /* Typechecking for multi-argument MAP and FOR-EACH.
3770 Verify that each element of the vector ARGV, except for the first,
3771 is a proper list whose length is LEN. Attribute errors to WHO,
3772 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3774 check_map_args (SCM argv
,
3781 SCM
*ve
= SCM_VELTS (argv
);
3784 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3786 long elt_len
= scm_ilength (ve
[i
]);
3791 scm_apply_generic (gf
, scm_cons (proc
, args
));
3793 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3797 scm_out_of_range (who
, ve
[i
]);
3800 scm_remember_upto_here_1 (argv
);
3804 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3806 /* Note: Currently, scm_map applies PROC to the argument list(s)
3807 sequentially, starting with the first element(s). This is used in
3808 evalext.c where the Scheme procedure `map-in-order', which guarantees
3809 sequential behaviour, is implemented using scm_map. If the
3810 behaviour changes, we need to update `map-in-order'.
3814 scm_map (SCM proc
, SCM arg1
, SCM args
)
3815 #define FUNC_NAME s_map
3820 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3822 len
= scm_ilength (arg1
);
3823 SCM_GASSERTn (len
>= 0,
3824 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3825 SCM_VALIDATE_REST_ARGUMENT (args
);
3826 if (SCM_NULLP (args
))
3828 while (SCM_NIMP (arg1
))
3830 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3831 pres
= SCM_CDRLOC (*pres
);
3832 arg1
= SCM_CDR (arg1
);
3836 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3837 ve
= SCM_VELTS (args
);
3838 #ifndef SCM_RECKLESS
3839 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3844 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3846 if (SCM_IMP (ve
[i
]))
3848 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3849 ve
[i
] = SCM_CDR (ve
[i
]);
3851 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3852 pres
= SCM_CDRLOC (*pres
);
3858 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3861 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3862 #define FUNC_NAME s_for_each
3864 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3866 len
= scm_ilength (arg1
);
3867 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3868 SCM_ARG2
, s_for_each
);
3869 SCM_VALIDATE_REST_ARGUMENT (args
);
3870 if (SCM_NULLP (args
))
3872 while (SCM_NIMP (arg1
))
3874 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3875 arg1
= SCM_CDR (arg1
);
3877 return SCM_UNSPECIFIED
;
3879 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3880 ve
= SCM_VELTS (args
);
3881 #ifndef SCM_RECKLESS
3882 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3887 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3889 if (SCM_IMP (ve
[i
]))
3890 return SCM_UNSPECIFIED
;
3891 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3892 ve
[i
] = SCM_CDR (ve
[i
]);
3894 scm_apply (proc
, arg1
, SCM_EOL
);
3901 scm_closure (SCM code
, SCM env
)
3904 SCM closcar
= scm_cons (code
, SCM_EOL
);
3905 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3906 scm_remember_upto_here (closcar
);
3911 scm_t_bits scm_tc16_promise
;
3914 scm_makprom (SCM code
)
3916 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3922 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3924 int writingp
= SCM_WRITINGP (pstate
);
3925 scm_puts ("#<promise ", port
);
3926 SCM_SET_WRITINGP (pstate
, 1);
3927 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3928 SCM_SET_WRITINGP (pstate
, writingp
);
3929 scm_putc ('>', port
);
3934 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3936 "If the promise @var{x} has not been computed yet, compute and\n"
3937 "return @var{x}, otherwise just return the previously computed\n"
3939 #define FUNC_NAME s_scm_force
3941 SCM_VALIDATE_SMOB (1, x
, promise
);
3942 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3944 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3945 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3948 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3949 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3953 return SCM_CELL_OBJECT_1 (x
);
3958 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3960 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3961 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3962 #define FUNC_NAME s_scm_promise_p
3964 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3969 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3970 (SCM xorig
, SCM x
, SCM y
),
3971 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3972 "Any source properties associated with @var{xorig} are also associated\n"
3973 "with the new pair.")
3974 #define FUNC_NAME s_scm_cons_source
3977 z
= scm_cons (x
, y
);
3978 /* Copy source properties possibly associated with xorig. */
3979 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3981 scm_whash_insert (scm_source_whash
, z
, p
);
3987 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3989 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3990 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3991 "contents of both pairs and vectors (since both cons cells and vector\n"
3992 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3993 "any other object.")
3994 #define FUNC_NAME s_scm_copy_tree
3999 if (SCM_VECTORP (obj
))
4001 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4002 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4004 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
4007 if (!SCM_CONSP (obj
))
4009 ans
= tl
= scm_cons_source (obj
,
4010 scm_copy_tree (SCM_CAR (obj
)),
4012 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4014 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4018 SCM_SETCDR (tl
, obj
);
4024 /* We have three levels of EVAL here:
4026 - scm_i_eval (exp, env)
4028 evaluates EXP in environment ENV. ENV is a lexical environment
4029 structure as used by the actual tree code evaluator. When ENV is
4030 a top-level environment, then changes to the current module are
4031 tracked by updating ENV so that it continues to be in sync with
4034 - scm_primitive_eval (exp)
4036 evaluates EXP in the top-level environment as determined by the
4037 current module. This is done by constructing a suitable
4038 environment and calling scm_i_eval. Thus, changes to the
4039 top-level module are tracked normally.
4041 - scm_eval (exp, mod)
4043 evaluates EXP while MOD is the current module. This is done by
4044 setting the current module to MOD, invoking scm_primitive_eval on
4045 EXP, and then restoring the current module to the value it had
4046 previously. That is, while EXP is evaluated, changes to the
4047 current module are tracked, but these changes do not persist when
4050 For each level of evals, there are two variants, distinguished by a
4051 _x suffix: the ordinary variant does not modify EXP while the _x
4052 variant can destructively modify EXP into something completely
4053 unintelligible. A Scheme data structure passed as EXP to one of the
4054 _x variants should not ever be used again for anything. So when in
4055 doubt, use the ordinary variant.
4060 scm_i_eval_x (SCM exp
, SCM env
)
4062 return SCM_XEVAL (exp
, env
);
4066 scm_i_eval (SCM exp
, SCM env
)
4068 exp
= scm_copy_tree (exp
);
4069 return SCM_XEVAL (exp
, env
);
4073 scm_primitive_eval_x (SCM exp
)
4076 SCM transformer
= scm_current_module_transformer ();
4077 if (SCM_NIMP (transformer
))
4078 exp
= scm_call_1 (transformer
, exp
);
4079 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4080 return scm_i_eval_x (exp
, env
);
4083 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4085 "Evaluate @var{exp} in the top-level environment specified by\n"
4086 "the current module.")
4087 #define FUNC_NAME s_scm_primitive_eval
4090 SCM transformer
= scm_current_module_transformer ();
4091 if (SCM_NIMP (transformer
))
4092 exp
= scm_call_1 (transformer
, exp
);
4093 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4094 return scm_i_eval (exp
, env
);
4098 /* Eval does not take the second arg optionally. This is intentional
4099 * in order to be R5RS compatible, and to prepare for the new module
4100 * system, where we would like to make the choice of evaluation
4101 * environment explicit. */
4104 change_environment (void *data
)
4106 SCM pair
= SCM_PACK (data
);
4107 SCM new_module
= SCM_CAR (pair
);
4108 SCM old_module
= scm_current_module ();
4109 SCM_SETCDR (pair
, old_module
);
4110 scm_set_current_module (new_module
);
4115 restore_environment (void *data
)
4117 SCM pair
= SCM_PACK (data
);
4118 SCM old_module
= SCM_CDR (pair
);
4119 SCM new_module
= scm_current_module ();
4120 SCM_SETCAR (pair
, new_module
);
4121 scm_set_current_module (old_module
);
4125 inner_eval_x (void *data
)
4127 return scm_primitive_eval_x (SCM_PACK(data
));
4131 scm_eval_x (SCM exp
, SCM module
)
4132 #define FUNC_NAME "eval!"
4134 SCM_VALIDATE_MODULE (2, module
);
4136 return scm_internal_dynamic_wind
4137 (change_environment
, inner_eval_x
, restore_environment
,
4138 (void *) SCM_UNPACK (exp
),
4139 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4144 inner_eval (void *data
)
4146 return scm_primitive_eval (SCM_PACK(data
));
4149 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4150 (SCM exp
, SCM module
),
4151 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4152 "in the top-level environment specified by @var{module}.\n"
4153 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4154 "@var{module} is made the current module. The current module\n"
4155 "is reset to its previous value when @var{eval} returns.")
4156 #define FUNC_NAME s_scm_eval
4158 SCM_VALIDATE_MODULE (2, module
);
4160 return scm_internal_dynamic_wind
4161 (change_environment
, inner_eval
, restore_environment
,
4162 (void *) SCM_UNPACK (exp
),
4163 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4168 /* At this point, scm_deval and scm_dapply are generated.
4171 #ifdef DEBUG_EXTENSIONS
4181 scm_init_opts (scm_evaluator_traps
,
4182 scm_evaluator_trap_table
,
4183 SCM_N_EVALUATOR_TRAPS
);
4184 scm_init_opts (scm_eval_options_interface
,
4186 SCM_N_EVAL_OPTIONS
);
4188 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4189 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4190 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4192 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4193 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4194 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4195 scm_listofnull
= scm_list_1 (SCM_EOL
);
4197 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4202 #ifndef SCM_MAGIC_SNARFER
4203 #include "libguile/eval.x"
4206 scm_add_feature ("delay");