1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 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/goops.h"
100 #include "libguile/values.h"
102 #include "libguile/validate.h"
103 #include "libguile/eval.h"
104 #include "libguile/lang.h"
108 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
110 if (SCM_EQ_P ((x), SCM_EOL)) \
111 scm_misc_error (NULL, scm_s_expression, SCM_EOL); \
116 /* The evaluator contains a plethora of EVAL symbols.
117 * This is an attempt at explanation.
119 * The following macros should be used in code which is read twice
120 * (where the choice of evaluator is hard soldered):
122 * SCM_CEVAL is the symbol used within one evaluator to call itself.
123 * Originally, it is defined to scm_ceval, but is redefined to
124 * scm_deval during the second pass.
126 * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
127 * only side effects of expressions matter. All immediates are
130 * SCM_EVALIM is used when it is known that the expression is an
131 * immediate. (This macro never calls an evaluator.)
133 * EVALCAR evaluates the car of an expression.
135 * EVALCELLCAR is like EVALCAR, but is used when it is known that the
136 * car is a lisp cell.
138 * The following macros should be used in code which is read once
139 * (where the choice of evaluator is dynamic):
141 * SCM_XEVAL takes care of immediates without calling an evaluator. It
142 * then calls scm_ceval *or* scm_deval, depending on the debugging
145 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
146 * depending on the debugging mode.
148 * The main motivation for keeping this plethora is efficiency
149 * together with maintainability (=> locality of code).
152 #define SCM_CEVAL scm_ceval
153 #define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env))
155 #define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
156 ? *scm_lookupcar (x, env, 1) \
157 : SCM_CEVAL (SCM_CAR (x), env))
159 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
160 ? SCM_EVALIM (SCM_CAR (x), env) \
161 : EVALCELLCAR (x, env))
163 #define EXTEND_ENV SCM_EXTEND_ENV
165 #ifdef MEMOIZE_LOCALS
168 scm_ilookup (SCM iloc
, SCM env
)
170 register long ir
= SCM_IFRAME (iloc
);
171 register SCM er
= env
;
172 for (; 0 != ir
; --ir
)
175 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
177 if (SCM_ICDRP (iloc
))
178 return SCM_CDRLOC (er
);
179 return SCM_CARLOC (SCM_CDR (er
));
185 /* The Lookup Car Race
188 Memoization of variables and special forms is done while executing
189 the code for the first time. As long as there is only one thread
190 everything is fine, but as soon as two threads execute the same
191 code concurrently `for the first time' they can come into conflict.
193 This memoization includes rewriting variable references into more
194 efficient forms and expanding macros. Furthermore, macro expansion
195 includes `compiling' special forms like `let', `cond', etc. into
196 tree-code instructions.
198 There shouldn't normally be a problem with memoizing local and
199 global variable references (into ilocs and variables), because all
200 threads will mutate the code in *exactly* the same way and (if I
201 read the C code correctly) it is not possible to observe a half-way
202 mutated cons cell. The lookup procedure can handle this
203 transparently without any critical sections.
205 It is different with macro expansion, because macro expansion
206 happens outside of the lookup procedure and can't be
207 undone. Therefore the lookup procedure can't cope with it. It has
208 to indicate failure when it detects a lost race and hope that the
209 caller can handle it. Luckily, it turns out that this is the case.
211 An example to illustrate this: Suppose that the following form will
212 be memoized concurrently by two threads
216 Let's first examine the lookup of X in the body. The first thread
217 decides that it has to find the symbol "x" in the environment and
218 starts to scan it. Then the other thread takes over and actually
219 overtakes the first. It looks up "x" and substitutes an
220 appropriate iloc for it. Now the first thread continues and
221 completes its lookup. It comes to exactly the same conclusions as
222 the second one and could - without much ado - just overwrite the
223 iloc with the same iloc.
225 But let's see what will happen when the race occurs while looking
226 up the symbol "let" at the start of the form. It could happen that
227 the second thread interrupts the lookup of the first thread and not
228 only substitutes a variable for it but goes right ahead and
229 replaces it with the compiled form (#@let* (x 12) x). Now, when
230 the first thread completes its lookup, it would replace the #@let*
231 with a variable containing the "let" binding, effectively reverting
232 the form to (let (x 12) x). This is wrong. It has to detect that
233 it has lost the race and the evaluator has to reconsider the
234 changed form completely.
236 This race condition could be resolved with some kind of traffic
237 light (like mutexes) around scm_lookupcar, but I think that it is
238 best to avoid them in this case. They would serialize memoization
239 completely and because lookup involves calling arbitrary Scheme
240 code (via the lookup-thunk), threads could be blocked for an
241 arbitrary amount of time or even deadlock. But with the current
242 solution a lot of unnecessary work is potentially done. */
244 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
245 return NULL to indicate a failed lookup due to some race conditions
246 between threads. This only happens when VLOC is the first cell of
247 a special form that will eventually be memoized (like `let', etc.)
248 In that case the whole lookup is bogus and the caller has to
249 reconsider the complete special form.
251 SCM_LOOKUPCAR is still there, of course. It just calls
252 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
253 should only be called when it is known that VLOC is not the first
254 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
255 for NULL. I think I've found the only places where this
258 #endif /* USE_THREADS */
260 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
264 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
267 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
271 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
272 #ifdef MEMOIZE_LOCALS
273 register SCM iloc
= SCM_ILOC00
;
275 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
277 if (!SCM_CONSP (SCM_CAR (env
)))
279 al
= SCM_CARLOC (env
);
280 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
284 if (SCM_EQ_P (fl
, var
))
286 #ifdef MEMOIZE_LOCALS
288 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
291 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
293 return SCM_CDRLOC (*al
);
298 al
= SCM_CDRLOC (*al
);
299 if (SCM_EQ_P (SCM_CAR (fl
), var
))
301 #ifdef MEMOIZE_LOCALS
302 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
303 if (SCM_UNBNDP (SCM_CAR (*al
)))
310 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
313 SCM_SETCAR (vloc
, iloc
);
315 return SCM_CARLOC (*al
);
317 #ifdef MEMOIZE_LOCALS
318 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
321 #ifdef MEMOIZE_LOCALS
322 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
326 SCM top_thunk
, real_var
;
329 top_thunk
= SCM_CAR (env
); /* env now refers to a
330 top level env thunk */
334 top_thunk
= SCM_BOOL_F
;
335 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
336 if (SCM_FALSEP (real_var
))
340 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
346 scm_error (scm_unbound_variable_key
, NULL
,
347 "Unbound variable: ~S",
348 scm_list_1 (var
), SCM_BOOL_F
);
350 scm_misc_error (NULL
, "Damaged environment: ~S",
355 /* A variable could not be found, but we shall
356 not throw an error. */
357 static SCM undef_object
= SCM_UNDEFINED
;
358 return &undef_object
;
364 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
366 /* Some other thread has changed the very cell we are working
367 on. In effect, it must have done our job or messed it up
370 var
= SCM_CAR (vloc
);
371 if (SCM_VARIABLEP (var
))
372 return SCM_VARIABLE_LOC (var
);
373 #ifdef MEMOIZE_LOCALS
374 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
375 return scm_ilookup (var
, genv
);
377 /* We can't cope with anything else than variables and ilocs. When
378 a special form has been memoized (i.e. `let' into `#@let') we
379 return NULL and expect the calling function to do the right
380 thing. For the evaluator, this means going back and redoing
381 the dispatch on the car of the form. */
384 #endif /* USE_THREADS */
386 SCM_SETCAR (vloc
, real_var
);
387 return SCM_VARIABLE_LOC (real_var
);
393 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
395 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
402 #define unmemocar scm_unmemocar
404 SCM_SYMBOL (sym_three_question_marks
, "???");
407 scm_unmemocar (SCM form
, SCM env
)
409 if (!SCM_CONSP (form
))
413 SCM c
= SCM_CAR (form
);
414 if (SCM_VARIABLEP (c
))
416 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
417 if (SCM_FALSEP (sym
))
418 sym
= sym_three_question_marks
;
419 SCM_SETCAR (form
, sym
);
421 #ifdef MEMOIZE_LOCALS
422 else if (SCM_ILOCP (c
))
424 unsigned long int ir
;
426 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
428 env
= SCM_CAAR (env
);
429 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
431 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
440 scm_eval_car (SCM pair
, SCM env
)
442 return SCM_XEVALCAR (pair
, env
);
447 * The following rewrite expressions and
448 * some memoized forms have different syntax
451 const char scm_s_expression
[] = "missing or extra expression";
452 const char scm_s_test
[] = "bad test";
453 const char scm_s_body
[] = "bad body";
454 const char scm_s_bindings
[] = "bad bindings";
455 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
456 const char scm_s_variable
[] = "bad variable";
457 const char scm_s_clauses
[] = "bad or missing clauses";
458 const char scm_s_formals
[] = "bad formals";
459 const char scm_s_duplicate_formals
[] = "duplicate formals";
460 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
462 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
463 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
464 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
465 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
466 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
470 #ifdef DEBUG_EXTENSIONS
471 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
472 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
473 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
474 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
478 /* Check that the body denoted by XORIG is valid and rewrite it into
479 its internal form. The internal form of a body is just the body
480 itself, but prefixed with an ISYM that denotes to what kind of
481 outer construct this body belongs. A lambda body starts with
482 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
483 etc. The one exception is a body that belongs to a letrec that has
484 been formed by rewriting internal defines: it starts with
487 /* XXX - Besides controlling the rewriting of internal defines, the
488 additional ISYM could be used for improved error messages.
489 This is not done yet. */
492 scm_m_body (SCM op
, SCM xorig
, const char *what
)
494 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
496 /* Don't add another ISYM if one is present already. */
497 if (SCM_ISYMP (SCM_CAR (xorig
)))
500 /* Retain possible doc string. */
501 if (!SCM_CONSP (SCM_CAR (xorig
)))
503 if (!SCM_NULLP (SCM_CDR (xorig
)))
504 return scm_cons (SCM_CAR (xorig
),
505 scm_m_body (op
, SCM_CDR (xorig
), what
));
509 return scm_cons (op
, xorig
);
513 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
514 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
517 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
519 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
520 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
524 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
525 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
528 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
530 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
531 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
535 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
536 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
539 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
541 long len
= scm_ilength (SCM_CDR (xorig
));
542 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
543 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
547 /* Will go into the RnRS module when Guile is factorized.
548 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
549 const char scm_s_set_x
[] = "set!";
550 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
553 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
555 SCM x
= SCM_CDR (xorig
);
556 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
557 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
558 return scm_cons (SCM_IM_SET_X
, x
);
562 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
563 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
566 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
568 long len
= scm_ilength (SCM_CDR (xorig
));
569 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
571 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
577 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
578 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
581 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
583 long len
= scm_ilength (SCM_CDR (xorig
));
584 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
586 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
592 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
593 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
596 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
599 SCM cdrx
= SCM_CDR (xorig
);
600 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
601 clauses
= SCM_CDR (cdrx
);
602 while (!SCM_NULLP (clauses
))
604 SCM clause
= SCM_CAR (clauses
);
605 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
606 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
607 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
608 && SCM_NULLP (SCM_CDR (clauses
))),
609 scm_s_clauses
, s_case
);
610 clauses
= SCM_CDR (clauses
);
612 return scm_cons (SCM_IM_CASE
, cdrx
);
616 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
617 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
620 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
622 SCM cdrx
= SCM_CDR (xorig
);
624 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
625 while (!SCM_NULLP (clauses
))
627 SCM clause
= SCM_CAR (clauses
);
628 long len
= scm_ilength (clause
);
629 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
630 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
632 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
633 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
635 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
637 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
638 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
640 clauses
= SCM_CDR (clauses
);
642 return scm_cons (SCM_IM_COND
, cdrx
);
646 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
647 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
649 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
650 * cdr of the last cons. (Thus, LIST is not required to be a proper
651 * list and OBJ can also be found in the improper ending.) */
653 scm_c_improper_memq (SCM obj
, SCM list
)
655 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
657 if (SCM_EQ_P (SCM_CAR (list
), obj
))
660 return SCM_EQ_P (list
, obj
);
664 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
667 SCM x
= SCM_CDR (xorig
);
669 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
671 formals
= SCM_CAR (x
);
672 while (SCM_CONSP (formals
))
674 SCM formal
= SCM_CAR (formals
);
675 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
676 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
677 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
678 formals
= SCM_CDR (formals
);
680 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
681 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
683 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
684 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
688 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
689 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
691 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
692 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
694 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
697 SCM x
= SCM_CDR (xorig
);
701 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
703 bindings
= SCM_CAR (x
);
704 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
705 while (!SCM_NULLP (bindings
))
707 SCM binding
= SCM_CAR (bindings
);
708 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
709 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
710 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
711 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
712 bindings
= SCM_CDR (bindings
);
715 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
716 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
720 /* DO gets the most radically altered syntax. The order of the vars is
721 * reversed here. In contrast, the order of the inits and steps is reversed
722 * during the evaluation:
724 (do ((<var1> <init1> <step1>)
732 (#@do (varn ... var2 var1)
733 (<init1> <init2> ... <initn>)
736 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
739 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
740 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
743 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
746 SCM x
= SCM_CDR (xorig
);
749 SCM
*initloc
= &inits
;
751 SCM
*steploc
= &steps
;
752 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
753 bindings
= SCM_CAR (x
);
754 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
755 while (!SCM_NULLP (bindings
))
757 SCM binding
= SCM_CAR (bindings
);
758 long len
= scm_ilength (binding
);
759 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
761 SCM name
= SCM_CAR (binding
);
762 SCM init
= SCM_CADR (binding
);
763 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
764 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
765 vars
= scm_cons (name
, vars
);
766 *initloc
= scm_list_1 (init
);
767 initloc
= SCM_CDRLOC (*initloc
);
768 *steploc
= scm_list_1 (step
);
769 steploc
= SCM_CDRLOC (*steploc
);
770 bindings
= SCM_CDR (bindings
);
774 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
775 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
776 x
= scm_cons2 (vars
, inits
, x
);
777 return scm_cons (SCM_IM_DO
, x
);
781 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
782 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
784 /* Internal function to handle a quasiquotation: 'form' is the parameter in
785 * the call (quasiquotation form), 'env' is the environment where unquoted
786 * expressions will be evaluated, and 'depth' is the current quasiquotation
787 * nesting level and is known to be greater than zero. */
789 iqq (SCM form
, SCM env
, unsigned long int depth
)
791 if (SCM_CONSP (form
))
793 SCM tmp
= SCM_CAR (form
);
794 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
796 SCM args
= SCM_CDR (form
);
797 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
798 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
800 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
802 SCM args
= SCM_CDR (form
);
803 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
805 return scm_eval_car (args
, env
);
807 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
809 else if (SCM_CONSP (tmp
)
810 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
812 SCM args
= SCM_CDR (tmp
);
813 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
816 SCM list
= scm_eval_car (args
, env
);
817 SCM rest
= SCM_CDR (form
);
818 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
819 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
822 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
823 iqq (SCM_CDR (form
), env
, depth
));
826 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
827 iqq (SCM_CDR (form
), env
, depth
));
829 else if (SCM_VECTORP (form
))
831 size_t i
= SCM_VECTOR_LENGTH (form
);
832 SCM
*data
= SCM_VELTS (form
);
835 tmp
= scm_cons (data
[--i
], tmp
);
836 scm_remember_upto_here_1 (form
);
837 return scm_vector (iqq (tmp
, env
, depth
));
844 scm_m_quasiquote (SCM xorig
, SCM env
)
846 SCM x
= SCM_CDR (xorig
);
847 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
848 return iqq (SCM_CAR (x
), env
, 1);
852 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
853 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
855 /* Promises are implemented as closures with an empty parameter list. Thus,
856 * (delay <expression>) is transformed into (#@delay '() <expression>), where
857 * the empty list represents the empty parameter list. This representation
858 * allows for easy creation of the closure during evaluation. */
860 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
862 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
863 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
867 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
868 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
870 /* Guile provides an extension to R5RS' define syntax to represent function
871 * currying in a compact way. With this extension, it is allowed to write
872 * (define <nested-variable> <body>), where <nested-variable> has of one of
873 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
874 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
875 * should be either a sequence of zero or more variables, or a sequence of one
876 * or more variables followed by a space-delimited period and another
877 * variable. Each level of argument nesting wraps the <body> within another
878 * lambda expression. For example, the following forms are allowed, each one
879 * followed by an equivalent, more explicit implementation.
881 * (define ((a b . c) . d) <body>) is equivalent to
882 * (define a (lambda (b . c) (lambda d <body>)))
884 * (define (((a) b) c . d) <body>) is equivalent to
885 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
887 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
888 * module that does not implement this extension. */
890 scm_m_define (SCM x
, SCM env
)
894 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
897 while (SCM_CONSP (name
))
899 /* This while loop realizes function currying by variable nesting. */
900 SCM formals
= SCM_CDR (name
);
901 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
902 name
= SCM_CAR (name
);
904 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
905 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
906 if (SCM_TOP_LEVEL (env
))
909 x
= scm_eval_car (x
, env
);
910 if (SCM_REC_PROCNAMES_P
)
913 while (SCM_MACROP (tmp
))
914 tmp
= SCM_MACRO_CODE (tmp
);
915 if (SCM_CLOSUREP (tmp
)
916 /* Only the first definition determines the name. */
917 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
918 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
920 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
921 SCM_VARIABLE_SET (var
, x
);
922 return SCM_UNSPECIFIED
;
925 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
929 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
930 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
931 * reversed here, the list of inits gets reversed during evaluation. */
933 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
939 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
943 SCM binding
= SCM_CAR (bindings
);
944 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
945 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
946 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
947 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
948 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
949 *initloc
= scm_list_1 (SCM_CADR (binding
));
950 initloc
= SCM_CDRLOC (*initloc
);
951 bindings
= SCM_CDR (bindings
);
953 while (!SCM_NULLP (bindings
));
959 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
960 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
963 scm_m_letrec (SCM xorig
, SCM env
)
965 SCM x
= SCM_CDR (xorig
);
966 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
968 if (SCM_NULLP (SCM_CAR (x
)))
970 /* null binding, let* faster */
971 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
972 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
976 SCM rvars
, inits
, body
;
977 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
978 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
979 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
984 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
985 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
988 scm_m_let (SCM xorig
, SCM env
)
990 SCM x
= SCM_CDR (xorig
);
993 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
996 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
998 /* null or single binding, let* is faster */
1000 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
1001 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
1003 else if (SCM_CONSP (temp
))
1006 SCM bindings
= temp
;
1007 SCM rvars
, inits
, body
;
1008 transform_bindings (bindings
, &rvars
, &inits
, "let");
1009 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1010 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1014 /* named let: Transform (let name ((var init) ...) body ...) into
1015 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1019 SCM
*varloc
= &vars
;
1020 SCM inits
= SCM_EOL
;
1021 SCM
*initloc
= &inits
;
1024 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1026 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1027 bindings
= SCM_CAR (x
);
1028 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1029 while (!SCM_NULLP (bindings
))
1030 { /* vars and inits both in order */
1031 SCM binding
= SCM_CAR (bindings
);
1032 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1033 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1034 *varloc
= scm_list_1 (SCM_CAR (binding
));
1035 varloc
= SCM_CDRLOC (*varloc
);
1036 *initloc
= scm_list_1 (SCM_CADR (binding
));
1037 initloc
= SCM_CDRLOC (*initloc
);
1038 bindings
= SCM_CDR (bindings
);
1042 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1043 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1044 SCM rvar
= scm_list_1 (name
);
1045 SCM init
= scm_list_1 (lambda_form
);
1046 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1047 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1048 return scm_cons (letrec
, inits
);
1054 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1055 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1056 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1059 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1061 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1062 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1066 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1067 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1071 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1073 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1074 scm_s_expression
, s_atcall_cc
);
1075 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1078 #ifdef SCM_ENABLE_ELISP
1080 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1083 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1085 long len
= scm_ilength (SCM_CDR (xorig
));
1086 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1087 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1090 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1093 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1095 SCM x
= SCM_CDR (xorig
), var
;
1096 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1097 var
= scm_symbol_fref (SCM_CAR (x
));
1098 /* Passing the symbol name as the `subr' arg here isn't really
1099 right, but without it it can be very difficult to work out from
1100 the error message which function definition was missing. In any
1101 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1102 something equivalent to (signal void-function (list SYM)) in
1104 SCM_ASSYNT (SCM_VARIABLEP (var
),
1105 "Symbol's function definition is void",
1106 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1107 /* Support `defalias'. */
1108 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1110 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1111 SCM_ASSYNT (SCM_VARIABLEP (var
),
1112 "Symbol's function definition is void",
1113 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1115 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1116 former allows for automatically picking up redefinitions of the
1117 corresponding symbol. */
1118 SCM_SETCAR (x
, var
);
1119 /* If the variable contains a procedure, leave the
1120 `transformer-macro' in place so that the procedure's arguments
1121 get properly transformed, and change the initial @fop to
1123 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1125 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1128 /* Otherwise (the variable contains a macro), the arguments should
1129 not be transformed, so cut the `transformer-macro' out and return
1130 the resulting expression starting with the variable. */
1131 SCM_SETCDR (x
, SCM_CDADR (x
));
1135 #endif /* SCM_ENABLE_ELISP */
1137 /* (@bind ((var exp) ...) body ...)
1139 This will assign the values of the `exp's to the global variables
1140 named by `var's (symbols, not evaluated), creating them if they
1141 don't exist, executes body, and then restores the previous values of
1142 the `var's. Additionally, whenever control leaves body, the values
1143 of the `var's are saved and restored when control returns. It is an
1144 error when a symbol appears more than once among the `var's.
1145 All `exp's are evaluated before any `var' is set.
1147 Think of this as `let' for dynamic scope.
1149 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1151 XXX - also implement `@bind*'.
1154 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1157 scm_m_atbind (SCM xorig
, SCM env
)
1159 SCM x
= SCM_CDR (xorig
);
1160 SCM top_level
= scm_env_top_level (env
);
1161 SCM vars
= SCM_EOL
, var
;
1164 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1167 while (SCM_NIMP (x
))
1170 SCM sym_exp
= SCM_CAR (x
);
1171 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1172 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1174 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1175 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1176 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1177 /* The first call to scm_sym2var will look beyond the current
1178 module, while the second call wont. */
1179 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1180 if (SCM_FALSEP (var
))
1181 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1182 vars
= scm_cons (var
, vars
);
1183 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1185 return scm_cons (SCM_IM_BIND
,
1186 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1190 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1191 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1194 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1196 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1197 scm_s_expression
, s_at_call_with_values
);
1198 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1202 scm_m_expand_body (SCM xorig
, SCM env
)
1204 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1205 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1207 while (SCM_NIMP (x
))
1209 SCM form
= SCM_CAR (x
);
1210 if (!SCM_CONSP (form
))
1212 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1215 form
= scm_macroexp (scm_cons_source (form
,
1220 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1222 defs
= scm_cons (SCM_CDR (form
), defs
);
1225 else if (!SCM_IMP (defs
))
1229 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1231 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1235 x
= scm_cons (form
, SCM_CDR (x
));
1240 if (!SCM_NULLP (defs
))
1242 SCM rvars
, inits
, body
, letrec
;
1243 transform_bindings (defs
, &rvars
, &inits
, what
);
1244 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1245 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1246 SCM_SETCAR (xorig
, letrec
);
1247 SCM_SETCDR (xorig
, SCM_EOL
);
1251 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1252 SCM_SETCAR (xorig
, SCM_CAR (x
));
1253 SCM_SETCDR (xorig
, SCM_CDR (x
));
1260 scm_macroexp (SCM x
, SCM env
)
1262 SCM res
, proc
, orig_sym
;
1264 /* Don't bother to produce error messages here. We get them when we
1265 eventually execute the code for real. */
1268 orig_sym
= SCM_CAR (x
);
1269 if (!SCM_SYMBOLP (orig_sym
))
1274 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1275 if (proc_ptr
== NULL
)
1277 /* We have lost the race. */
1283 proc
= *scm_lookupcar (x
, env
, 0);
1286 /* Only handle memoizing macros. `Acros' and `macros' are really
1287 special forms and should not be evaluated here. */
1289 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1292 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1293 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1295 if (scm_ilength (res
) <= 0)
1296 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1299 SCM_SETCAR (x
, SCM_CAR (res
));
1300 SCM_SETCDR (x
, SCM_CDR (res
));
1306 /* scm_unmemocopy takes a memoized expression together with its
1307 * environment and rewrites it to its original form. Thus, it is the
1308 * inversion of the rewrite rules above. The procedure is not
1309 * optimized for speed. It's used in scm_iprin1 when printing the
1310 * code of a closure, in scm_procedure_source, in display_frame when
1311 * generating the source for a stackframe in a backtrace, and in
1312 * display_expression.
1314 * Unmemoizing is not a reliable process. You cannot in general
1315 * expect to get the original source back.
1317 * However, GOOPS currently relies on this for method compilation.
1318 * This ought to change.
1321 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1324 build_binding_list (SCM names
, SCM inits
)
1326 SCM bindings
= SCM_EOL
;
1327 while (!SCM_NULLP (names
))
1329 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1330 bindings
= scm_cons (binding
, bindings
);
1331 names
= SCM_CDR (names
);
1332 inits
= SCM_CDR (inits
);
1338 unmemocopy (SCM x
, SCM env
)
1341 #ifdef DEBUG_EXTENSIONS
1346 #ifdef DEBUG_EXTENSIONS
1347 p
= scm_whash_lookup (scm_source_whash
, x
);
1349 switch (SCM_ITAG7 (SCM_CAR (x
)))
1351 case SCM_BIT8(SCM_IM_AND
):
1352 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1354 case SCM_BIT8(SCM_IM_BEGIN
):
1355 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1357 case SCM_BIT8(SCM_IM_CASE
):
1358 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1360 case SCM_BIT8(SCM_IM_COND
):
1361 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1363 case SCM_BIT8 (SCM_IM_DO
):
1365 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1366 * where nx is the name of a local variable, ix is an initializer for
1367 * the local variable, test is the test clause of the do loop, body is
1368 * the body of the do loop and sx are the step clauses for the local
1370 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1373 names
= SCM_CAR (x
);
1375 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1376 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1378 test
= unmemocopy (SCM_CAR (x
), env
);
1380 memoized_body
= SCM_CAR (x
);
1382 steps
= scm_reverse (unmemocopy (x
, env
));
1384 /* build transformed binding list */
1386 while (!SCM_NULLP (names
))
1388 SCM name
= SCM_CAR (names
);
1389 SCM init
= SCM_CAR (inits
);
1390 SCM step
= SCM_CAR (steps
);
1391 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1393 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1395 names
= SCM_CDR (names
);
1396 inits
= SCM_CDR (inits
);
1397 steps
= SCM_CDR (steps
);
1399 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1400 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1402 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1405 case SCM_BIT8(SCM_IM_IF
):
1406 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1408 case SCM_BIT8 (SCM_IM_LET
):
1410 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1411 * where nx is the name of a local variable, ix is an initializer for
1412 * the local variable and by are the body clauses. */
1413 SCM names
, inits
, bindings
;
1416 names
= SCM_CAR (x
);
1418 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1419 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1421 bindings
= build_binding_list (names
, inits
);
1422 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1423 ls
= scm_cons (scm_sym_let
, z
);
1426 case SCM_BIT8 (SCM_IM_LETREC
):
1428 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1429 * where nx is the name of a local variable, ix is an initializer for
1430 * the local variable and by are the body clauses. */
1431 SCM names
, inits
, bindings
;
1434 names
= SCM_CAR (x
);
1435 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1437 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1439 bindings
= build_binding_list (names
, inits
);
1440 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1441 ls
= scm_cons (scm_sym_letrec
, z
);
1444 case SCM_BIT8(SCM_IM_LETSTAR
):
1452 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1455 y
= z
= scm_acons (SCM_CAR (b
),
1457 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1459 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1463 SCM_SETCDR (y
, SCM_EOL
);
1464 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1469 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1471 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1474 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1477 while (SCM_NIMP (b
));
1478 SCM_SETCDR (z
, SCM_EOL
);
1480 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1483 case SCM_BIT8(SCM_IM_OR
):
1484 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1486 case SCM_BIT8(SCM_IM_LAMBDA
):
1488 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1489 ls
= scm_cons (scm_sym_lambda
, z
);
1490 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1492 case SCM_BIT8(SCM_IM_QUOTE
):
1493 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1495 case SCM_BIT8(SCM_IM_SET_X
):
1496 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1498 case SCM_BIT8(SCM_IM_DEFINE
):
1503 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1504 ls
= scm_cons (scm_sym_define
, z
);
1505 if (!SCM_NULLP (env
))
1506 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1509 case SCM_BIT8(SCM_MAKISYM (0)):
1513 switch (SCM_ISYMNUM (z
))
1515 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1516 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1518 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1519 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1521 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1522 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1525 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1526 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1529 /* appease the Sun compiler god: */ ;
1533 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1539 while (SCM_CONSP (x
))
1541 SCM form
= SCM_CAR (x
);
1542 if (!SCM_ISYMP (form
))
1544 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1545 SCM_SETCDR (z
, unmemocar (copy
, env
));
1551 #ifdef DEBUG_EXTENSIONS
1552 if (!SCM_FALSEP (p
))
1553 scm_whash_insert (scm_source_whash
, ls
, p
);
1560 scm_unmemocopy (SCM x
, SCM env
)
1562 if (!SCM_NULLP (env
))
1563 /* Make a copy of the lowest frame to protect it from
1564 modifications by SCM_IM_DEFINE */
1565 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1567 return unmemocopy (x
, env
);
1570 #ifndef SCM_RECKLESS
1573 scm_badargsp (SCM formals
, SCM args
)
1575 while (!SCM_NULLP (formals
))
1577 if (!SCM_CONSP (formals
))
1579 if (SCM_NULLP (args
))
1581 formals
= SCM_CDR (formals
);
1582 args
= SCM_CDR (args
);
1584 return !SCM_NULLP (args
) ? 1 : 0;
1590 scm_badformalsp (SCM closure
, int n
)
1592 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1593 while (!SCM_NULLP (formals
))
1595 if (!SCM_CONSP (formals
))
1600 formals
= SCM_CDR (formals
);
1607 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1609 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1610 while (SCM_CONSP (l
))
1612 res
= EVALCAR (l
, env
);
1614 *lloc
= scm_list_1 (res
);
1615 lloc
= SCM_CDRLOC (*lloc
);
1620 scm_wrong_num_args (proc
);
1626 scm_eval_body (SCM code
, SCM env
)
1630 next
= SCM_CDR (code
);
1631 while (!SCM_NULLP (next
))
1633 if (SCM_IMP (SCM_CAR (code
)))
1635 if (SCM_ISYMP (SCM_CAR (code
)))
1637 code
= scm_m_expand_body (code
, env
);
1642 SCM_XEVAL (SCM_CAR (code
), env
);
1644 next
= SCM_CDR (code
);
1646 return SCM_XEVALCAR (code
, env
);
1653 /* SECTION: This code is specific for the debugging support. One
1654 * branch is read when DEVAL isn't defined, the other when DEVAL is
1660 #define SCM_APPLY scm_apply
1661 #define PREP_APPLY(proc, args)
1663 #define RETURN(x) do { return x; } while (0)
1664 #ifdef STACK_CHECKING
1665 #ifndef NO_CEVAL_STACK_CHECKING
1666 #define EVAL_STACK_CHECKING
1673 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1675 #define SCM_APPLY scm_dapply
1677 #define PREP_APPLY(p, l) \
1678 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1680 #define ENTER_APPLY \
1682 SCM_SET_ARGSREADY (debug);\
1683 if (CHECK_APPLY && SCM_TRAPS_P)\
1684 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1686 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1687 SCM_SET_TRACED_FRAME (debug); \
1689 if (SCM_CHEAPTRAPS_P)\
1691 tmp = scm_make_debugobj (&debug);\
1692 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1697 tmp = scm_make_continuation (&first);\
1699 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1705 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1706 #ifdef STACK_CHECKING
1707 #ifndef EVAL_STACK_CHECKING
1708 #define EVAL_STACK_CHECKING
1712 /* scm_ceval_ptr points to the currently selected evaluator.
1713 * *fixme*: Although efficiency is important here, this state variable
1714 * should probably not be a global. It should be related to the
1719 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1721 /* scm_last_debug_frame contains a pointer to the last debugging
1722 * information stack frame. It is accessed very often from the
1723 * debugging evaluator, so it should probably not be indirectly
1724 * addressed. Better to save and restore it from the current root at
1729 scm_t_debug_frame
*scm_last_debug_frame
;
1732 /* scm_debug_eframe_size is the number of slots available for pseudo
1733 * stack frames at each real stack frame.
1736 long scm_debug_eframe_size
;
1738 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1740 long scm_eval_stack
;
1742 scm_t_option scm_eval_opts
[] = {
1743 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1746 scm_t_option scm_debug_opts
[] = {
1747 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1748 "*Flyweight representation of the stack at traps." },
1749 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1750 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1751 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1752 "Record procedure names at definition." },
1753 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1754 "Display backtrace in anti-chronological order." },
1755 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1756 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1757 { SCM_OPTION_INTEGER
, "frames", 3,
1758 "Maximum number of tail-recursive frames in backtrace." },
1759 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1760 "Maximal number of stored backtrace frames." },
1761 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1762 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1763 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1764 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1765 { 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."}
1768 scm_t_option scm_evaluator_trap_table
[] = {
1769 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1770 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1771 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1772 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1773 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1774 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1775 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1778 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1780 "Option interface for the evaluation options. Instead of using\n"
1781 "this procedure directly, use the procedures @code{eval-enable},\n"
1782 "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.")
1783 #define FUNC_NAME s_scm_eval_options_interface
1787 ans
= scm_options (setting
,
1791 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1797 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1799 "Option interface for the evaluator trap options.")
1800 #define FUNC_NAME s_scm_evaluator_traps
1804 ans
= scm_options (setting
,
1805 scm_evaluator_trap_table
,
1806 SCM_N_EVALUATOR_TRAPS
,
1808 SCM_RESET_DEBUG_MODE
;
1815 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1817 SCM
*results
= lloc
, res
;
1818 while (SCM_CONSP (l
))
1820 res
= EVALCAR (l
, env
);
1822 *lloc
= scm_list_1 (res
);
1823 lloc
= SCM_CDRLOC (*lloc
);
1828 scm_wrong_num_args (proc
);
1836 /* SECTION: This code is compiled twice.
1840 /* Update the toplevel environment frame ENV so that it refers to the
1841 * current module. */
1842 #define UPDATE_TOPLEVEL_ENV(env) \
1844 SCM p = scm_current_module_lookup_closure (); \
1845 if (p != SCM_CAR(env)) \
1846 env = scm_top_level_env (p); \
1850 /* This is the evaluator. Like any real monster, it has three heads:
1852 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1853 * version. Both are implemented using a common code base, using the
1854 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1855 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1856 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1857 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1858 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1859 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1860 * are enclosed within #ifdef DEVAL ... #endif.
1862 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1863 * take two input parameters, x and env: x is a single expression to be
1864 * evalutated. env is the environment in which bindings are searched.
1866 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1867 * is a single expression, it is necessarily in a tail position. If x is just
1868 * a call to another function like in the expression (foo exp1 exp2 ...), the
1869 * realization of that call therefore _must_not_ increase stack usage (the
1870 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1871 * making extensive use of 'goto' statements within the evaluator: The gotos
1872 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1873 * that SCM_CEVAL was already using. If, however, x represents some form that
1874 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1875 * then recursive calls to SCM_CEVAL are performed for all but the last
1876 * expression of that sequence. */
1880 scm_ceval (SCM x
, SCM env
)
1886 scm_deval (SCM x
, SCM env
)
1891 SCM_CEVAL (SCM x
, SCM env
)
1898 SCM proc
, arg2
, orig_sym
;
1900 scm_t_debug_frame debug
;
1901 scm_t_debug_info
*debug_info_end
;
1902 debug
.prev
= scm_last_debug_frame
;
1905 * The debug.vect contains twice as much scm_t_debug_info frames as the
1906 * user has specified with (debug-set! frames <n>).
1908 * Even frames are eval frames, odd frames are apply frames.
1910 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1911 * sizeof (scm_t_debug_info
));
1912 debug
.info
= debug
.vect
;
1913 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1914 scm_last_debug_frame
= &debug
;
1916 #ifdef EVAL_STACK_CHECKING
1917 if (scm_stack_checking_enabled_p
1918 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1921 debug
.info
->e
.exp
= x
;
1922 debug
.info
->e
.env
= env
;
1924 scm_report_stack_overflow ();
1933 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1936 SCM_CLEAR_ARGSREADY (debug
);
1937 if (SCM_OVERFLOWP (debug
))
1940 * In theory, this should be the only place where it is necessary to
1941 * check for space in debug.vect since both eval frames and
1942 * available space are even.
1944 * For this to be the case, however, it is necessary that primitive
1945 * special forms which jump back to `loop', `begin' or some similar
1946 * label call PREP_APPLY. A convenient way to do this is to jump to
1947 * `loopnoap' or `cdrxnoap'.
1949 else if (++debug
.info
>= debug_info_end
)
1951 SCM_SET_OVERFLOW (debug
);
1956 debug
.info
->e
.exp
= x
;
1957 debug
.info
->e
.env
= env
;
1958 if (CHECK_ENTRY
&& SCM_TRAPS_P
)
1959 if (SCM_ENTER_FRAME_P
|| (SCM_BREAKPOINTS_P
&& SRCBRKP (x
)))
1961 SCM tail
= SCM_BOOL(SCM_TAILRECP (debug
));
1962 SCM_SET_TAILREC (debug
);
1963 if (SCM_CHEAPTRAPS_P
)
1964 t
.arg1
= scm_make_debugobj (&debug
);
1968 SCM val
= scm_make_continuation (&first
);
1978 /* This gives the possibility for the debugger to
1979 modify the source expression before evaluation. */
1984 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1985 scm_sym_enter_frame
,
1988 scm_unmemocopy (x
, env
));
1992 #if defined (USE_THREADS) || defined (DEVAL)
1996 switch (SCM_TYP7 (x
))
1998 case scm_tc7_symbol
:
1999 /* Only happens when called at top level. */
2000 x
= scm_cons (x
, SCM_UNDEFINED
);
2001 RETURN (*scm_lookupcar (x
, env
, 1));
2003 case SCM_BIT8 (SCM_IM_AND
):
2005 while (!SCM_NULLP (SCM_CDR (x
)))
2007 SCM test_result
= EVALCAR (x
, env
);
2008 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2009 RETURN (SCM_BOOL_F
);
2013 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2016 case SCM_BIT8 (SCM_IM_BEGIN
):
2017 if (SCM_NULLP (SCM_CDR (x
)))
2018 RETURN (SCM_UNSPECIFIED
);
2020 /* (currently unused)
2022 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2023 /* (currently unused)
2028 /* If we are on toplevel with a lookup closure, we need to sync
2029 with the current module. */
2030 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2032 UPDATE_TOPLEVEL_ENV (env
);
2033 while (!SCM_NULLP (SCM_CDR (x
)))
2036 UPDATE_TOPLEVEL_ENV (env
);
2042 goto nontoplevel_begin
;
2044 nontoplevel_cdrxnoap
:
2045 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
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
))
2358 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2360 proc
= EVALCAR (proc
, env
);
2361 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2362 if (SCM_CLOSUREP (proc
))
2364 PREP_APPLY (proc
, SCM_EOL
);
2365 t
.arg1
= SCM_CDDR (x
);
2366 t
.arg1
= EVALCAR (t
.arg1
, env
);
2368 /* Go here to tail-call a closure. PROC is the closure
2369 and T.ARG1 is the list of arguments. Do not forget to
2372 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2374 debug
.info
->a
.args
= t
.arg1
;
2376 #ifndef SCM_RECKLESS
2377 if (scm_badargsp (formals
, t
.arg1
))
2381 /* Copy argument list */
2382 if (SCM_NULL_OR_NIL_P (t
.arg1
))
2383 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2386 SCM args
= scm_list_1 (SCM_CAR (t
.arg1
));
2388 t
.arg1
= SCM_CDR (t
.arg1
);
2389 while (!SCM_NULL_OR_NIL_P (t
.arg1
))
2391 SCM new_tail
= scm_list_1 (SCM_CAR (t
.arg1
));
2392 SCM_SETCDR (tail
, new_tail
);
2394 t
.arg1
= SCM_CDR (t
.arg1
);
2396 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2399 x
= SCM_CLOSURE_BODY (proc
);
2400 goto nontoplevel_begin
;
2410 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2413 SCM val
= scm_make_continuation (&first
);
2421 proc
= scm_eval_car (proc
, env
);
2422 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2423 PREP_APPLY (proc
, scm_list_1 (t
.arg1
));
2425 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2426 goto umwrongnumargs
;
2429 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2430 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2432 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2434 /* If not done yet, evaluate the operand forms. The result is a
2435 * list of arguments stored in t.arg1, which is used to perform the
2436 * function dispatch. */
2437 SCM operand_forms
= SCM_CADR (x
);
2438 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2439 if (SCM_ILOCP (operand_forms
))
2440 t
.arg1
= *scm_ilookup (operand_forms
, env
);
2441 else if (SCM_VARIABLEP (operand_forms
))
2442 t
.arg1
= SCM_VARIABLE_REF (operand_forms
);
2443 else if (!SCM_CONSP (operand_forms
))
2444 t
.arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2447 SCM tail
= t
.arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2448 operand_forms
= SCM_CDR (operand_forms
);
2449 while (!SCM_NULLP (operand_forms
))
2451 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2452 SCM_SETCDR (tail
, new_tail
);
2454 operand_forms
= SCM_CDR (operand_forms
);
2459 /* The type dispatch code is duplicated below
2460 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2461 * cuts down execution time for type dispatch to 50%. */
2462 type_dispatch
: /* inputs: x, t.arg1 */
2463 /* Type dispatch means to determine from the types of the function
2464 * arguments (i. e. the 'signature' of the call), which method from
2465 * a generic function is to be called. This process of selecting
2466 * the right method takes some time. To speed it up, guile uses
2467 * caching: Together with the macro call to dispatch the signatures
2468 * of some previous calls to that generic function from the same
2469 * place are stored (in the code!) in a cache that we call the
2470 * 'method cache'. This is done since it is likely, that
2471 * consecutive calls to dispatch from that position in the code will
2472 * have the same signature. Thus, the type dispatch works as
2473 * follows: First, determine a hash value from the signature of the
2474 * actual arguments. Second, use this hash value as an index to
2475 * find that same signature in the method cache stored at this
2476 * position in the code. If found, you have also found the
2477 * corresponding method that belongs to that signature. If the
2478 * signature is not found in the method cache, you have to perform a
2479 * full search over all signatures stored with the generic
2482 unsigned long int specializers
;
2483 unsigned long int hash_value
;
2484 unsigned long int cache_end_pos
;
2485 unsigned long int mask
;
2489 SCM z
= SCM_CDDR (x
);
2490 SCM tmp
= SCM_CADR (z
);
2491 specializers
= SCM_INUM (SCM_CAR (z
));
2493 /* Compute a hash value for searching the method cache. There
2494 * are two variants for computing the hash value, a (rather)
2495 * complicated one, and a simple one. For the complicated one
2496 * explained below, tmp holds a number that is used in the
2498 if (SCM_INUMP (tmp
))
2500 /* Use the signature of the actual arguments to determine
2501 * the hash value. This is done as follows: Each class has
2502 * an array of random numbers, that are determined when the
2503 * class is created. The integer 'hashset' is an index into
2504 * that array of random numbers. Now, from all classes that
2505 * are part of the signature of the actual arguments, the
2506 * random numbers at index 'hashset' are taken and summed
2507 * up, giving the hash value. The value of 'hashset' is
2508 * stored at the call to dispatch. This allows to have
2509 * different 'formulas' for calculating the hash value at
2510 * different places where dispatch is called. This allows
2511 * to optimize the hash formula at every individual place
2512 * where dispatch is called, such that hopefully the hash
2513 * value that is computed will directly point to the right
2514 * method in the method cache. */
2515 unsigned long int hashset
= SCM_INUM (tmp
);
2516 unsigned long int counter
= specializers
+ 1;
2517 SCM tmp_arg
= t
.arg1
;
2519 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2521 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2522 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2523 tmp_arg
= SCM_CDR (tmp_arg
);
2527 method_cache
= SCM_CADR (z
);
2528 mask
= SCM_INUM (SCM_CAR (z
));
2530 cache_end_pos
= hash_value
;
2534 /* This method of determining the hash value is much
2535 * simpler: Set the hash value to zero and just perform a
2536 * linear search through the method cache. */
2538 mask
= (unsigned long int) ((long) -1);
2540 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2545 /* Search the method cache for a method with a matching
2546 * signature. Start the search at position 'hash_value'. The
2547 * hashing implementation uses linear probing for conflict
2548 * resolution, that is, if the signature in question is not
2549 * found at the starting index in the hash table, the next table
2550 * entry is tried, and so on, until in the worst case the whole
2551 * cache has been searched, but still the signature has not been
2556 SCM args
= t
.arg1
; /* list of arguments */
2557 z
= SCM_VELTS (method_cache
)[hash_value
];
2558 while (!SCM_NULLP (args
))
2560 /* More arguments than specifiers => CLASS != ENV */
2561 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2562 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2564 args
= SCM_CDR (args
);
2567 /* Fewer arguments than specifiers => CAR != ENV */
2568 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2571 hash_value
= (hash_value
+ 1) & mask
;
2572 } while (hash_value
!= cache_end_pos
);
2574 /* No appropriate method was found in the cache. */
2575 z
= scm_memoize_method (x
, t
.arg1
);
2577 apply_cmethod
: /* inputs: z, t.arg1 */
2579 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2580 env
= EXTEND_ENV (formals
, t
.arg1
, SCM_CMETHOD_ENV (z
));
2581 x
= SCM_CMETHOD_BODY (z
);
2582 goto nontoplevel_begin
;
2588 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2591 SCM instance
= EVALCAR (x
, env
);
2592 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2593 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2597 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2600 SCM instance
= EVALCAR (x
, env
);
2601 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2602 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2603 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2604 RETURN (SCM_UNSPECIFIED
);
2608 #ifdef SCM_ENABLE_ELISP
2610 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2612 SCM test_form
= SCM_CDR (x
);
2613 x
= SCM_CDR (test_form
);
2614 while (!SCM_NULL_OR_NIL_P (x
))
2616 SCM test_result
= EVALCAR (test_form
, env
);
2617 if (!(SCM_FALSEP (test_result
)
2618 || SCM_NULL_OR_NIL_P (test_result
)))
2620 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2621 RETURN (test_result
);
2622 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2627 test_form
= SCM_CDR (x
);
2628 x
= SCM_CDR (test_form
);
2632 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2636 #endif /* SCM_ENABLE_ELISP */
2638 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2640 SCM vars
, exps
, vals
;
2643 vars
= SCM_CAAR (x
);
2644 exps
= SCM_CDAR (x
);
2648 while (SCM_NIMP (exps
))
2650 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2651 exps
= SCM_CDR (exps
);
2654 scm_swap_bindings (vars
, vals
);
2655 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2657 /* Ignore all but the last evaluation result. */
2658 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2660 if (SCM_CONSP (SCM_CAR (x
)))
2661 SCM_CEVAL (SCM_CAR (x
), env
);
2663 proc
= EVALCAR (x
, env
);
2665 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2666 scm_swap_bindings (vars
, vals
);
2672 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2675 x
= EVALCAR (proc
, env
);
2676 proc
= SCM_CDR (proc
);
2677 proc
= EVALCAR (proc
, env
);
2678 t
.arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2679 if (SCM_VALUESP (t
.arg1
))
2680 t
.arg1
= scm_struct_ref (t
.arg1
, SCM_INUM0
);
2682 t
.arg1
= scm_list_1 (t
.arg1
);
2683 if (SCM_CLOSUREP (proc
))
2685 PREP_APPLY (proc
, t
.arg1
);
2688 return SCM_APPLY (proc
, t
.arg1
, SCM_EOL
);
2699 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2700 case scm_tc7_vector
:
2704 case scm_tc7_byvect
:
2711 #ifdef HAVE_LONG_LONGS
2712 case scm_tc7_llvect
:
2715 case scm_tc7_string
:
2717 case scm_tcs_closures
:
2721 case scm_tcs_struct
:
2724 case scm_tc7_variable
:
2725 RETURN (SCM_VARIABLE_REF(x
));
2727 #ifdef MEMOIZE_LOCALS
2728 case SCM_BIT8(SCM_ILOC00
):
2729 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2730 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2731 #ifndef SCM_RECKLESS
2737 #endif /* ifdef MEMOIZE_LOCALS */
2739 case scm_tcs_cons_nimcar
:
2740 orig_sym
= SCM_CAR (x
);
2741 if (SCM_SYMBOLP (orig_sym
))
2745 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2746 if (location
== NULL
)
2748 /* we have lost the race, start again. */
2754 proc
= *scm_lookupcar (x
, env
, 1);
2759 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2763 if (SCM_MACROP (proc
))
2765 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2769 /* Set a flag during macro expansion so that macro
2770 application frames can be deleted from the backtrace. */
2771 SCM_SET_MACROEXP (debug
);
2773 t
.arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2774 scm_cons (env
, scm_listofnull
));
2777 SCM_CLEAR_MACROEXP (debug
);
2779 switch (SCM_MACRO_TYPE (proc
))
2782 if (scm_ilength (t
.arg1
) <= 0)
2783 t
.arg1
= scm_list_2 (SCM_IM_BEGIN
, t
.arg1
);
2785 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2788 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2789 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2793 /* Prevent memoizing of debug info expression. */
2794 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2799 SCM_SETCAR (x
, SCM_CAR (t
.arg1
));
2800 SCM_SETCDR (x
, SCM_CDR (t
.arg1
));
2804 if (SCM_NIMP (x
= t
.arg1
))
2812 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2813 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2814 #ifndef SCM_RECKLESS
2818 if (SCM_CLOSUREP (proc
))
2820 arg2
= SCM_CLOSURE_FORMALS (proc
);
2821 t
.arg1
= SCM_CDR (x
);
2822 while (!SCM_NULLP (arg2
))
2824 if (!SCM_CONSP (arg2
))
2826 if (SCM_IMP (t
.arg1
))
2827 goto umwrongnumargs
;
2828 arg2
= SCM_CDR (arg2
);
2829 t
.arg1
= SCM_CDR (t
.arg1
);
2831 if (!SCM_NULLP (t
.arg1
))
2832 goto umwrongnumargs
;
2834 else if (SCM_MACROP (proc
))
2835 goto handle_a_macro
;
2841 PREP_APPLY (proc
, SCM_EOL
);
2842 if (SCM_NULLP (SCM_CDR (x
))) {
2845 switch (SCM_TYP7 (proc
))
2846 { /* no arguments given */
2847 case scm_tc7_subr_0
:
2848 RETURN (SCM_SUBRF (proc
) ());
2849 case scm_tc7_subr_1o
:
2850 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2852 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2853 case scm_tc7_rpsubr
:
2854 RETURN (SCM_BOOL_T
);
2856 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2858 if (!SCM_SMOB_APPLICABLE_P (proc
))
2860 RETURN (SCM_SMOB_APPLY_0 (proc
));
2863 proc
= SCM_CCLO_SUBR (proc
);
2865 debug
.info
->a
.proc
= proc
;
2866 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2870 proc
= SCM_PROCEDURE (proc
);
2872 debug
.info
->a
.proc
= proc
;
2874 if (!SCM_CLOSUREP (proc
))
2876 if (scm_badformalsp (proc
, 0))
2877 goto umwrongnumargs
;
2878 case scm_tcs_closures
:
2879 x
= SCM_CLOSURE_BODY (proc
);
2880 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2881 goto nontoplevel_begin
;
2882 case scm_tcs_struct
:
2883 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2885 x
= SCM_ENTITY_PROCEDURE (proc
);
2889 else if (!SCM_I_OPERATORP (proc
))
2894 proc
= (SCM_I_ENTITYP (proc
)
2895 ? SCM_ENTITY_PROCEDURE (proc
)
2896 : SCM_OPERATOR_PROCEDURE (proc
));
2898 debug
.info
->a
.proc
= proc
;
2899 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2901 if (SCM_NIMP (proc
))
2906 case scm_tc7_subr_1
:
2907 case scm_tc7_subr_2
:
2908 case scm_tc7_subr_2o
:
2910 case scm_tc7_subr_3
:
2911 case scm_tc7_lsubr_2
:
2915 scm_wrong_num_args (proc
);
2917 /* handle macros here */
2922 /* must handle macros by here */
2927 else if (SCM_CONSP (x
))
2929 if (SCM_IMP (SCM_CAR (x
)))
2930 t
.arg1
= SCM_EVALIM (SCM_CAR (x
), env
);
2932 t
.arg1
= EVALCELLCAR (x
, env
);
2937 t
.arg1
= EVALCAR (x
, env
);
2940 debug
.info
->a
.args
= scm_list_1 (t
.arg1
);
2947 switch (SCM_TYP7 (proc
))
2948 { /* have one argument in t.arg1 */
2949 case scm_tc7_subr_2o
:
2950 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2951 case scm_tc7_subr_1
:
2952 case scm_tc7_subr_1o
:
2953 RETURN (SCM_SUBRF (proc
) (t
.arg1
));
2955 if (SCM_SUBRF (proc
))
2957 if (SCM_INUMP (t
.arg1
))
2959 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (t
.arg1
))));
2961 else if (SCM_REALP (t
.arg1
))
2963 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (t
.arg1
))));
2966 else if (SCM_BIGP (t
.arg1
))
2968 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (t
.arg1
))));
2971 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), t
.arg1
,
2972 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2974 proc
= SCM_SNAME (proc
);
2976 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2977 while ('c' != *--chrs
)
2979 SCM_ASSERT (SCM_CONSP (t
.arg1
),
2980 t
.arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2981 t
.arg1
= ('a' == *chrs
) ? SCM_CAR (t
.arg1
) : SCM_CDR (t
.arg1
);
2985 case scm_tc7_rpsubr
:
2986 RETURN (SCM_BOOL_T
);
2988 RETURN (SCM_SUBRF (proc
) (t
.arg1
, SCM_UNDEFINED
));
2991 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2993 RETURN (SCM_SUBRF (proc
) (scm_list_1 (t
.arg1
)));
2996 if (!SCM_SMOB_APPLICABLE_P (proc
))
2998 RETURN (SCM_SMOB_APPLY_1 (proc
, t
.arg1
));
3002 proc
= SCM_CCLO_SUBR (proc
);
3004 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
3005 debug
.info
->a
.proc
= proc
;
3009 proc
= SCM_PROCEDURE (proc
);
3011 debug
.info
->a
.proc
= proc
;
3013 if (!SCM_CLOSUREP (proc
))
3015 if (scm_badformalsp (proc
, 1))
3016 goto umwrongnumargs
;
3017 case scm_tcs_closures
:
3019 x
= SCM_CLOSURE_BODY (proc
);
3021 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
3023 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (t
.arg1
), SCM_ENV (proc
));
3025 goto nontoplevel_begin
;
3026 case scm_tcs_struct
:
3027 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3029 x
= SCM_ENTITY_PROCEDURE (proc
);
3031 t
.arg1
= debug
.info
->a
.args
;
3033 t
.arg1
= scm_list_1 (t
.arg1
);
3037 else if (!SCM_I_OPERATORP (proc
))
3043 proc
= (SCM_I_ENTITYP (proc
)
3044 ? SCM_ENTITY_PROCEDURE (proc
)
3045 : SCM_OPERATOR_PROCEDURE (proc
));
3047 debug
.info
->a
.args
= scm_cons (t
.arg1
, debug
.info
->a
.args
);
3048 debug
.info
->a
.proc
= proc
;
3050 if (SCM_NIMP (proc
))
3055 case scm_tc7_subr_2
:
3056 case scm_tc7_subr_0
:
3057 case scm_tc7_subr_3
:
3058 case scm_tc7_lsubr_2
:
3067 else if (SCM_CONSP (x
))
3069 if (SCM_IMP (SCM_CAR (x
)))
3070 arg2
= SCM_EVALIM (SCM_CAR (x
), env
);
3072 arg2
= EVALCELLCAR (x
, env
);
3077 arg2
= EVALCAR (x
, env
);
3079 { /* have two or more arguments */
3081 debug
.info
->a
.args
= scm_list_2 (t
.arg1
, arg2
);
3084 if (SCM_NULLP (x
)) {
3087 switch (SCM_TYP7 (proc
))
3088 { /* have two arguments */
3089 case scm_tc7_subr_2
:
3090 case scm_tc7_subr_2o
:
3091 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
3094 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3096 RETURN (SCM_SUBRF (proc
) (scm_list_2 (t
.arg1
, arg2
)));
3098 case scm_tc7_lsubr_2
:
3099 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, SCM_EOL
));
3100 case scm_tc7_rpsubr
:
3102 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
));
3104 if (!SCM_SMOB_APPLICABLE_P (proc
))
3106 RETURN (SCM_SMOB_APPLY_2 (proc
, t
.arg1
, arg2
));
3110 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3111 scm_cons (proc
, debug
.info
->a
.args
),
3114 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3115 scm_cons2 (proc
, t
.arg1
,
3122 case scm_tcs_struct
:
3123 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3125 x
= SCM_ENTITY_PROCEDURE (proc
);
3127 t
.arg1
= debug
.info
->a
.args
;
3129 t
.arg1
= scm_list_2 (t
.arg1
, arg2
);
3133 else if (!SCM_I_OPERATORP (proc
))
3139 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3140 ? SCM_ENTITY_PROCEDURE (proc
)
3141 : SCM_OPERATOR_PROCEDURE (proc
),
3142 scm_cons (proc
, debug
.info
->a
.args
),
3145 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3146 ? SCM_ENTITY_PROCEDURE (proc
)
3147 : SCM_OPERATOR_PROCEDURE (proc
),
3148 scm_cons2 (proc
, t
.arg1
,
3156 case scm_tc7_subr_0
:
3158 case scm_tc7_subr_1o
:
3159 case scm_tc7_subr_1
:
3160 case scm_tc7_subr_3
:
3165 proc
= SCM_PROCEDURE (proc
);
3167 debug
.info
->a
.proc
= proc
;
3169 if (!SCM_CLOSUREP (proc
))
3171 if (scm_badformalsp (proc
, 2))
3172 goto umwrongnumargs
;
3173 case scm_tcs_closures
:
3176 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3180 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3181 scm_list_2 (t
.arg1
, arg2
), SCM_ENV (proc
));
3183 x
= SCM_CLOSURE_BODY (proc
);
3184 goto nontoplevel_begin
;
3188 if (SCM_IMP (x
) || !SCM_CONSP (x
))
3192 debug
.info
->a
.args
= scm_cons2 (t
.arg1
, arg2
,
3193 deval_args (x
, env
, proc
, SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3197 switch (SCM_TYP7 (proc
))
3198 { /* have 3 or more arguments */
3200 case scm_tc7_subr_3
:
3201 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3202 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3203 SCM_CADDR (debug
.info
->a
.args
)));
3205 #ifdef BUILTIN_RPASUBR
3206 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, arg2
);
3207 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3210 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, SCM_CAR (arg2
));
3211 arg2
= SCM_CDR (arg2
);
3213 while (SCM_NIMP (arg2
));
3215 #endif /* BUILTIN_RPASUBR */
3216 case scm_tc7_rpsubr
:
3217 #ifdef BUILTIN_RPASUBR
3218 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3219 RETURN (SCM_BOOL_F
);
3220 t
.arg1
= SCM_CDDR (debug
.info
->a
.args
);
3223 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (t
.arg1
))))
3224 RETURN (SCM_BOOL_F
);
3225 arg2
= SCM_CAR (t
.arg1
);
3226 t
.arg1
= SCM_CDR (t
.arg1
);
3228 while (SCM_NIMP (t
.arg1
));
3229 RETURN (SCM_BOOL_T
);
3230 #else /* BUILTIN_RPASUBR */
3231 RETURN (SCM_APPLY (proc
, t
.arg1
,
3233 SCM_CDDR (debug
.info
->a
.args
),
3235 #endif /* BUILTIN_RPASUBR */
3236 case scm_tc7_lsubr_2
:
3237 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
,
3238 SCM_CDDR (debug
.info
->a
.args
)));
3240 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3242 if (!SCM_SMOB_APPLICABLE_P (proc
))
3244 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3245 SCM_CDDR (debug
.info
->a
.args
)));
3249 proc
= SCM_PROCEDURE (proc
);
3250 debug
.info
->a
.proc
= proc
;
3251 if (!SCM_CLOSUREP (proc
))
3253 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3254 goto umwrongnumargs
;
3255 case scm_tcs_closures
:
3256 SCM_SET_ARGSREADY (debug
);
3257 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3260 x
= SCM_CLOSURE_BODY (proc
);
3261 goto nontoplevel_begin
;
3263 case scm_tc7_subr_3
:
3264 SCM_ASRTGO (SCM_NULLP (SCM_CDR (x
)), wrongnumargs
);
3265 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, EVALCAR (x
, env
)));
3267 #ifdef BUILTIN_RPASUBR
3268 t
.arg1
= SCM_SUBRF (proc
) (t
.arg1
, arg2
);
3271 t
.arg1
= SCM_SUBRF(proc
)(t
.arg1
, EVALCAR(x
, env
));
3274 while (SCM_NIMP (x
));
3276 #endif /* BUILTIN_RPASUBR */
3277 case scm_tc7_rpsubr
:
3278 #ifdef BUILTIN_RPASUBR
3279 if (SCM_FALSEP (SCM_SUBRF (proc
) (t
.arg1
, arg2
)))
3280 RETURN (SCM_BOOL_F
);
3283 t
.arg1
= EVALCAR (x
, env
);
3284 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, t
.arg1
)))
3285 RETURN (SCM_BOOL_F
);
3289 while (SCM_NIMP (x
));
3290 RETURN (SCM_BOOL_T
);
3291 #else /* BUILTIN_RPASUBR */
3292 RETURN (SCM_APPLY (proc
, t
.arg1
,
3294 scm_eval_args (x
, env
, proc
),
3296 #endif /* BUILTIN_RPASUBR */
3297 case scm_tc7_lsubr_2
:
3298 RETURN (SCM_SUBRF (proc
) (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3300 RETURN (SCM_SUBRF (proc
) (scm_cons2 (t
.arg1
,
3302 scm_eval_args (x
, env
, proc
))));
3304 if (!SCM_SMOB_APPLICABLE_P (proc
))
3306 RETURN (SCM_SMOB_APPLY_3 (proc
, t
.arg1
, arg2
,
3307 scm_eval_args (x
, env
, proc
)));
3311 proc
= SCM_PROCEDURE (proc
);
3312 if (!SCM_CLOSUREP (proc
))
3315 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3316 if (SCM_NULLP (formals
)
3317 || (SCM_CONSP (formals
)
3318 && (SCM_NULLP (SCM_CDR (formals
))
3319 || (SCM_CONSP (SCM_CDR (formals
))
3320 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3321 goto umwrongnumargs
;
3323 case scm_tcs_closures
:
3325 SCM_SET_ARGSREADY (debug
);
3327 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3330 scm_eval_args (x
, env
, proc
)),
3332 x
= SCM_CLOSURE_BODY (proc
);
3333 goto nontoplevel_begin
;
3335 case scm_tcs_struct
:
3336 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3339 t
.arg1
= debug
.info
->a
.args
;
3341 t
.arg1
= scm_cons2 (t
.arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3343 x
= SCM_ENTITY_PROCEDURE (proc
);
3346 else if (!SCM_I_OPERATORP (proc
))
3350 case scm_tc7_subr_2
:
3351 case scm_tc7_subr_1o
:
3352 case scm_tc7_subr_2o
:
3353 case scm_tc7_subr_0
:
3355 case scm_tc7_subr_1
:
3363 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3364 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3366 SCM_CLEAR_TRACED_FRAME (debug
);
3367 if (SCM_CHEAPTRAPS_P
)
3368 t
.arg1
= scm_make_debugobj (&debug
);
3372 SCM val
= scm_make_continuation (&first
);
3383 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, t
.arg1
, proc
);
3387 scm_last_debug_frame
= debug
.prev
;
3393 /* SECTION: This code is compiled once.
3399 /* Simple procedure calls
3403 scm_call_0 (SCM proc
)
3405 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3409 scm_call_1 (SCM proc
, SCM arg1
)
3411 return scm_apply (proc
, arg1
, scm_listofnull
);
3415 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3417 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3421 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3423 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3427 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3429 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3430 scm_cons (arg4
, scm_listofnull
)));
3433 /* Simple procedure applies
3437 scm_apply_0 (SCM proc
, SCM args
)
3439 return scm_apply (proc
, args
, SCM_EOL
);
3443 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3445 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3449 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3451 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3455 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3457 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3461 /* This code processes the arguments to apply:
3463 (apply PROC ARG1 ... ARGS)
3465 Given a list (ARG1 ... ARGS), this function conses the ARG1
3466 ... arguments onto the front of ARGS, and returns the resulting
3467 list. Note that ARGS is a list; thus, the argument to this
3468 function is a list whose last element is a list.
3470 Apply calls this function, and applies PROC to the elements of the
3471 result. apply:nconc2last takes care of building the list of
3472 arguments, given (ARG1 ... ARGS).
3474 Rather than do new consing, apply:nconc2last destroys its argument.
3475 On that topic, this code came into my care with the following
3476 beautifully cryptic comment on that topic: "This will only screw
3477 you if you do (scm_apply scm_apply '( ... ))" If you know what
3478 they're referring to, send me a patch to this comment. */
3480 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3482 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3483 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3484 "@var{args}, and returns the resulting list. Note that\n"
3485 "@var{args} is a list; thus, the argument to this function is\n"
3486 "a list whose last element is a list.\n"
3487 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3488 "destroys its argument, so use with care.")
3489 #define FUNC_NAME s_scm_nconc2last
3492 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3494 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3495 SCM_NULL_OR_NIL_P, but not
3496 needed in 99.99% of cases,
3497 and it could seriously hurt
3498 performance. - Neil */
3499 lloc
= SCM_CDRLOC (*lloc
);
3500 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3501 *lloc
= SCM_CAR (*lloc
);
3509 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3510 * It is compiled twice.
3515 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3521 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3526 /* Apply a function to a list of arguments.
3528 This function is exported to the Scheme level as taking two
3529 required arguments and a tail argument, as if it were:
3530 (lambda (proc arg1 . args) ...)
3531 Thus, if you just have a list of arguments to pass to a procedure,
3532 pass the list as ARG1, and '() for ARGS. If you have some fixed
3533 args, pass the first as ARG1, then cons any remaining fixed args
3534 onto the front of your argument list, and pass that as ARGS. */
3537 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3539 #ifdef DEBUG_EXTENSIONS
3541 scm_t_debug_frame debug
;
3542 scm_t_debug_info debug_vect_body
;
3543 debug
.prev
= scm_last_debug_frame
;
3544 debug
.status
= SCM_APPLYFRAME
;
3545 debug
.vect
= &debug_vect_body
;
3546 debug
.vect
[0].a
.proc
= proc
;
3547 debug
.vect
[0].a
.args
= SCM_EOL
;
3548 scm_last_debug_frame
= &debug
;
3551 return scm_dapply (proc
, arg1
, args
);
3555 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3557 /* If ARGS is the empty list, then we're calling apply with only two
3558 arguments --- ARG1 is the list of arguments for PROC. Whatever
3559 the case, futz with things so that ARG1 is the first argument to
3560 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3563 Setting the debug apply frame args this way is pretty messy.
3564 Perhaps we should store arg1 and args directly in the frame as
3565 received, and let scm_frame_arguments unpack them, because that's
3566 a relatively rare operation. This works for now; if the Guile
3567 developer archives are still around, see Mikael's post of
3569 if (SCM_NULLP (args
))
3571 if (SCM_NULLP (arg1
))
3573 arg1
= SCM_UNDEFINED
;
3575 debug
.vect
[0].a
.args
= SCM_EOL
;
3581 debug
.vect
[0].a
.args
= arg1
;
3583 args
= SCM_CDR (arg1
);
3584 arg1
= SCM_CAR (arg1
);
3589 args
= scm_nconc2last (args
);
3591 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3595 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3598 if (SCM_CHEAPTRAPS_P
)
3599 tmp
= scm_make_debugobj (&debug
);
3604 tmp
= scm_make_continuation (&first
);
3609 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3616 switch (SCM_TYP7 (proc
))
3618 case scm_tc7_subr_2o
:
3619 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3620 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3621 case scm_tc7_subr_2
:
3622 SCM_ASRTGO (!SCM_NULLP (args
) && SCM_NULLP (SCM_CDR (args
)),
3624 args
= SCM_CAR (args
);
3625 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3626 case scm_tc7_subr_0
:
3627 SCM_ASRTGO (SCM_UNBNDP (arg1
), wrongnumargs
);
3628 RETURN (SCM_SUBRF (proc
) ());
3629 case scm_tc7_subr_1
:
3630 SCM_ASRTGO (!SCM_UNBNDP (arg1
), wrongnumargs
);
3631 case scm_tc7_subr_1o
:
3632 SCM_ASRTGO (SCM_NULLP (args
), wrongnumargs
);
3633 RETURN (SCM_SUBRF (proc
) (arg1
));
3635 SCM_ASRTGO (!SCM_UNBNDP (arg1
) && SCM_NULLP (args
), wrongnumargs
);
3636 if (SCM_SUBRF (proc
))
3638 if (SCM_INUMP (arg1
))
3640 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3642 else if (SCM_REALP (arg1
))
3644 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3647 else if (SCM_BIGP (arg1
))
3648 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3650 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3651 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3653 proc
= SCM_SNAME (proc
);
3655 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3656 while ('c' != *--chrs
)
3658 SCM_ASSERT (SCM_CONSP (arg1
),
3659 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3660 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3664 case scm_tc7_subr_3
:
3665 SCM_ASRTGO (!SCM_NULLP (args
)
3666 && !SCM_NULLP (SCM_CDR (args
))
3667 && SCM_NULLP (SCM_CDDR (args
)),
3669 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3672 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3674 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3676 case scm_tc7_lsubr_2
:
3677 SCM_ASRTGO (SCM_CONSP (args
), wrongnumargs
);
3678 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3680 if (SCM_NULLP (args
))
3681 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3682 while (SCM_NIMP (args
))
3684 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3685 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3686 args
= SCM_CDR (args
);
3689 case scm_tc7_rpsubr
:
3690 if (SCM_NULLP (args
))
3691 RETURN (SCM_BOOL_T
);
3692 while (SCM_NIMP (args
))
3694 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3695 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3696 RETURN (SCM_BOOL_F
);
3697 arg1
= SCM_CAR (args
);
3698 args
= SCM_CDR (args
);
3700 RETURN (SCM_BOOL_T
);
3701 case scm_tcs_closures
:
3703 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3705 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3707 #ifndef SCM_RECKLESS
3708 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3712 /* Copy argument list */
3717 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3718 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3720 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3724 SCM_SETCDR (tl
, arg1
);
3727 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3728 proc
= SCM_CLOSURE_BODY (proc
);
3731 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3733 if (SCM_IMP (SCM_CAR (proc
)))
3735 if (SCM_ISYMP (SCM_CAR (proc
)))
3737 proc
= scm_m_expand_body (proc
, args
);
3741 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3744 SCM_CEVAL (SCM_CAR (proc
), args
);
3747 RETURN (EVALCAR (proc
, args
));
3749 if (!SCM_SMOB_APPLICABLE_P (proc
))
3751 if (SCM_UNBNDP (arg1
))
3752 RETURN (SCM_SMOB_APPLY_0 (proc
));
3753 else if (SCM_NULLP (args
))
3754 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3755 else if (SCM_NULLP (SCM_CDR (args
)))
3756 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3758 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3761 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3763 proc
= SCM_CCLO_SUBR (proc
);
3764 debug
.vect
[0].a
.proc
= proc
;
3765 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3767 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3769 proc
= SCM_CCLO_SUBR (proc
);
3773 proc
= SCM_PROCEDURE (proc
);
3775 debug
.vect
[0].a
.proc
= proc
;
3778 case scm_tcs_struct
:
3779 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3782 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3784 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3786 RETURN (scm_apply_generic (proc
, args
));
3788 else if (!SCM_I_OPERATORP (proc
))
3793 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3795 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3798 proc
= (SCM_I_ENTITYP (proc
)
3799 ? SCM_ENTITY_PROCEDURE (proc
)
3800 : SCM_OPERATOR_PROCEDURE (proc
));
3802 debug
.vect
[0].a
.proc
= proc
;
3803 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3805 if (SCM_NIMP (proc
))
3811 scm_wrong_num_args (proc
);
3814 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3819 if (CHECK_EXIT
&& SCM_TRAPS_P
)
3820 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3822 SCM_CLEAR_TRACED_FRAME (debug
);
3823 if (SCM_CHEAPTRAPS_P
)
3824 arg1
= scm_make_debugobj (&debug
);
3828 SCM val
= scm_make_continuation (&first
);
3839 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3843 scm_last_debug_frame
= debug
.prev
;
3849 /* SECTION: The rest of this file is only read once.
3854 /* Typechecking for multi-argument MAP and FOR-EACH.
3856 Verify that each element of the vector ARGV, except for the first,
3857 is a proper list whose length is LEN. Attribute errors to WHO,
3858 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3860 check_map_args (SCM argv
,
3867 SCM
*ve
= SCM_VELTS (argv
);
3870 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3872 long elt_len
= scm_ilength (ve
[i
]);
3877 scm_apply_generic (gf
, scm_cons (proc
, args
));
3879 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3883 scm_out_of_range (who
, ve
[i
]);
3886 scm_remember_upto_here_1 (argv
);
3890 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3892 /* Note: Currently, scm_map applies PROC to the argument list(s)
3893 sequentially, starting with the first element(s). This is used in
3894 evalext.c where the Scheme procedure `map-in-order', which guarantees
3895 sequential behaviour, is implemented using scm_map. If the
3896 behaviour changes, we need to update `map-in-order'.
3900 scm_map (SCM proc
, SCM arg1
, SCM args
)
3901 #define FUNC_NAME s_map
3906 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3908 len
= scm_ilength (arg1
);
3909 SCM_GASSERTn (len
>= 0,
3910 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3911 SCM_VALIDATE_REST_ARGUMENT (args
);
3912 if (SCM_NULLP (args
))
3914 while (SCM_NIMP (arg1
))
3916 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3917 pres
= SCM_CDRLOC (*pres
);
3918 arg1
= SCM_CDR (arg1
);
3922 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3923 ve
= SCM_VELTS (args
);
3924 #ifndef SCM_RECKLESS
3925 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3930 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3932 if (SCM_IMP (ve
[i
]))
3934 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3935 ve
[i
] = SCM_CDR (ve
[i
]);
3937 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3938 pres
= SCM_CDRLOC (*pres
);
3944 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3947 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3948 #define FUNC_NAME s_for_each
3950 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3952 len
= scm_ilength (arg1
);
3953 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3954 SCM_ARG2
, s_for_each
);
3955 SCM_VALIDATE_REST_ARGUMENT (args
);
3956 if (SCM_NULLP (args
))
3958 while (SCM_NIMP (arg1
))
3960 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3961 arg1
= SCM_CDR (arg1
);
3963 return SCM_UNSPECIFIED
;
3965 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3966 ve
= SCM_VELTS (args
);
3967 #ifndef SCM_RECKLESS
3968 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3973 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3975 if (SCM_IMP (ve
[i
]))
3976 return SCM_UNSPECIFIED
;
3977 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3978 ve
[i
] = SCM_CDR (ve
[i
]);
3980 scm_apply (proc
, arg1
, SCM_EOL
);
3987 scm_closure (SCM code
, SCM env
)
3990 SCM closcar
= scm_cons (code
, SCM_EOL
);
3991 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3992 scm_remember_upto_here (closcar
);
3997 scm_t_bits scm_tc16_promise
;
4000 scm_makprom (SCM code
)
4002 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
4008 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
4010 int writingp
= SCM_WRITINGP (pstate
);
4011 scm_puts ("#<promise ", port
);
4012 SCM_SET_WRITINGP (pstate
, 1);
4013 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
4014 SCM_SET_WRITINGP (pstate
, writingp
);
4015 scm_putc ('>', port
);
4020 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
4022 "If the promise @var{x} has not been computed yet, compute and\n"
4023 "return @var{x}, otherwise just return the previously computed\n"
4025 #define FUNC_NAME s_scm_force
4027 SCM_VALIDATE_SMOB (1, x
, promise
);
4028 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4030 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
4031 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4034 SCM_SET_CELL_OBJECT_1 (x
, ans
);
4035 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
4039 return SCM_CELL_OBJECT_1 (x
);
4044 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4046 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4047 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4048 #define FUNC_NAME s_scm_promise_p
4050 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4055 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4056 (SCM xorig
, SCM x
, SCM y
),
4057 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4058 "Any source properties associated with @var{xorig} are also associated\n"
4059 "with the new pair.")
4060 #define FUNC_NAME s_scm_cons_source
4063 z
= scm_cons (x
, y
);
4064 /* Copy source properties possibly associated with xorig. */
4065 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4067 scm_whash_insert (scm_source_whash
, z
, p
);
4073 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4075 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4076 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4077 "contents of both pairs and vectors (since both cons cells and vector\n"
4078 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4079 "any other object.")
4080 #define FUNC_NAME s_scm_copy_tree
4085 if (SCM_VECTORP (obj
))
4087 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4088 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4090 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
4093 if (!SCM_CONSP (obj
))
4095 ans
= tl
= scm_cons_source (obj
,
4096 scm_copy_tree (SCM_CAR (obj
)),
4098 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4100 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4104 SCM_SETCDR (tl
, obj
);
4110 /* We have three levels of EVAL here:
4112 - scm_i_eval (exp, env)
4114 evaluates EXP in environment ENV. ENV is a lexical environment
4115 structure as used by the actual tree code evaluator. When ENV is
4116 a top-level environment, then changes to the current module are
4117 tracked by updating ENV so that it continues to be in sync with
4120 - scm_primitive_eval (exp)
4122 evaluates EXP in the top-level environment as determined by the
4123 current module. This is done by constructing a suitable
4124 environment and calling scm_i_eval. Thus, changes to the
4125 top-level module are tracked normally.
4127 - scm_eval (exp, mod)
4129 evaluates EXP while MOD is the current module. This is done by
4130 setting the current module to MOD, invoking scm_primitive_eval on
4131 EXP, and then restoring the current module to the value it had
4132 previously. That is, while EXP is evaluated, changes to the
4133 current module are tracked, but these changes do not persist when
4136 For each level of evals, there are two variants, distinguished by a
4137 _x suffix: the ordinary variant does not modify EXP while the _x
4138 variant can destructively modify EXP into something completely
4139 unintelligible. A Scheme data structure passed as EXP to one of the
4140 _x variants should not ever be used again for anything. So when in
4141 doubt, use the ordinary variant.
4146 scm_i_eval_x (SCM exp
, SCM env
)
4148 return SCM_XEVAL (exp
, env
);
4152 scm_i_eval (SCM exp
, SCM env
)
4154 exp
= scm_copy_tree (exp
);
4155 return SCM_XEVAL (exp
, env
);
4159 scm_primitive_eval_x (SCM exp
)
4162 SCM transformer
= scm_current_module_transformer ();
4163 if (SCM_NIMP (transformer
))
4164 exp
= scm_call_1 (transformer
, exp
);
4165 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4166 return scm_i_eval_x (exp
, env
);
4169 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4171 "Evaluate @var{exp} in the top-level environment specified by\n"
4172 "the current module.")
4173 #define FUNC_NAME s_scm_primitive_eval
4176 SCM transformer
= scm_current_module_transformer ();
4177 if (SCM_NIMP (transformer
))
4178 exp
= scm_call_1 (transformer
, exp
);
4179 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4180 return scm_i_eval (exp
, env
);
4184 /* Eval does not take the second arg optionally. This is intentional
4185 * in order to be R5RS compatible, and to prepare for the new module
4186 * system, where we would like to make the choice of evaluation
4187 * environment explicit. */
4190 change_environment (void *data
)
4192 SCM pair
= SCM_PACK (data
);
4193 SCM new_module
= SCM_CAR (pair
);
4194 SCM old_module
= scm_current_module ();
4195 SCM_SETCDR (pair
, old_module
);
4196 scm_set_current_module (new_module
);
4201 restore_environment (void *data
)
4203 SCM pair
= SCM_PACK (data
);
4204 SCM old_module
= SCM_CDR (pair
);
4205 SCM new_module
= scm_current_module ();
4206 SCM_SETCAR (pair
, new_module
);
4207 scm_set_current_module (old_module
);
4211 inner_eval_x (void *data
)
4213 return scm_primitive_eval_x (SCM_PACK(data
));
4217 scm_eval_x (SCM exp
, SCM module
)
4218 #define FUNC_NAME "eval!"
4220 SCM_VALIDATE_MODULE (2, module
);
4222 return scm_internal_dynamic_wind
4223 (change_environment
, inner_eval_x
, restore_environment
,
4224 (void *) SCM_UNPACK (exp
),
4225 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4230 inner_eval (void *data
)
4232 return scm_primitive_eval (SCM_PACK(data
));
4235 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4236 (SCM exp
, SCM module
),
4237 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4238 "in the top-level environment specified by @var{module}.\n"
4239 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4240 "@var{module} is made the current module. The current module\n"
4241 "is reset to its previous value when @var{eval} returns.")
4242 #define FUNC_NAME s_scm_eval
4244 SCM_VALIDATE_MODULE (2, module
);
4246 return scm_internal_dynamic_wind
4247 (change_environment
, inner_eval
, restore_environment
,
4248 (void *) SCM_UNPACK (exp
),
4249 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4254 /* At this point, scm_deval and scm_dapply are generated.
4257 #ifdef DEBUG_EXTENSIONS
4267 scm_init_opts (scm_evaluator_traps
,
4268 scm_evaluator_trap_table
,
4269 SCM_N_EVALUATOR_TRAPS
);
4270 scm_init_opts (scm_eval_options_interface
,
4272 SCM_N_EVAL_OPTIONS
);
4274 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4275 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4276 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4278 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4279 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4280 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4281 scm_listofnull
= scm_list_1 (SCM_EOL
);
4283 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4288 #include "libguile/eval.x"
4290 scm_add_feature ("delay");