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 * SCM_EVALIM is used when it is known that the expression is an
127 * immediate. (This macro never calls an evaluator.)
129 * EVALCAR evaluates the car of an expression.
131 * The following macros should be used in code which is read once
132 * (where the choice of evaluator is dynamic):
134 * SCM_XEVAL takes care of immediates without calling an evaluator. It
135 * then calls scm_ceval *or* scm_deval, depending on the debugging
138 * SCM_XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
139 * depending on the debugging mode.
141 * The main motivation for keeping this plethora is efficiency
142 * together with maintainability (=> locality of code).
145 #define SCM_CEVAL scm_ceval
147 #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \
148 ? SCM_EVALIM (SCM_CAR (x), env) \
149 : (SCM_SYMBOLP (SCM_CAR (x)) \
150 ? *scm_lookupcar (x, env, 1) \
151 : SCM_CEVAL (SCM_CAR (x), env)))
153 #define EXTEND_ENV SCM_EXTEND_ENV
155 #ifdef MEMOIZE_LOCALS
158 scm_ilookup (SCM iloc
, SCM env
)
160 register long ir
= SCM_IFRAME (iloc
);
161 register SCM er
= env
;
162 for (; 0 != ir
; --ir
)
165 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
167 if (SCM_ICDRP (iloc
))
168 return SCM_CDRLOC (er
);
169 return SCM_CARLOC (SCM_CDR (er
));
175 /* The Lookup Car Race
178 Memoization of variables and special forms is done while executing
179 the code for the first time. As long as there is only one thread
180 everything is fine, but as soon as two threads execute the same
181 code concurrently `for the first time' they can come into conflict.
183 This memoization includes rewriting variable references into more
184 efficient forms and expanding macros. Furthermore, macro expansion
185 includes `compiling' special forms like `let', `cond', etc. into
186 tree-code instructions.
188 There shouldn't normally be a problem with memoizing local and
189 global variable references (into ilocs and variables), because all
190 threads will mutate the code in *exactly* the same way and (if I
191 read the C code correctly) it is not possible to observe a half-way
192 mutated cons cell. The lookup procedure can handle this
193 transparently without any critical sections.
195 It is different with macro expansion, because macro expansion
196 happens outside of the lookup procedure and can't be
197 undone. Therefore the lookup procedure can't cope with it. It has
198 to indicate failure when it detects a lost race and hope that the
199 caller can handle it. Luckily, it turns out that this is the case.
201 An example to illustrate this: Suppose that the following form will
202 be memoized concurrently by two threads
206 Let's first examine the lookup of X in the body. The first thread
207 decides that it has to find the symbol "x" in the environment and
208 starts to scan it. Then the other thread takes over and actually
209 overtakes the first. It looks up "x" and substitutes an
210 appropriate iloc for it. Now the first thread continues and
211 completes its lookup. It comes to exactly the same conclusions as
212 the second one and could - without much ado - just overwrite the
213 iloc with the same iloc.
215 But let's see what will happen when the race occurs while looking
216 up the symbol "let" at the start of the form. It could happen that
217 the second thread interrupts the lookup of the first thread and not
218 only substitutes a variable for it but goes right ahead and
219 replaces it with the compiled form (#@let* (x 12) x). Now, when
220 the first thread completes its lookup, it would replace the #@let*
221 with a variable containing the "let" binding, effectively reverting
222 the form to (let (x 12) x). This is wrong. It has to detect that
223 it has lost the race and the evaluator has to reconsider the
224 changed form completely.
226 This race condition could be resolved with some kind of traffic
227 light (like mutexes) around scm_lookupcar, but I think that it is
228 best to avoid them in this case. They would serialize memoization
229 completely and because lookup involves calling arbitrary Scheme
230 code (via the lookup-thunk), threads could be blocked for an
231 arbitrary amount of time or even deadlock. But with the current
232 solution a lot of unnecessary work is potentially done. */
234 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
235 return NULL to indicate a failed lookup due to some race conditions
236 between threads. This only happens when VLOC is the first cell of
237 a special form that will eventually be memoized (like `let', etc.)
238 In that case the whole lookup is bogus and the caller has to
239 reconsider the complete special form.
241 SCM_LOOKUPCAR is still there, of course. It just calls
242 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
243 should only be called when it is known that VLOC is not the first
244 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
245 for NULL. I think I've found the only places where this
248 #endif /* USE_THREADS */
250 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
254 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
257 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
261 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
262 #ifdef MEMOIZE_LOCALS
263 register SCM iloc
= SCM_ILOC00
;
265 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
267 if (!SCM_CONSP (SCM_CAR (env
)))
269 al
= SCM_CARLOC (env
);
270 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
274 if (SCM_EQ_P (fl
, var
))
276 #ifdef MEMOIZE_LOCALS
278 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
281 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
283 return SCM_CDRLOC (*al
);
288 al
= SCM_CDRLOC (*al
);
289 if (SCM_EQ_P (SCM_CAR (fl
), var
))
291 #ifdef MEMOIZE_LOCALS
292 #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
293 if (SCM_UNBNDP (SCM_CAR (*al
)))
300 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
303 SCM_SETCAR (vloc
, iloc
);
305 return SCM_CARLOC (*al
);
307 #ifdef MEMOIZE_LOCALS
308 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
311 #ifdef MEMOIZE_LOCALS
312 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
316 SCM top_thunk
, real_var
;
319 top_thunk
= SCM_CAR (env
); /* env now refers to a
320 top level env thunk */
324 top_thunk
= SCM_BOOL_F
;
325 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
326 if (SCM_FALSEP (real_var
))
330 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
336 scm_error (scm_unbound_variable_key
, NULL
,
337 "Unbound variable: ~S",
338 scm_list_1 (var
), SCM_BOOL_F
);
340 scm_misc_error (NULL
, "Damaged environment: ~S",
345 /* A variable could not be found, but we shall
346 not throw an error. */
347 static SCM undef_object
= SCM_UNDEFINED
;
348 return &undef_object
;
354 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
356 /* Some other thread has changed the very cell we are working
357 on. In effect, it must have done our job or messed it up
360 var
= SCM_CAR (vloc
);
361 if (SCM_VARIABLEP (var
))
362 return SCM_VARIABLE_LOC (var
);
363 #ifdef MEMOIZE_LOCALS
364 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
365 return scm_ilookup (var
, genv
);
367 /* We can't cope with anything else than variables and ilocs. When
368 a special form has been memoized (i.e. `let' into `#@let') we
369 return NULL and expect the calling function to do the right
370 thing. For the evaluator, this means going back and redoing
371 the dispatch on the car of the form. */
374 #endif /* USE_THREADS */
376 SCM_SETCAR (vloc
, real_var
);
377 return SCM_VARIABLE_LOC (real_var
);
383 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
385 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
392 #define unmemocar scm_unmemocar
394 SCM_SYMBOL (sym_three_question_marks
, "???");
397 scm_unmemocar (SCM form
, SCM env
)
399 if (!SCM_CONSP (form
))
403 SCM c
= SCM_CAR (form
);
404 if (SCM_VARIABLEP (c
))
406 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
407 if (SCM_FALSEP (sym
))
408 sym
= sym_three_question_marks
;
409 SCM_SETCAR (form
, sym
);
411 #ifdef MEMOIZE_LOCALS
412 else if (SCM_ILOCP (c
))
414 unsigned long int ir
;
416 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
418 env
= SCM_CAAR (env
);
419 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
421 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
430 scm_eval_car (SCM pair
, SCM env
)
432 return SCM_XEVALCAR (pair
, env
);
437 * The following rewrite expressions and
438 * some memoized forms have different syntax
441 const char scm_s_expression
[] = "missing or extra expression";
442 const char scm_s_test
[] = "bad test";
443 const char scm_s_body
[] = "bad body";
444 const char scm_s_bindings
[] = "bad bindings";
445 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
446 const char scm_s_variable
[] = "bad variable";
447 const char scm_s_clauses
[] = "bad or missing clauses";
448 const char scm_s_formals
[] = "bad formals";
449 const char scm_s_duplicate_formals
[] = "duplicate formals";
450 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
452 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
453 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
454 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
455 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
456 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
460 #ifdef DEBUG_EXTENSIONS
461 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
462 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
463 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
464 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
468 /* Check that the body denoted by XORIG is valid and rewrite it into
469 its internal form. The internal form of a body is just the body
470 itself, but prefixed with an ISYM that denotes to what kind of
471 outer construct this body belongs. A lambda body starts with
472 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
473 etc. The one exception is a body that belongs to a letrec that has
474 been formed by rewriting internal defines: it starts with
477 /* XXX - Besides controlling the rewriting of internal defines, the
478 additional ISYM could be used for improved error messages.
479 This is not done yet. */
482 scm_m_body (SCM op
, SCM xorig
, const char *what
)
484 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
486 /* Don't add another ISYM if one is present already. */
487 if (SCM_ISYMP (SCM_CAR (xorig
)))
490 /* Retain possible doc string. */
491 if (!SCM_CONSP (SCM_CAR (xorig
)))
493 if (!SCM_NULLP (SCM_CDR (xorig
)))
494 return scm_cons (SCM_CAR (xorig
),
495 scm_m_body (op
, SCM_CDR (xorig
), what
));
499 return scm_cons (op
, xorig
);
503 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
504 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
507 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
509 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
510 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
514 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
515 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
518 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
520 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
521 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
525 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
526 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
529 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
531 long len
= scm_ilength (SCM_CDR (xorig
));
532 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
533 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
537 /* Will go into the RnRS module when Guile is factorized.
538 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
539 const char scm_s_set_x
[] = "set!";
540 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
543 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
545 SCM x
= SCM_CDR (xorig
);
546 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
547 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
548 return scm_cons (SCM_IM_SET_X
, x
);
552 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
553 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
556 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
558 long len
= scm_ilength (SCM_CDR (xorig
));
559 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
561 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
567 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
568 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
571 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
573 long len
= scm_ilength (SCM_CDR (xorig
));
574 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
576 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
582 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
583 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
586 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
589 SCM cdrx
= SCM_CDR (xorig
);
590 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
591 clauses
= SCM_CDR (cdrx
);
592 while (!SCM_NULLP (clauses
))
594 SCM clause
= SCM_CAR (clauses
);
595 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
596 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
597 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
598 && SCM_NULLP (SCM_CDR (clauses
))),
599 scm_s_clauses
, s_case
);
600 clauses
= SCM_CDR (clauses
);
602 return scm_cons (SCM_IM_CASE
, cdrx
);
606 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
607 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
610 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
612 SCM cdrx
= SCM_CDR (xorig
);
614 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
615 while (!SCM_NULLP (clauses
))
617 SCM clause
= SCM_CAR (clauses
);
618 long len
= scm_ilength (clause
);
619 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
620 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
622 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
623 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
625 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
627 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
628 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
630 clauses
= SCM_CDR (clauses
);
632 return scm_cons (SCM_IM_COND
, cdrx
);
636 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
637 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
639 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
640 * cdr of the last cons. (Thus, LIST is not required to be a proper
641 * list and OBJ can also be found in the improper ending.) */
643 scm_c_improper_memq (SCM obj
, SCM list
)
645 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
647 if (SCM_EQ_P (SCM_CAR (list
), obj
))
650 return SCM_EQ_P (list
, obj
);
654 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
657 SCM x
= SCM_CDR (xorig
);
659 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
661 formals
= SCM_CAR (x
);
662 while (SCM_CONSP (formals
))
664 SCM formal
= SCM_CAR (formals
);
665 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
666 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
667 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
668 formals
= SCM_CDR (formals
);
670 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
671 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
673 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
674 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
678 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
679 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
681 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
682 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
684 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
687 SCM x
= SCM_CDR (xorig
);
691 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
693 bindings
= SCM_CAR (x
);
694 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
695 while (!SCM_NULLP (bindings
))
697 SCM binding
= SCM_CAR (bindings
);
698 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
699 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
700 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
701 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
702 bindings
= SCM_CDR (bindings
);
705 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
706 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
710 /* DO gets the most radically altered syntax. The order of the vars is
711 * reversed here. In contrast, the order of the inits and steps is reversed
712 * during the evaluation:
714 (do ((<var1> <init1> <step1>)
722 (#@do (varn ... var2 var1)
723 (<init1> <init2> ... <initn>)
726 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
729 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
730 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
733 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
736 SCM x
= SCM_CDR (xorig
);
739 SCM
*initloc
= &inits
;
741 SCM
*steploc
= &steps
;
742 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
743 bindings
= SCM_CAR (x
);
744 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
745 while (!SCM_NULLP (bindings
))
747 SCM binding
= SCM_CAR (bindings
);
748 long len
= scm_ilength (binding
);
749 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
751 SCM name
= SCM_CAR (binding
);
752 SCM init
= SCM_CADR (binding
);
753 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
754 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
755 vars
= scm_cons (name
, vars
);
756 *initloc
= scm_list_1 (init
);
757 initloc
= SCM_CDRLOC (*initloc
);
758 *steploc
= scm_list_1 (step
);
759 steploc
= SCM_CDRLOC (*steploc
);
760 bindings
= SCM_CDR (bindings
);
764 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
765 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
766 x
= scm_cons2 (vars
, inits
, x
);
767 return scm_cons (SCM_IM_DO
, x
);
771 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
772 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
774 /* Internal function to handle a quasiquotation: 'form' is the parameter in
775 * the call (quasiquotation form), 'env' is the environment where unquoted
776 * expressions will be evaluated, and 'depth' is the current quasiquotation
777 * nesting level and is known to be greater than zero. */
779 iqq (SCM form
, SCM env
, unsigned long int depth
)
781 if (SCM_CONSP (form
))
783 SCM tmp
= SCM_CAR (form
);
784 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
786 SCM args
= SCM_CDR (form
);
787 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
788 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
790 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
792 SCM args
= SCM_CDR (form
);
793 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
795 return scm_eval_car (args
, env
);
797 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
799 else if (SCM_CONSP (tmp
)
800 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
802 SCM args
= SCM_CDR (tmp
);
803 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
806 SCM list
= scm_eval_car (args
, env
);
807 SCM rest
= SCM_CDR (form
);
808 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
809 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
812 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
813 iqq (SCM_CDR (form
), env
, depth
));
816 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
817 iqq (SCM_CDR (form
), env
, depth
));
819 else if (SCM_VECTORP (form
))
821 size_t i
= SCM_VECTOR_LENGTH (form
);
822 SCM
*data
= SCM_VELTS (form
);
825 tmp
= scm_cons (data
[--i
], tmp
);
826 scm_remember_upto_here_1 (form
);
827 return scm_vector (iqq (tmp
, env
, depth
));
834 scm_m_quasiquote (SCM xorig
, SCM env
)
836 SCM x
= SCM_CDR (xorig
);
837 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
838 return iqq (SCM_CAR (x
), env
, 1);
842 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
843 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
845 /* Promises are implemented as closures with an empty parameter list. Thus,
846 * (delay <expression>) is transformed into (#@delay '() <expression>), where
847 * the empty list represents the empty parameter list. This representation
848 * allows for easy creation of the closure during evaluation. */
850 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
852 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
853 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
857 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
858 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
860 /* Guile provides an extension to R5RS' define syntax to represent function
861 * currying in a compact way. With this extension, it is allowed to write
862 * (define <nested-variable> <body>), where <nested-variable> has of one of
863 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
864 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
865 * should be either a sequence of zero or more variables, or a sequence of one
866 * or more variables followed by a space-delimited period and another
867 * variable. Each level of argument nesting wraps the <body> within another
868 * lambda expression. For example, the following forms are allowed, each one
869 * followed by an equivalent, more explicit implementation.
871 * (define ((a b . c) . d) <body>) is equivalent to
872 * (define a (lambda (b . c) (lambda d <body>)))
874 * (define (((a) b) c . d) <body>) is equivalent to
875 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
877 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
878 * module that does not implement this extension. */
880 scm_m_define (SCM x
, SCM env
)
884 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
887 while (SCM_CONSP (name
))
889 /* This while loop realizes function currying by variable nesting. */
890 SCM formals
= SCM_CDR (name
);
891 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
892 name
= SCM_CAR (name
);
894 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
895 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
896 if (SCM_TOP_LEVEL (env
))
899 x
= scm_eval_car (x
, env
);
900 if (SCM_REC_PROCNAMES_P
)
903 while (SCM_MACROP (tmp
))
904 tmp
= SCM_MACRO_CODE (tmp
);
905 if (SCM_CLOSUREP (tmp
)
906 /* Only the first definition determines the name. */
907 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
908 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
910 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
911 SCM_VARIABLE_SET (var
, x
);
912 return SCM_UNSPECIFIED
;
915 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
919 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
920 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
921 * reversed here, the list of inits gets reversed during evaluation. */
923 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
929 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
933 SCM binding
= SCM_CAR (bindings
);
934 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
935 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
936 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
937 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
938 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
939 *initloc
= scm_list_1 (SCM_CADR (binding
));
940 initloc
= SCM_CDRLOC (*initloc
);
941 bindings
= SCM_CDR (bindings
);
943 while (!SCM_NULLP (bindings
));
949 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
950 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
953 scm_m_letrec (SCM xorig
, SCM env
)
955 SCM x
= SCM_CDR (xorig
);
956 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
958 if (SCM_NULLP (SCM_CAR (x
)))
960 /* null binding, let* faster */
961 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
962 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
966 SCM rvars
, inits
, body
;
967 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
968 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
969 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
974 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
975 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
978 scm_m_let (SCM xorig
, SCM env
)
980 SCM x
= SCM_CDR (xorig
);
983 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
986 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
988 /* null or single binding, let* is faster */
990 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
991 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
993 else if (SCM_CONSP (temp
))
997 SCM rvars
, inits
, body
;
998 transform_bindings (bindings
, &rvars
, &inits
, "let");
999 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1000 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
1004 /* named let: Transform (let name ((var init) ...) body ...) into
1005 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
1009 SCM
*varloc
= &vars
;
1010 SCM inits
= SCM_EOL
;
1011 SCM
*initloc
= &inits
;
1014 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
1016 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
1017 bindings
= SCM_CAR (x
);
1018 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
1019 while (!SCM_NULLP (bindings
))
1020 { /* vars and inits both in order */
1021 SCM binding
= SCM_CAR (bindings
);
1022 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1023 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1024 *varloc
= scm_list_1 (SCM_CAR (binding
));
1025 varloc
= SCM_CDRLOC (*varloc
);
1026 *initloc
= scm_list_1 (SCM_CADR (binding
));
1027 initloc
= SCM_CDRLOC (*initloc
);
1028 bindings
= SCM_CDR (bindings
);
1032 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1033 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1034 SCM rvar
= scm_list_1 (name
);
1035 SCM init
= scm_list_1 (lambda_form
);
1036 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1037 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1038 return scm_cons (letrec
, inits
);
1044 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1045 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1046 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1049 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1051 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1052 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1056 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1057 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1061 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1063 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1064 scm_s_expression
, s_atcall_cc
);
1065 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1068 #ifdef SCM_ENABLE_ELISP
1070 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1073 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1075 long len
= scm_ilength (SCM_CDR (xorig
));
1076 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1077 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1080 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1083 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1085 SCM x
= SCM_CDR (xorig
), var
;
1086 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1087 var
= scm_symbol_fref (SCM_CAR (x
));
1088 /* Passing the symbol name as the `subr' arg here isn't really
1089 right, but without it it can be very difficult to work out from
1090 the error message which function definition was missing. In any
1091 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1092 something equivalent to (signal void-function (list SYM)) in
1094 SCM_ASSYNT (SCM_VARIABLEP (var
),
1095 "Symbol's function definition is void",
1096 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1097 /* Support `defalias'. */
1098 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1100 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1101 SCM_ASSYNT (SCM_VARIABLEP (var
),
1102 "Symbol's function definition is void",
1103 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1105 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1106 former allows for automatically picking up redefinitions of the
1107 corresponding symbol. */
1108 SCM_SETCAR (x
, var
);
1109 /* If the variable contains a procedure, leave the
1110 `transformer-macro' in place so that the procedure's arguments
1111 get properly transformed, and change the initial @fop to
1113 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1115 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1118 /* Otherwise (the variable contains a macro), the arguments should
1119 not be transformed, so cut the `transformer-macro' out and return
1120 the resulting expression starting with the variable. */
1121 SCM_SETCDR (x
, SCM_CDADR (x
));
1125 #endif /* SCM_ENABLE_ELISP */
1127 /* (@bind ((var exp) ...) body ...)
1129 This will assign the values of the `exp's to the global variables
1130 named by `var's (symbols, not evaluated), creating them if they
1131 don't exist, executes body, and then restores the previous values of
1132 the `var's. Additionally, whenever control leaves body, the values
1133 of the `var's are saved and restored when control returns. It is an
1134 error when a symbol appears more than once among the `var's.
1135 All `exp's are evaluated before any `var' is set.
1137 Think of this as `let' for dynamic scope.
1139 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1141 XXX - also implement `@bind*'.
1144 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1147 scm_m_atbind (SCM xorig
, SCM env
)
1149 SCM x
= SCM_CDR (xorig
);
1150 SCM top_level
= scm_env_top_level (env
);
1151 SCM vars
= SCM_EOL
, var
;
1154 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1157 while (SCM_NIMP (x
))
1160 SCM sym_exp
= SCM_CAR (x
);
1161 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1162 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1164 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1165 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1166 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1167 /* The first call to scm_sym2var will look beyond the current
1168 module, while the second call wont. */
1169 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1170 if (SCM_FALSEP (var
))
1171 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1172 vars
= scm_cons (var
, vars
);
1173 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1175 return scm_cons (SCM_IM_BIND
,
1176 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1180 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1181 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1184 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1186 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1187 scm_s_expression
, s_at_call_with_values
);
1188 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1192 scm_m_expand_body (SCM xorig
, SCM env
)
1194 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1195 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1197 while (SCM_NIMP (x
))
1199 SCM form
= SCM_CAR (x
);
1200 if (!SCM_CONSP (form
))
1202 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1205 form
= scm_macroexp (scm_cons_source (form
,
1210 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1212 defs
= scm_cons (SCM_CDR (form
), defs
);
1215 else if (!SCM_IMP (defs
))
1219 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1221 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1225 x
= scm_cons (form
, SCM_CDR (x
));
1230 if (!SCM_NULLP (defs
))
1232 SCM rvars
, inits
, body
, letrec
;
1233 transform_bindings (defs
, &rvars
, &inits
, what
);
1234 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1235 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1236 SCM_SETCAR (xorig
, letrec
);
1237 SCM_SETCDR (xorig
, SCM_EOL
);
1241 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1242 SCM_SETCAR (xorig
, SCM_CAR (x
));
1243 SCM_SETCDR (xorig
, SCM_CDR (x
));
1250 scm_macroexp (SCM x
, SCM env
)
1252 SCM res
, proc
, orig_sym
;
1254 /* Don't bother to produce error messages here. We get them when we
1255 eventually execute the code for real. */
1258 orig_sym
= SCM_CAR (x
);
1259 if (!SCM_SYMBOLP (orig_sym
))
1264 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1265 if (proc_ptr
== NULL
)
1267 /* We have lost the race. */
1273 proc
= *scm_lookupcar (x
, env
, 0);
1276 /* Only handle memoizing macros. `Acros' and `macros' are really
1277 special forms and should not be evaluated here. */
1279 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1282 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1283 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1285 if (scm_ilength (res
) <= 0)
1286 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1289 SCM_SETCAR (x
, SCM_CAR (res
));
1290 SCM_SETCDR (x
, SCM_CDR (res
));
1296 /* scm_unmemocopy takes a memoized expression together with its
1297 * environment and rewrites it to its original form. Thus, it is the
1298 * inversion of the rewrite rules above. The procedure is not
1299 * optimized for speed. It's used in scm_iprin1 when printing the
1300 * code of a closure, in scm_procedure_source, in display_frame when
1301 * generating the source for a stackframe in a backtrace, and in
1302 * display_expression.
1304 * Unmemoizing is not a reliable process. You cannot in general
1305 * expect to get the original source back.
1307 * However, GOOPS currently relies on this for method compilation.
1308 * This ought to change.
1311 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1314 build_binding_list (SCM names
, SCM inits
)
1316 SCM bindings
= SCM_EOL
;
1317 while (!SCM_NULLP (names
))
1319 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1320 bindings
= scm_cons (binding
, bindings
);
1321 names
= SCM_CDR (names
);
1322 inits
= SCM_CDR (inits
);
1328 unmemocopy (SCM x
, SCM env
)
1331 #ifdef DEBUG_EXTENSIONS
1336 #ifdef DEBUG_EXTENSIONS
1337 p
= scm_whash_lookup (scm_source_whash
, x
);
1339 switch (SCM_ITAG7 (SCM_CAR (x
)))
1341 case SCM_BIT8(SCM_IM_AND
):
1342 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1344 case SCM_BIT8(SCM_IM_BEGIN
):
1345 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1347 case SCM_BIT8(SCM_IM_CASE
):
1348 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1350 case SCM_BIT8(SCM_IM_COND
):
1351 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1353 case SCM_BIT8 (SCM_IM_DO
):
1355 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1356 * where nx is the name of a local variable, ix is an initializer for
1357 * the local variable, test is the test clause of the do loop, body is
1358 * the body of the do loop and sx are the step clauses for the local
1360 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1363 names
= SCM_CAR (x
);
1365 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1366 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1368 test
= unmemocopy (SCM_CAR (x
), env
);
1370 memoized_body
= SCM_CAR (x
);
1372 steps
= scm_reverse (unmemocopy (x
, env
));
1374 /* build transformed binding list */
1376 while (!SCM_NULLP (names
))
1378 SCM name
= SCM_CAR (names
);
1379 SCM init
= SCM_CAR (inits
);
1380 SCM step
= SCM_CAR (steps
);
1381 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1383 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1385 names
= SCM_CDR (names
);
1386 inits
= SCM_CDR (inits
);
1387 steps
= SCM_CDR (steps
);
1389 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1390 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1392 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1395 case SCM_BIT8(SCM_IM_IF
):
1396 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1398 case SCM_BIT8 (SCM_IM_LET
):
1400 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1401 * where nx is the name of a local variable, ix is an initializer for
1402 * the local variable and by are the body clauses. */
1403 SCM names
, inits
, bindings
;
1406 names
= SCM_CAR (x
);
1408 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1409 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1411 bindings
= build_binding_list (names
, inits
);
1412 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1413 ls
= scm_cons (scm_sym_let
, z
);
1416 case SCM_BIT8 (SCM_IM_LETREC
):
1418 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1419 * where nx is the name of a local variable, ix is an initializer for
1420 * the local variable and by are the body clauses. */
1421 SCM names
, inits
, bindings
;
1424 names
= SCM_CAR (x
);
1425 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1427 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1429 bindings
= build_binding_list (names
, inits
);
1430 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1431 ls
= scm_cons (scm_sym_letrec
, z
);
1434 case SCM_BIT8(SCM_IM_LETSTAR
):
1442 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1445 y
= z
= scm_acons (SCM_CAR (b
),
1447 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1449 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1453 SCM_SETCDR (y
, SCM_EOL
);
1454 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1459 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1461 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1464 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1467 while (SCM_NIMP (b
));
1468 SCM_SETCDR (z
, SCM_EOL
);
1470 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1473 case SCM_BIT8(SCM_IM_OR
):
1474 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1476 case SCM_BIT8(SCM_IM_LAMBDA
):
1478 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1479 ls
= scm_cons (scm_sym_lambda
, z
);
1480 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1482 case SCM_BIT8(SCM_IM_QUOTE
):
1483 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1485 case SCM_BIT8(SCM_IM_SET_X
):
1486 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1488 case SCM_BIT8(SCM_IM_DEFINE
):
1493 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1494 ls
= scm_cons (scm_sym_define
, z
);
1495 if (!SCM_NULLP (env
))
1496 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1499 case SCM_BIT8(SCM_MAKISYM (0)):
1503 switch (SCM_ISYMNUM (z
))
1505 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1506 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1508 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1509 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1511 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1512 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1515 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1516 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1519 /* appease the Sun compiler god: */ ;
1523 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1529 while (SCM_CONSP (x
))
1531 SCM form
= SCM_CAR (x
);
1532 if (!SCM_ISYMP (form
))
1534 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1535 SCM_SETCDR (z
, unmemocar (copy
, env
));
1541 #ifdef DEBUG_EXTENSIONS
1542 if (!SCM_FALSEP (p
))
1543 scm_whash_insert (scm_source_whash
, ls
, p
);
1550 scm_unmemocopy (SCM x
, SCM env
)
1552 if (!SCM_NULLP (env
))
1553 /* Make a copy of the lowest frame to protect it from
1554 modifications by SCM_IM_DEFINE */
1555 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1557 return unmemocopy (x
, env
);
1560 #ifndef SCM_RECKLESS
1563 scm_badargsp (SCM formals
, SCM args
)
1565 while (!SCM_NULLP (formals
))
1567 if (!SCM_CONSP (formals
))
1569 if (SCM_NULLP (args
))
1571 formals
= SCM_CDR (formals
);
1572 args
= SCM_CDR (args
);
1574 return !SCM_NULLP (args
) ? 1 : 0;
1580 scm_badformalsp (SCM closure
, int n
)
1582 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1583 while (!SCM_NULLP (formals
))
1585 if (!SCM_CONSP (formals
))
1590 formals
= SCM_CDR (formals
);
1597 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1599 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1600 while (SCM_CONSP (l
))
1602 res
= EVALCAR (l
, env
);
1604 *lloc
= scm_list_1 (res
);
1605 lloc
= SCM_CDRLOC (*lloc
);
1610 scm_wrong_num_args (proc
);
1616 scm_eval_body (SCM code
, SCM env
)
1620 next
= SCM_CDR (code
);
1621 while (!SCM_NULLP (next
))
1623 if (SCM_IMP (SCM_CAR (code
)))
1625 if (SCM_ISYMP (SCM_CAR (code
)))
1627 code
= scm_m_expand_body (code
, env
);
1632 SCM_XEVAL (SCM_CAR (code
), env
);
1634 next
= SCM_CDR (code
);
1636 return SCM_XEVALCAR (code
, env
);
1643 /* SECTION: This code is specific for the debugging support. One
1644 * branch is read when DEVAL isn't defined, the other when DEVAL is
1650 #define SCM_APPLY scm_apply
1651 #define PREP_APPLY(proc, args)
1653 #define RETURN(x) do { return x; } while (0)
1654 #ifdef STACK_CHECKING
1655 #ifndef NO_CEVAL_STACK_CHECKING
1656 #define EVAL_STACK_CHECKING
1663 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1665 #define SCM_APPLY scm_dapply
1667 #define PREP_APPLY(p, l) \
1668 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1670 #define ENTER_APPLY \
1672 SCM_SET_ARGSREADY (debug);\
1673 if (scm_check_apply_p && SCM_TRAPS_P)\
1674 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1676 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1677 SCM_SET_TRACED_FRAME (debug); \
1679 if (SCM_CHEAPTRAPS_P)\
1681 tmp = scm_make_debugobj (&debug);\
1682 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1687 tmp = scm_make_continuation (&first);\
1689 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1695 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1696 #ifdef STACK_CHECKING
1697 #ifndef EVAL_STACK_CHECKING
1698 #define EVAL_STACK_CHECKING
1702 /* scm_ceval_ptr points to the currently selected evaluator.
1703 * *fixme*: Although efficiency is important here, this state variable
1704 * should probably not be a global. It should be related to the
1709 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1711 /* scm_last_debug_frame contains a pointer to the last debugging
1712 * information stack frame. It is accessed very often from the
1713 * debugging evaluator, so it should probably not be indirectly
1714 * addressed. Better to save and restore it from the current root at
1719 scm_t_debug_frame
*scm_last_debug_frame
;
1722 /* scm_debug_eframe_size is the number of slots available for pseudo
1723 * stack frames at each real stack frame.
1726 long scm_debug_eframe_size
;
1728 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1730 long scm_eval_stack
;
1732 scm_t_option scm_eval_opts
[] = {
1733 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1736 scm_t_option scm_debug_opts
[] = {
1737 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1738 "*Flyweight representation of the stack at traps." },
1739 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1740 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1741 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1742 "Record procedure names at definition." },
1743 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1744 "Display backtrace in anti-chronological order." },
1745 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1746 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1747 { SCM_OPTION_INTEGER
, "frames", 3,
1748 "Maximum number of tail-recursive frames in backtrace." },
1749 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1750 "Maximal number of stored backtrace frames." },
1751 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1752 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1753 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1754 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1755 { 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."}
1758 scm_t_option scm_evaluator_trap_table
[] = {
1759 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1760 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1761 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1762 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1763 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1764 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1765 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1768 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1770 "Option interface for the evaluation options. Instead of using\n"
1771 "this procedure directly, use the procedures @code{eval-enable},\n"
1772 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1773 #define FUNC_NAME s_scm_eval_options_interface
1777 ans
= scm_options (setting
,
1781 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1787 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1789 "Option interface for the evaluator trap options.")
1790 #define FUNC_NAME s_scm_evaluator_traps
1794 ans
= scm_options (setting
,
1795 scm_evaluator_trap_table
,
1796 SCM_N_EVALUATOR_TRAPS
,
1798 SCM_RESET_DEBUG_MODE
;
1805 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1807 SCM
*results
= lloc
, res
;
1808 while (SCM_CONSP (l
))
1810 res
= EVALCAR (l
, env
);
1812 *lloc
= scm_list_1 (res
);
1813 lloc
= SCM_CDRLOC (*lloc
);
1818 scm_wrong_num_args (proc
);
1826 /* SECTION: This code is compiled twice.
1830 /* Update the toplevel environment frame ENV so that it refers to the
1831 * current module. */
1832 #define UPDATE_TOPLEVEL_ENV(env) \
1834 SCM p = scm_current_module_lookup_closure (); \
1835 if (p != SCM_CAR(env)) \
1836 env = scm_top_level_env (p); \
1840 /* This is the evaluator. Like any real monster, it has three heads:
1842 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1843 * version. Both are implemented using a common code base, using the
1844 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1845 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1846 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1847 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1848 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1849 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1850 * are enclosed within #ifdef DEVAL ... #endif.
1852 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1853 * take two input parameters, x and env: x is a single expression to be
1854 * evalutated. env is the environment in which bindings are searched.
1856 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1857 * is a single expression, it is necessarily in a tail position. If x is just
1858 * a call to another function like in the expression (foo exp1 exp2 ...), the
1859 * realization of that call therefore _must_not_ increase stack usage (the
1860 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1861 * making extensive use of 'goto' statements within the evaluator: The gotos
1862 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1863 * that SCM_CEVAL was already using. If, however, x represents some form that
1864 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1865 * then recursive calls to SCM_CEVAL are performed for all but the last
1866 * expression of that sequence. */
1870 scm_ceval (SCM x
, SCM env
)
1876 scm_deval (SCM x
, SCM env
)
1881 SCM_CEVAL (SCM x
, SCM env
)
1885 scm_t_debug_frame debug
;
1886 scm_t_debug_info
*debug_info_end
;
1887 debug
.prev
= scm_last_debug_frame
;
1890 * The debug.vect contains twice as much scm_t_debug_info frames as the
1891 * user has specified with (debug-set! frames <n>).
1893 * Even frames are eval frames, odd frames are apply frames.
1895 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1896 * sizeof (scm_t_debug_info
));
1897 debug
.info
= debug
.vect
;
1898 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1899 scm_last_debug_frame
= &debug
;
1901 #ifdef EVAL_STACK_CHECKING
1902 if (scm_stack_checking_enabled_p
1903 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1906 debug
.info
->e
.exp
= x
;
1907 debug
.info
->e
.env
= env
;
1909 scm_report_stack_overflow ();
1919 SCM_CLEAR_ARGSREADY (debug
);
1920 if (SCM_OVERFLOWP (debug
))
1923 * In theory, this should be the only place where it is necessary to
1924 * check for space in debug.vect since both eval frames and
1925 * available space are even.
1927 * For this to be the case, however, it is necessary that primitive
1928 * special forms which jump back to `loop', `begin' or some similar
1929 * label call PREP_APPLY.
1931 else if (++debug
.info
>= debug_info_end
)
1933 SCM_SET_OVERFLOW (debug
);
1938 debug
.info
->e
.exp
= x
;
1939 debug
.info
->e
.env
= env
;
1940 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1942 if (SCM_ENTER_FRAME_P
1943 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1946 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1947 SCM_SET_TAILREC (debug
);
1948 if (SCM_CHEAPTRAPS_P
)
1949 stackrep
= scm_make_debugobj (&debug
);
1953 SCM val
= scm_make_continuation (&first
);
1963 /* This gives the possibility for the debugger to
1964 modify the source expression before evaluation. */
1969 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1970 scm_sym_enter_frame
,
1973 scm_unmemocopy (x
, env
));
1978 #if defined (USE_THREADS) || defined (DEVAL)
1982 switch (SCM_TYP7 (x
))
1984 case scm_tc7_symbol
:
1985 /* Only happens when called at top level. */
1986 x
= scm_cons (x
, SCM_UNDEFINED
);
1987 RETURN (*scm_lookupcar (x
, env
, 1));
1989 case SCM_BIT8 (SCM_IM_AND
):
1991 while (!SCM_NULLP (SCM_CDR (x
)))
1993 SCM test_result
= EVALCAR (x
, env
);
1994 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1995 RETURN (SCM_BOOL_F
);
1999 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2002 case SCM_BIT8 (SCM_IM_BEGIN
):
2005 RETURN (SCM_UNSPECIFIED
);
2007 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2010 /* If we are on toplevel with a lookup closure, we need to sync
2011 with the current module. */
2012 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
2014 UPDATE_TOPLEVEL_ENV (env
);
2015 while (!SCM_NULLP (SCM_CDR (x
)))
2018 UPDATE_TOPLEVEL_ENV (env
);
2024 goto nontoplevel_begin
;
2027 while (!SCM_NULLP (SCM_CDR (x
)))
2029 SCM form
= SCM_CAR (x
);
2032 if (SCM_ISYMP (form
))
2034 x
= scm_m_expand_body (x
, env
);
2035 goto nontoplevel_begin
;
2038 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2041 SCM_CEVAL (form
, env
);
2047 /* scm_eval last form in list */
2048 SCM last_form
= SCM_CAR (x
);
2050 if (SCM_CONSP (last_form
))
2052 /* This is by far the most frequent case. */
2054 goto loop
; /* tail recurse */
2056 else if (SCM_IMP (last_form
))
2057 RETURN (SCM_EVALIM (last_form
, env
));
2058 else if (SCM_VARIABLEP (last_form
))
2059 RETURN (SCM_VARIABLE_REF (last_form
));
2060 else if (SCM_SYMBOLP (last_form
))
2061 RETURN (*scm_lookupcar (x
, env
, 1));
2067 case SCM_BIT8 (SCM_IM_CASE
):
2070 SCM key
= EVALCAR (x
, env
);
2072 while (!SCM_NULLP (x
))
2074 SCM clause
= SCM_CAR (x
);
2075 SCM labels
= SCM_CAR (clause
);
2076 if (SCM_EQ_P (labels
, scm_sym_else
))
2078 x
= SCM_CDR (clause
);
2079 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2082 while (!SCM_NULLP (labels
))
2084 SCM label
= SCM_CAR (labels
);
2085 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2087 x
= SCM_CDR (clause
);
2088 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2091 labels
= SCM_CDR (labels
);
2096 RETURN (SCM_UNSPECIFIED
);
2099 case SCM_BIT8 (SCM_IM_COND
):
2101 while (!SCM_NULLP (x
))
2103 SCM clause
= SCM_CAR (x
);
2104 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2106 x
= SCM_CDR (clause
);
2107 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2112 arg1
= EVALCAR (clause
, env
);
2113 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2115 x
= SCM_CDR (clause
);
2118 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2120 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2126 proc
= EVALCAR (proc
, env
);
2127 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2128 PREP_APPLY (proc
, scm_list_1 (arg1
));
2130 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2131 goto umwrongnumargs
;
2139 RETURN (SCM_UNSPECIFIED
);
2142 case SCM_BIT8 (SCM_IM_DO
):
2145 /* Compute the initialization values and the initial environment. */
2146 SCM init_forms
= SCM_CADR (x
);
2147 SCM init_values
= SCM_EOL
;
2148 while (!SCM_NULLP (init_forms
))
2150 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2151 init_forms
= SCM_CDR (init_forms
);
2153 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2157 SCM test_form
= SCM_CAR (x
);
2158 SCM body_forms
= SCM_CADR (x
);
2159 SCM step_forms
= SCM_CDDR (x
);
2161 SCM test_result
= EVALCAR (test_form
, env
);
2163 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2166 /* Evaluate body forms. */
2168 for (temp_forms
= body_forms
;
2169 !SCM_NULLP (temp_forms
);
2170 temp_forms
= SCM_CDR (temp_forms
))
2172 SCM form
= SCM_CAR (temp_forms
);
2173 /* Dirk:FIXME: We only need to eval forms, that may have a
2174 * side effect here. This is only true for forms that start
2175 * with a pair. All others are just constants. However,
2176 * since in the common case there is no constant expression
2177 * in a body of a do form, we just check for immediates here
2178 * and have SCM_CEVAL take care of other cases. In the long
2179 * run it would make sense to get rid of this test and have
2180 * the macro transformer of 'do' eliminate all forms that
2181 * have no sideeffect. */
2182 if (!SCM_IMP (form
))
2183 SCM_CEVAL (form
, env
);
2188 /* Evaluate the step expressions. */
2190 SCM step_values
= SCM_EOL
;
2191 for (temp_forms
= step_forms
;
2192 !SCM_NULLP (temp_forms
);
2193 temp_forms
= SCM_CDR (temp_forms
))
2195 SCM value
= EVALCAR (temp_forms
, env
);
2196 step_values
= scm_cons (value
, step_values
);
2198 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2201 test_result
= EVALCAR (test_form
, env
);
2206 RETURN (SCM_UNSPECIFIED
);
2207 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2208 goto nontoplevel_begin
;
2211 case SCM_BIT8 (SCM_IM_IF
):
2214 SCM test_result
= EVALCAR (x
, env
);
2215 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2221 RETURN (SCM_UNSPECIFIED
);
2224 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2228 case SCM_BIT8 (SCM_IM_LET
):
2231 SCM init_forms
= SCM_CADR (x
);
2232 SCM init_values
= SCM_EOL
;
2235 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2236 init_forms
= SCM_CDR (init_forms
);
2238 while (!SCM_NULLP (init_forms
));
2239 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2242 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2243 goto nontoplevel_begin
;
2246 case SCM_BIT8 (SCM_IM_LETREC
):
2248 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2251 SCM init_forms
= SCM_CAR (x
);
2252 SCM init_values
= SCM_EOL
;
2255 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2256 init_forms
= SCM_CDR (init_forms
);
2258 while (!SCM_NULLP (init_forms
));
2259 SCM_SETCDR (SCM_CAR (env
), init_values
);
2262 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2263 goto nontoplevel_begin
;
2266 case SCM_BIT8 (SCM_IM_LETSTAR
):
2269 SCM bindings
= SCM_CAR (x
);
2270 if (SCM_NULLP (bindings
))
2271 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2276 SCM name
= SCM_CAR (bindings
);
2277 SCM init
= SCM_CDR (bindings
);
2278 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2279 bindings
= SCM_CDR (init
);
2281 while (!SCM_NULLP (bindings
));
2285 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2286 goto nontoplevel_begin
;
2289 case SCM_BIT8 (SCM_IM_OR
):
2291 while (!SCM_NULLP (SCM_CDR (x
)))
2293 SCM val
= EVALCAR (x
, env
);
2294 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2299 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2303 case SCM_BIT8 (SCM_IM_LAMBDA
):
2304 RETURN (scm_closure (SCM_CDR (x
), env
));
2307 case SCM_BIT8 (SCM_IM_QUOTE
):
2308 RETURN (SCM_CADR (x
));
2311 case SCM_BIT8 (SCM_IM_SET_X
):
2315 SCM variable
= SCM_CAR (x
);
2316 #ifdef MEMOIZE_LOCALS
2317 if (SCM_ILOCP (variable
))
2318 location
= scm_ilookup (variable
, env
);
2321 if (SCM_VARIABLEP (variable
))
2322 location
= SCM_VARIABLE_LOC (variable
);
2323 else /* (SCM_SYMBOLP (variable)) is known to be true */
2324 location
= scm_lookupcar (x
, env
, 1);
2326 *location
= EVALCAR (x
, env
);
2328 RETURN (SCM_UNSPECIFIED
);
2331 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2332 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2335 /* new syntactic forms go here. */
2336 case SCM_BIT8 (SCM_MAKISYM (0)):
2338 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2339 switch (SCM_ISYMNUM (proc
))
2343 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2345 proc
= EVALCAR (proc
, env
);
2346 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2347 if (SCM_CLOSUREP (proc
))
2349 PREP_APPLY (proc
, SCM_EOL
);
2350 arg1
= SCM_CDDR (x
);
2351 arg1
= EVALCAR (arg1
, env
);
2353 /* Go here to tail-call a closure. PROC is the closure
2354 and ARG1 is the list of arguments. Do not forget to
2357 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2359 debug
.info
->a
.args
= arg1
;
2361 #ifndef SCM_RECKLESS
2362 if (scm_badargsp (formals
, arg1
))
2363 scm_wrong_num_args (proc
);
2366 /* Copy argument list */
2367 if (SCM_NULL_OR_NIL_P (arg1
))
2368 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2371 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2373 arg1
= SCM_CDR (arg1
);
2374 while (!SCM_NULL_OR_NIL_P (arg1
))
2376 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2377 SCM_SETCDR (tail
, new_tail
);
2379 arg1
= SCM_CDR (arg1
);
2381 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2384 x
= SCM_CLOSURE_BODY (proc
);
2385 goto nontoplevel_begin
;
2395 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2398 SCM val
= scm_make_continuation (&first
);
2406 proc
= scm_eval_car (proc
, env
);
2407 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2408 PREP_APPLY (proc
, scm_list_1 (arg1
));
2410 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2411 goto umwrongnumargs
;
2417 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2418 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2421 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2423 /* If not done yet, evaluate the operand forms. The result is a
2424 * list of arguments stored in arg1, which is used to perform the
2425 * function dispatch. */
2426 SCM operand_forms
= SCM_CADR (x
);
2427 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2428 if (SCM_ILOCP (operand_forms
))
2429 arg1
= *scm_ilookup (operand_forms
, env
);
2430 else if (SCM_VARIABLEP (operand_forms
))
2431 arg1
= SCM_VARIABLE_REF (operand_forms
);
2432 else if (!SCM_CONSP (operand_forms
))
2433 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2436 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2437 operand_forms
= SCM_CDR (operand_forms
);
2438 while (!SCM_NULLP (operand_forms
))
2440 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2441 SCM_SETCDR (tail
, new_tail
);
2443 operand_forms
= SCM_CDR (operand_forms
);
2448 /* The type dispatch code is duplicated below
2449 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2450 * cuts down execution time for type dispatch to 50%. */
2451 type_dispatch
: /* inputs: x, arg1 */
2452 /* Type dispatch means to determine from the types of the function
2453 * arguments (i. e. the 'signature' of the call), which method from
2454 * a generic function is to be called. This process of selecting
2455 * the right method takes some time. To speed it up, guile uses
2456 * caching: Together with the macro call to dispatch the signatures
2457 * of some previous calls to that generic function from the same
2458 * place are stored (in the code!) in a cache that we call the
2459 * 'method cache'. This is done since it is likely, that
2460 * consecutive calls to dispatch from that position in the code will
2461 * have the same signature. Thus, the type dispatch works as
2462 * follows: First, determine a hash value from the signature of the
2463 * actual arguments. Second, use this hash value as an index to
2464 * find that same signature in the method cache stored at this
2465 * position in the code. If found, you have also found the
2466 * corresponding method that belongs to that signature. If the
2467 * signature is not found in the method cache, you have to perform a
2468 * full search over all signatures stored with the generic
2471 unsigned long int specializers
;
2472 unsigned long int hash_value
;
2473 unsigned long int cache_end_pos
;
2474 unsigned long int mask
;
2478 SCM z
= SCM_CDDR (x
);
2479 SCM tmp
= SCM_CADR (z
);
2480 specializers
= SCM_INUM (SCM_CAR (z
));
2482 /* Compute a hash value for searching the method cache. There
2483 * are two variants for computing the hash value, a (rather)
2484 * complicated one, and a simple one. For the complicated one
2485 * explained below, tmp holds a number that is used in the
2487 if (SCM_INUMP (tmp
))
2489 /* Use the signature of the actual arguments to determine
2490 * the hash value. This is done as follows: Each class has
2491 * an array of random numbers, that are determined when the
2492 * class is created. The integer 'hashset' is an index into
2493 * that array of random numbers. Now, from all classes that
2494 * are part of the signature of the actual arguments, the
2495 * random numbers at index 'hashset' are taken and summed
2496 * up, giving the hash value. The value of 'hashset' is
2497 * stored at the call to dispatch. This allows to have
2498 * different 'formulas' for calculating the hash value at
2499 * different places where dispatch is called. This allows
2500 * to optimize the hash formula at every individual place
2501 * where dispatch is called, such that hopefully the hash
2502 * value that is computed will directly point to the right
2503 * method in the method cache. */
2504 unsigned long int hashset
= SCM_INUM (tmp
);
2505 unsigned long int counter
= specializers
+ 1;
2508 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2510 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2511 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2512 tmp_arg
= SCM_CDR (tmp_arg
);
2516 method_cache
= SCM_CADR (z
);
2517 mask
= SCM_INUM (SCM_CAR (z
));
2519 cache_end_pos
= hash_value
;
2523 /* This method of determining the hash value is much
2524 * simpler: Set the hash value to zero and just perform a
2525 * linear search through the method cache. */
2527 mask
= (unsigned long int) ((long) -1);
2529 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2534 /* Search the method cache for a method with a matching
2535 * signature. Start the search at position 'hash_value'. The
2536 * hashing implementation uses linear probing for conflict
2537 * resolution, that is, if the signature in question is not
2538 * found at the starting index in the hash table, the next table
2539 * entry is tried, and so on, until in the worst case the whole
2540 * cache has been searched, but still the signature has not been
2545 SCM args
= arg1
; /* list of arguments */
2546 z
= SCM_VELTS (method_cache
)[hash_value
];
2547 while (!SCM_NULLP (args
))
2549 /* More arguments than specifiers => CLASS != ENV */
2550 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2551 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2553 args
= SCM_CDR (args
);
2556 /* Fewer arguments than specifiers => CAR != ENV */
2557 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2560 hash_value
= (hash_value
+ 1) & mask
;
2561 } while (hash_value
!= cache_end_pos
);
2563 /* No appropriate method was found in the cache. */
2564 z
= scm_memoize_method (x
, arg1
);
2566 apply_cmethod
: /* inputs: z, arg1 */
2568 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2569 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2570 x
= SCM_CMETHOD_BODY (z
);
2571 goto nontoplevel_begin
;
2577 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2580 SCM instance
= EVALCAR (x
, env
);
2581 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2582 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2586 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2589 SCM instance
= EVALCAR (x
, env
);
2590 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2591 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2592 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2593 RETURN (SCM_UNSPECIFIED
);
2597 #ifdef SCM_ENABLE_ELISP
2599 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2601 SCM test_form
= SCM_CDR (x
);
2602 x
= SCM_CDR (test_form
);
2603 while (!SCM_NULL_OR_NIL_P (x
))
2605 SCM test_result
= EVALCAR (test_form
, env
);
2606 if (!(SCM_FALSEP (test_result
)
2607 || SCM_NULL_OR_NIL_P (test_result
)))
2609 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2610 RETURN (test_result
);
2611 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2616 test_form
= SCM_CDR (x
);
2617 x
= SCM_CDR (test_form
);
2621 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2625 #endif /* SCM_ENABLE_ELISP */
2627 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2629 SCM vars
, exps
, vals
;
2632 vars
= SCM_CAAR (x
);
2633 exps
= SCM_CDAR (x
);
2637 while (SCM_NIMP (exps
))
2639 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2640 exps
= SCM_CDR (exps
);
2643 scm_swap_bindings (vars
, vals
);
2644 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2646 /* Ignore all but the last evaluation result. */
2647 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2649 if (SCM_CONSP (SCM_CAR (x
)))
2650 SCM_CEVAL (SCM_CAR (x
), env
);
2652 proc
= EVALCAR (x
, env
);
2654 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2655 scm_swap_bindings (vars
, vals
);
2661 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2664 x
= EVALCAR (proc
, env
);
2665 proc
= SCM_CDR (proc
);
2666 proc
= EVALCAR (proc
, env
);
2667 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2668 if (SCM_VALUESP (arg1
))
2669 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2671 arg1
= scm_list_1 (arg1
);
2672 if (SCM_CLOSUREP (proc
))
2674 PREP_APPLY (proc
, arg1
);
2677 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2688 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2689 case scm_tc7_vector
:
2693 case scm_tc7_byvect
:
2700 #ifdef HAVE_LONG_LONGS
2701 case scm_tc7_llvect
:
2704 case scm_tc7_string
:
2706 case scm_tcs_closures
:
2710 case scm_tcs_struct
:
2713 case scm_tc7_variable
:
2714 RETURN (SCM_VARIABLE_REF(x
));
2716 #ifdef MEMOIZE_LOCALS
2717 case SCM_BIT8(SCM_ILOC00
):
2718 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2719 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2720 #ifndef SCM_RECKLESS
2726 #endif /* ifdef MEMOIZE_LOCALS */
2728 case scm_tcs_cons_nimcar
:
2729 if (SCM_SYMBOLP (SCM_CAR (x
)))
2731 SCM orig_sym
= SCM_CAR (x
);
2734 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2735 if (location
== NULL
)
2737 /* we have lost the race, start again. */
2743 proc
= *scm_lookupcar (x
, env
, 1);
2748 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2752 if (SCM_MACROP (proc
))
2754 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2756 handle_a_macro
: /* inputs: x, env, proc */
2758 /* Set a flag during macro expansion so that macro
2759 application frames can be deleted from the backtrace. */
2760 SCM_SET_MACROEXP (debug
);
2762 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2763 scm_cons (env
, scm_listofnull
));
2766 SCM_CLEAR_MACROEXP (debug
);
2768 switch (SCM_MACRO_TYPE (proc
))
2771 if (scm_ilength (arg1
) <= 0)
2772 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2774 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2777 SCM_SETCAR (x
, SCM_CAR (arg1
));
2778 SCM_SETCDR (x
, SCM_CDR (arg1
));
2782 /* Prevent memoizing of debug info expression. */
2783 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2788 SCM_SETCAR (x
, SCM_CAR (arg1
));
2789 SCM_SETCDR (x
, SCM_CDR (arg1
));
2791 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2797 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2808 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2809 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2810 #ifndef SCM_RECKLESS
2814 if (SCM_CLOSUREP (proc
))
2816 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2817 SCM args
= SCM_CDR (x
);
2818 while (!SCM_NULLP (formals
))
2820 if (!SCM_CONSP (formals
))
2823 goto umwrongnumargs
;
2824 formals
= SCM_CDR (formals
);
2825 args
= SCM_CDR (args
);
2827 if (!SCM_NULLP (args
))
2828 goto umwrongnumargs
;
2830 else if (SCM_MACROP (proc
))
2831 goto handle_a_macro
;
2836 evapply
: /* inputs: x, proc */
2837 PREP_APPLY (proc
, SCM_EOL
);
2838 if (SCM_NULLP (SCM_CDR (x
))) {
2841 switch (SCM_TYP7 (proc
))
2842 { /* no arguments given */
2843 case scm_tc7_subr_0
:
2844 RETURN (SCM_SUBRF (proc
) ());
2845 case scm_tc7_subr_1o
:
2846 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2848 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2849 case scm_tc7_rpsubr
:
2850 RETURN (SCM_BOOL_T
);
2852 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2854 if (!SCM_SMOB_APPLICABLE_P (proc
))
2856 RETURN (SCM_SMOB_APPLY_0 (proc
));
2859 proc
= SCM_CCLO_SUBR (proc
);
2861 debug
.info
->a
.proc
= proc
;
2862 debug
.info
->a
.args
= scm_list_1 (arg1
);
2866 proc
= SCM_PROCEDURE (proc
);
2868 debug
.info
->a
.proc
= proc
;
2870 if (!SCM_CLOSUREP (proc
))
2872 if (scm_badformalsp (proc
, 0))
2873 goto umwrongnumargs
;
2874 case scm_tcs_closures
:
2875 x
= SCM_CLOSURE_BODY (proc
);
2876 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2877 goto nontoplevel_begin
;
2878 case scm_tcs_struct
:
2879 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2881 x
= SCM_ENTITY_PROCEDURE (proc
);
2885 else if (!SCM_I_OPERATORP (proc
))
2890 proc
= (SCM_I_ENTITYP (proc
)
2891 ? SCM_ENTITY_PROCEDURE (proc
)
2892 : SCM_OPERATOR_PROCEDURE (proc
));
2894 debug
.info
->a
.proc
= proc
;
2895 debug
.info
->a
.args
= scm_list_1 (arg1
);
2897 if (SCM_NIMP (proc
))
2902 case scm_tc7_subr_1
:
2903 case scm_tc7_subr_2
:
2904 case scm_tc7_subr_2o
:
2906 case scm_tc7_subr_3
:
2907 case scm_tc7_lsubr_2
:
2910 scm_wrong_num_args (proc
);
2912 /* handle macros here */
2917 /* must handle macros by here */
2921 arg1
= EVALCAR (x
, env
);
2923 scm_wrong_num_args (proc
);
2925 arg1
= EVALCAR (x
, env
);
2928 debug
.info
->a
.args
= scm_list_1 (arg1
);
2936 evap1
: /* inputs: proc, arg1 */
2937 switch (SCM_TYP7 (proc
))
2938 { /* have one argument in arg1 */
2939 case scm_tc7_subr_2o
:
2940 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2941 case scm_tc7_subr_1
:
2942 case scm_tc7_subr_1o
:
2943 RETURN (SCM_SUBRF (proc
) (arg1
));
2945 if (SCM_SUBRF (proc
))
2947 if (SCM_INUMP (arg1
))
2949 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2951 else if (SCM_REALP (arg1
))
2953 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2956 else if (SCM_BIGP (arg1
))
2958 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2961 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2962 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2964 proc
= SCM_SNAME (proc
);
2966 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2967 while ('c' != *--chrs
)
2969 SCM_ASSERT (SCM_CONSP (arg1
),
2970 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2971 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2975 case scm_tc7_rpsubr
:
2976 RETURN (SCM_BOOL_T
);
2978 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2981 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2983 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2986 if (!SCM_SMOB_APPLICABLE_P (proc
))
2988 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2992 proc
= SCM_CCLO_SUBR (proc
);
2994 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2995 debug
.info
->a
.proc
= proc
;
2999 proc
= SCM_PROCEDURE (proc
);
3001 debug
.info
->a
.proc
= proc
;
3003 if (!SCM_CLOSUREP (proc
))
3005 if (scm_badformalsp (proc
, 1))
3006 goto umwrongnumargs
;
3007 case scm_tcs_closures
:
3009 x
= SCM_CLOSURE_BODY (proc
);
3011 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
3013 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
3015 goto nontoplevel_begin
;
3016 case scm_tcs_struct
:
3017 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3019 x
= SCM_ENTITY_PROCEDURE (proc
);
3021 arg1
= debug
.info
->a
.args
;
3023 arg1
= scm_list_1 (arg1
);
3027 else if (!SCM_I_OPERATORP (proc
))
3033 proc
= (SCM_I_ENTITYP (proc
)
3034 ? SCM_ENTITY_PROCEDURE (proc
)
3035 : SCM_OPERATOR_PROCEDURE (proc
));
3037 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3038 debug
.info
->a
.proc
= proc
;
3040 if (SCM_NIMP (proc
))
3045 case scm_tc7_subr_2
:
3046 case scm_tc7_subr_0
:
3047 case scm_tc7_subr_3
:
3048 case scm_tc7_lsubr_2
:
3049 scm_wrong_num_args (proc
);
3056 arg2
= EVALCAR (x
, env
);
3058 scm_wrong_num_args (proc
);
3060 arg2
= EVALCAR (x
, env
);
3062 { /* have two or more arguments */
3064 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3067 if (SCM_NULLP (x
)) {
3070 switch (SCM_TYP7 (proc
))
3071 { /* have two arguments */
3072 case scm_tc7_subr_2
:
3073 case scm_tc7_subr_2o
:
3074 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3077 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3079 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3081 case scm_tc7_lsubr_2
:
3082 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3083 case scm_tc7_rpsubr
:
3085 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3087 if (!SCM_SMOB_APPLICABLE_P (proc
))
3089 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3093 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3094 scm_cons (proc
, debug
.info
->a
.args
),
3097 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3098 scm_cons2 (proc
, arg1
,
3105 case scm_tcs_struct
:
3106 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3108 x
= SCM_ENTITY_PROCEDURE (proc
);
3110 arg1
= debug
.info
->a
.args
;
3112 arg1
= scm_list_2 (arg1
, arg2
);
3116 else if (!SCM_I_OPERATORP (proc
))
3122 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3123 ? SCM_ENTITY_PROCEDURE (proc
)
3124 : SCM_OPERATOR_PROCEDURE (proc
),
3125 scm_cons (proc
, debug
.info
->a
.args
),
3128 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3129 ? SCM_ENTITY_PROCEDURE (proc
)
3130 : SCM_OPERATOR_PROCEDURE (proc
),
3131 scm_cons2 (proc
, arg1
,
3139 case scm_tc7_subr_0
:
3141 case scm_tc7_subr_1o
:
3142 case scm_tc7_subr_1
:
3143 case scm_tc7_subr_3
:
3144 scm_wrong_num_args (proc
);
3148 proc
= SCM_PROCEDURE (proc
);
3150 debug
.info
->a
.proc
= proc
;
3152 if (!SCM_CLOSUREP (proc
))
3154 if (scm_badformalsp (proc
, 2))
3155 goto umwrongnumargs
;
3156 case scm_tcs_closures
:
3159 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3163 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3164 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3166 x
= SCM_CLOSURE_BODY (proc
);
3167 goto nontoplevel_begin
;
3172 scm_wrong_num_args (proc
);
3175 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3176 deval_args (x
, env
, proc
,
3177 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3181 switch (SCM_TYP7 (proc
))
3182 { /* have 3 or more arguments */
3184 case scm_tc7_subr_3
:
3185 if (!SCM_NULLP (SCM_CDR (x
)))
3186 scm_wrong_num_args (proc
);
3188 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3189 SCM_CADDR (debug
.info
->a
.args
)));
3191 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3192 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3195 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3196 arg2
= SCM_CDR (arg2
);
3198 while (SCM_NIMP (arg2
));
3200 case scm_tc7_rpsubr
:
3201 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3202 RETURN (SCM_BOOL_F
);
3203 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3206 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3207 RETURN (SCM_BOOL_F
);
3208 arg2
= SCM_CAR (arg1
);
3209 arg1
= SCM_CDR (arg1
);
3211 while (SCM_NIMP (arg1
));
3212 RETURN (SCM_BOOL_T
);
3213 case scm_tc7_lsubr_2
:
3214 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3215 SCM_CDDR (debug
.info
->a
.args
)));
3217 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3219 if (!SCM_SMOB_APPLICABLE_P (proc
))
3221 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3222 SCM_CDDR (debug
.info
->a
.args
)));
3226 proc
= SCM_PROCEDURE (proc
);
3227 debug
.info
->a
.proc
= proc
;
3228 if (!SCM_CLOSUREP (proc
))
3230 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3231 goto umwrongnumargs
;
3232 case scm_tcs_closures
:
3233 SCM_SET_ARGSREADY (debug
);
3234 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3237 x
= SCM_CLOSURE_BODY (proc
);
3238 goto nontoplevel_begin
;
3240 case scm_tc7_subr_3
:
3241 if (!SCM_NULLP (SCM_CDR (x
)))
3242 scm_wrong_num_args (proc
);
3244 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3246 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3249 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3252 while (SCM_NIMP (x
));
3254 case scm_tc7_rpsubr
:
3255 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3256 RETURN (SCM_BOOL_F
);
3259 arg1
= EVALCAR (x
, env
);
3260 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3261 RETURN (SCM_BOOL_F
);
3265 while (SCM_NIMP (x
));
3266 RETURN (SCM_BOOL_T
);
3267 case scm_tc7_lsubr_2
:
3268 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3270 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3272 scm_eval_args (x
, env
, proc
))));
3274 if (!SCM_SMOB_APPLICABLE_P (proc
))
3276 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3277 scm_eval_args (x
, env
, proc
)));
3281 proc
= SCM_PROCEDURE (proc
);
3282 if (!SCM_CLOSUREP (proc
))
3285 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3286 if (SCM_NULLP (formals
)
3287 || (SCM_CONSP (formals
)
3288 && (SCM_NULLP (SCM_CDR (formals
))
3289 || (SCM_CONSP (SCM_CDR (formals
))
3290 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3291 goto umwrongnumargs
;
3293 case scm_tcs_closures
:
3295 SCM_SET_ARGSREADY (debug
);
3297 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3300 scm_eval_args (x
, env
, proc
)),
3302 x
= SCM_CLOSURE_BODY (proc
);
3303 goto nontoplevel_begin
;
3305 case scm_tcs_struct
:
3306 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3309 arg1
= debug
.info
->a
.args
;
3311 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3313 x
= SCM_ENTITY_PROCEDURE (proc
);
3316 else if (!SCM_I_OPERATORP (proc
))
3320 case scm_tc7_subr_2
:
3321 case scm_tc7_subr_1o
:
3322 case scm_tc7_subr_2o
:
3323 case scm_tc7_subr_0
:
3325 case scm_tc7_subr_1
:
3326 scm_wrong_num_args (proc
);
3334 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3335 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3337 SCM_CLEAR_TRACED_FRAME (debug
);
3338 if (SCM_CHEAPTRAPS_P
)
3339 arg1
= scm_make_debugobj (&debug
);
3343 SCM val
= scm_make_continuation (&first
);
3354 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3358 scm_last_debug_frame
= debug
.prev
;
3364 /* SECTION: This code is compiled once.
3370 /* Simple procedure calls
3374 scm_call_0 (SCM proc
)
3376 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3380 scm_call_1 (SCM proc
, SCM arg1
)
3382 return scm_apply (proc
, arg1
, scm_listofnull
);
3386 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3388 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3392 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3394 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3398 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3400 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3401 scm_cons (arg4
, scm_listofnull
)));
3404 /* Simple procedure applies
3408 scm_apply_0 (SCM proc
, SCM args
)
3410 return scm_apply (proc
, args
, SCM_EOL
);
3414 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3416 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3420 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3422 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3426 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3428 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3432 /* This code processes the arguments to apply:
3434 (apply PROC ARG1 ... ARGS)
3436 Given a list (ARG1 ... ARGS), this function conses the ARG1
3437 ... arguments onto the front of ARGS, and returns the resulting
3438 list. Note that ARGS is a list; thus, the argument to this
3439 function is a list whose last element is a list.
3441 Apply calls this function, and applies PROC to the elements of the
3442 result. apply:nconc2last takes care of building the list of
3443 arguments, given (ARG1 ... ARGS).
3445 Rather than do new consing, apply:nconc2last destroys its argument.
3446 On that topic, this code came into my care with the following
3447 beautifully cryptic comment on that topic: "This will only screw
3448 you if you do (scm_apply scm_apply '( ... ))" If you know what
3449 they're referring to, send me a patch to this comment. */
3451 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3453 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3454 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3455 "@var{args}, and returns the resulting list. Note that\n"
3456 "@var{args} is a list; thus, the argument to this function is\n"
3457 "a list whose last element is a list.\n"
3458 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3459 "destroys its argument, so use with care.")
3460 #define FUNC_NAME s_scm_nconc2last
3463 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3465 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3466 SCM_NULL_OR_NIL_P, but not
3467 needed in 99.99% of cases,
3468 and it could seriously hurt
3469 performance. - Neil */
3470 lloc
= SCM_CDRLOC (*lloc
);
3471 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3472 *lloc
= SCM_CAR (*lloc
);
3480 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3481 * It is compiled twice.
3486 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3492 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3497 /* Apply a function to a list of arguments.
3499 This function is exported to the Scheme level as taking two
3500 required arguments and a tail argument, as if it were:
3501 (lambda (proc arg1 . args) ...)
3502 Thus, if you just have a list of arguments to pass to a procedure,
3503 pass the list as ARG1, and '() for ARGS. If you have some fixed
3504 args, pass the first as ARG1, then cons any remaining fixed args
3505 onto the front of your argument list, and pass that as ARGS. */
3508 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3510 #ifdef DEBUG_EXTENSIONS
3512 scm_t_debug_frame debug
;
3513 scm_t_debug_info debug_vect_body
;
3514 debug
.prev
= scm_last_debug_frame
;
3515 debug
.status
= SCM_APPLYFRAME
;
3516 debug
.vect
= &debug_vect_body
;
3517 debug
.vect
[0].a
.proc
= proc
;
3518 debug
.vect
[0].a
.args
= SCM_EOL
;
3519 scm_last_debug_frame
= &debug
;
3522 return scm_dapply (proc
, arg1
, args
);
3526 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3528 /* If ARGS is the empty list, then we're calling apply with only two
3529 arguments --- ARG1 is the list of arguments for PROC. Whatever
3530 the case, futz with things so that ARG1 is the first argument to
3531 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3534 Setting the debug apply frame args this way is pretty messy.
3535 Perhaps we should store arg1 and args directly in the frame as
3536 received, and let scm_frame_arguments unpack them, because that's
3537 a relatively rare operation. This works for now; if the Guile
3538 developer archives are still around, see Mikael's post of
3540 if (SCM_NULLP (args
))
3542 if (SCM_NULLP (arg1
))
3544 arg1
= SCM_UNDEFINED
;
3546 debug
.vect
[0].a
.args
= SCM_EOL
;
3552 debug
.vect
[0].a
.args
= arg1
;
3554 args
= SCM_CDR (arg1
);
3555 arg1
= SCM_CAR (arg1
);
3560 args
= scm_nconc2last (args
);
3562 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3566 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3569 if (SCM_CHEAPTRAPS_P
)
3570 tmp
= scm_make_debugobj (&debug
);
3575 tmp
= scm_make_continuation (&first
);
3580 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3587 switch (SCM_TYP7 (proc
))
3589 case scm_tc7_subr_2o
:
3590 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3591 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3592 case scm_tc7_subr_2
:
3593 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3594 scm_wrong_num_args (proc
);
3595 args
= SCM_CAR (args
);
3596 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3597 case scm_tc7_subr_0
:
3598 if (!SCM_UNBNDP (arg1
))
3599 scm_wrong_num_args (proc
);
3601 RETURN (SCM_SUBRF (proc
) ());
3602 case scm_tc7_subr_1
:
3603 if (SCM_UNBNDP (arg1
))
3604 scm_wrong_num_args (proc
);
3605 case scm_tc7_subr_1o
:
3606 if (!SCM_NULLP (args
))
3607 scm_wrong_num_args (proc
);
3609 RETURN (SCM_SUBRF (proc
) (arg1
));
3611 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3612 scm_wrong_num_args (proc
);
3613 if (SCM_SUBRF (proc
))
3615 if (SCM_INUMP (arg1
))
3617 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3619 else if (SCM_REALP (arg1
))
3621 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3624 else if (SCM_BIGP (arg1
))
3625 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3627 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3628 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3630 proc
= SCM_SNAME (proc
);
3632 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3633 while ('c' != *--chrs
)
3635 SCM_ASSERT (SCM_CONSP (arg1
),
3636 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3637 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3641 case scm_tc7_subr_3
:
3642 if (SCM_NULLP (args
)
3643 || SCM_NULLP (SCM_CDR (args
))
3644 || !SCM_NULLP (SCM_CDDR (args
)))
3645 scm_wrong_num_args (proc
);
3647 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3650 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3652 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3654 case scm_tc7_lsubr_2
:
3655 if (!SCM_CONSP (args
))
3656 scm_wrong_num_args (proc
);
3658 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3660 if (SCM_NULLP (args
))
3661 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3662 while (SCM_NIMP (args
))
3664 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3665 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3666 args
= SCM_CDR (args
);
3669 case scm_tc7_rpsubr
:
3670 if (SCM_NULLP (args
))
3671 RETURN (SCM_BOOL_T
);
3672 while (SCM_NIMP (args
))
3674 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3675 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3676 RETURN (SCM_BOOL_F
);
3677 arg1
= SCM_CAR (args
);
3678 args
= SCM_CDR (args
);
3680 RETURN (SCM_BOOL_T
);
3681 case scm_tcs_closures
:
3683 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3685 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3687 #ifndef SCM_RECKLESS
3688 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3689 scm_wrong_num_args (proc
);
3692 /* Copy argument list */
3697 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3698 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3700 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3704 SCM_SETCDR (tl
, arg1
);
3707 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3708 proc
= SCM_CLOSURE_BODY (proc
);
3711 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3713 if (SCM_IMP (SCM_CAR (proc
)))
3715 if (SCM_ISYMP (SCM_CAR (proc
)))
3717 proc
= scm_m_expand_body (proc
, args
);
3721 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3724 SCM_CEVAL (SCM_CAR (proc
), args
);
3727 RETURN (EVALCAR (proc
, args
));
3729 if (!SCM_SMOB_APPLICABLE_P (proc
))
3731 if (SCM_UNBNDP (arg1
))
3732 RETURN (SCM_SMOB_APPLY_0 (proc
));
3733 else if (SCM_NULLP (args
))
3734 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3735 else if (SCM_NULLP (SCM_CDR (args
)))
3736 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3738 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3741 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3743 proc
= SCM_CCLO_SUBR (proc
);
3744 debug
.vect
[0].a
.proc
= proc
;
3745 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3747 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3749 proc
= SCM_CCLO_SUBR (proc
);
3753 proc
= SCM_PROCEDURE (proc
);
3755 debug
.vect
[0].a
.proc
= proc
;
3758 case scm_tcs_struct
:
3759 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3762 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3764 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3766 RETURN (scm_apply_generic (proc
, args
));
3768 else if (!SCM_I_OPERATORP (proc
))
3773 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3775 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3778 proc
= (SCM_I_ENTITYP (proc
)
3779 ? SCM_ENTITY_PROCEDURE (proc
)
3780 : SCM_OPERATOR_PROCEDURE (proc
));
3782 debug
.vect
[0].a
.proc
= proc
;
3783 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3785 if (SCM_NIMP (proc
))
3792 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3796 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3797 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3799 SCM_CLEAR_TRACED_FRAME (debug
);
3800 if (SCM_CHEAPTRAPS_P
)
3801 arg1
= scm_make_debugobj (&debug
);
3805 SCM val
= scm_make_continuation (&first
);
3816 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3820 scm_last_debug_frame
= debug
.prev
;
3826 /* SECTION: The rest of this file is only read once.
3831 /* Typechecking for multi-argument MAP and FOR-EACH.
3833 Verify that each element of the vector ARGV, except for the first,
3834 is a proper list whose length is LEN. Attribute errors to WHO,
3835 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3837 check_map_args (SCM argv
,
3844 SCM
*ve
= SCM_VELTS (argv
);
3847 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3849 long elt_len
= scm_ilength (ve
[i
]);
3854 scm_apply_generic (gf
, scm_cons (proc
, args
));
3856 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3860 scm_out_of_range (who
, ve
[i
]);
3863 scm_remember_upto_here_1 (argv
);
3867 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3869 /* Note: Currently, scm_map applies PROC to the argument list(s)
3870 sequentially, starting with the first element(s). This is used in
3871 evalext.c where the Scheme procedure `map-in-order', which guarantees
3872 sequential behaviour, is implemented using scm_map. If the
3873 behaviour changes, we need to update `map-in-order'.
3877 scm_map (SCM proc
, SCM arg1
, SCM args
)
3878 #define FUNC_NAME s_map
3883 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3885 len
= scm_ilength (arg1
);
3886 SCM_GASSERTn (len
>= 0,
3887 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3888 SCM_VALIDATE_REST_ARGUMENT (args
);
3889 if (SCM_NULLP (args
))
3891 while (SCM_NIMP (arg1
))
3893 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3894 pres
= SCM_CDRLOC (*pres
);
3895 arg1
= SCM_CDR (arg1
);
3899 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3900 ve
= SCM_VELTS (args
);
3901 #ifndef SCM_RECKLESS
3902 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3907 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3909 if (SCM_IMP (ve
[i
]))
3911 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3912 ve
[i
] = SCM_CDR (ve
[i
]);
3914 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3915 pres
= SCM_CDRLOC (*pres
);
3921 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3924 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3925 #define FUNC_NAME s_for_each
3927 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3929 len
= scm_ilength (arg1
);
3930 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3931 SCM_ARG2
, s_for_each
);
3932 SCM_VALIDATE_REST_ARGUMENT (args
);
3933 if (SCM_NULLP (args
))
3935 while (SCM_NIMP (arg1
))
3937 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3938 arg1
= SCM_CDR (arg1
);
3940 return SCM_UNSPECIFIED
;
3942 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3943 ve
= SCM_VELTS (args
);
3944 #ifndef SCM_RECKLESS
3945 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3950 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3952 if (SCM_IMP (ve
[i
]))
3953 return SCM_UNSPECIFIED
;
3954 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3955 ve
[i
] = SCM_CDR (ve
[i
]);
3957 scm_apply (proc
, arg1
, SCM_EOL
);
3964 scm_closure (SCM code
, SCM env
)
3967 SCM closcar
= scm_cons (code
, SCM_EOL
);
3968 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3969 scm_remember_upto_here (closcar
);
3974 scm_t_bits scm_tc16_promise
;
3977 scm_makprom (SCM code
)
3979 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3985 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3987 int writingp
= SCM_WRITINGP (pstate
);
3988 scm_puts ("#<promise ", port
);
3989 SCM_SET_WRITINGP (pstate
, 1);
3990 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3991 SCM_SET_WRITINGP (pstate
, writingp
);
3992 scm_putc ('>', port
);
3997 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3999 "If the promise @var{x} has not been computed yet, compute and\n"
4000 "return @var{x}, otherwise just return the previously computed\n"
4002 #define FUNC_NAME s_scm_force
4004 SCM_VALIDATE_SMOB (1, x
, promise
);
4005 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4007 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
4008 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
4011 SCM_SET_CELL_OBJECT_1 (x
, ans
);
4012 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
4016 return SCM_CELL_OBJECT_1 (x
);
4021 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
4023 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
4024 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
4025 #define FUNC_NAME s_scm_promise_p
4027 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
4032 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
4033 (SCM xorig
, SCM x
, SCM y
),
4034 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
4035 "Any source properties associated with @var{xorig} are also associated\n"
4036 "with the new pair.")
4037 #define FUNC_NAME s_scm_cons_source
4040 z
= scm_cons (x
, y
);
4041 /* Copy source properties possibly associated with xorig. */
4042 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4044 scm_whash_insert (scm_source_whash
, z
, p
);
4050 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4052 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4053 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4054 "contents of both pairs and vectors (since both cons cells and vector\n"
4055 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4056 "any other object.")
4057 #define FUNC_NAME s_scm_copy_tree
4062 if (SCM_VECTORP (obj
))
4064 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4065 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4067 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
4070 if (!SCM_CONSP (obj
))
4072 ans
= tl
= scm_cons_source (obj
,
4073 scm_copy_tree (SCM_CAR (obj
)),
4075 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4077 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4081 SCM_SETCDR (tl
, obj
);
4087 /* We have three levels of EVAL here:
4089 - scm_i_eval (exp, env)
4091 evaluates EXP in environment ENV. ENV is a lexical environment
4092 structure as used by the actual tree code evaluator. When ENV is
4093 a top-level environment, then changes to the current module are
4094 tracked by updating ENV so that it continues to be in sync with
4097 - scm_primitive_eval (exp)
4099 evaluates EXP in the top-level environment as determined by the
4100 current module. This is done by constructing a suitable
4101 environment and calling scm_i_eval. Thus, changes to the
4102 top-level module are tracked normally.
4104 - scm_eval (exp, mod)
4106 evaluates EXP while MOD is the current module. This is done by
4107 setting the current module to MOD, invoking scm_primitive_eval on
4108 EXP, and then restoring the current module to the value it had
4109 previously. That is, while EXP is evaluated, changes to the
4110 current module are tracked, but these changes do not persist when
4113 For each level of evals, there are two variants, distinguished by a
4114 _x suffix: the ordinary variant does not modify EXP while the _x
4115 variant can destructively modify EXP into something completely
4116 unintelligible. A Scheme data structure passed as EXP to one of the
4117 _x variants should not ever be used again for anything. So when in
4118 doubt, use the ordinary variant.
4123 scm_i_eval_x (SCM exp
, SCM env
)
4125 return SCM_XEVAL (exp
, env
);
4129 scm_i_eval (SCM exp
, SCM env
)
4131 exp
= scm_copy_tree (exp
);
4132 return SCM_XEVAL (exp
, env
);
4136 scm_primitive_eval_x (SCM exp
)
4139 SCM transformer
= scm_current_module_transformer ();
4140 if (SCM_NIMP (transformer
))
4141 exp
= scm_call_1 (transformer
, exp
);
4142 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4143 return scm_i_eval_x (exp
, env
);
4146 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4148 "Evaluate @var{exp} in the top-level environment specified by\n"
4149 "the current module.")
4150 #define FUNC_NAME s_scm_primitive_eval
4153 SCM transformer
= scm_current_module_transformer ();
4154 if (SCM_NIMP (transformer
))
4155 exp
= scm_call_1 (transformer
, exp
);
4156 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4157 return scm_i_eval (exp
, env
);
4161 /* Eval does not take the second arg optionally. This is intentional
4162 * in order to be R5RS compatible, and to prepare for the new module
4163 * system, where we would like to make the choice of evaluation
4164 * environment explicit. */
4167 change_environment (void *data
)
4169 SCM pair
= SCM_PACK (data
);
4170 SCM new_module
= SCM_CAR (pair
);
4171 SCM old_module
= scm_current_module ();
4172 SCM_SETCDR (pair
, old_module
);
4173 scm_set_current_module (new_module
);
4178 restore_environment (void *data
)
4180 SCM pair
= SCM_PACK (data
);
4181 SCM old_module
= SCM_CDR (pair
);
4182 SCM new_module
= scm_current_module ();
4183 SCM_SETCAR (pair
, new_module
);
4184 scm_set_current_module (old_module
);
4188 inner_eval_x (void *data
)
4190 return scm_primitive_eval_x (SCM_PACK(data
));
4194 scm_eval_x (SCM exp
, SCM module
)
4195 #define FUNC_NAME "eval!"
4197 SCM_VALIDATE_MODULE (2, module
);
4199 return scm_internal_dynamic_wind
4200 (change_environment
, inner_eval_x
, restore_environment
,
4201 (void *) SCM_UNPACK (exp
),
4202 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4207 inner_eval (void *data
)
4209 return scm_primitive_eval (SCM_PACK(data
));
4212 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4213 (SCM exp
, SCM module
),
4214 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4215 "in the top-level environment specified by @var{module}.\n"
4216 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4217 "@var{module} is made the current module. The current module\n"
4218 "is reset to its previous value when @var{eval} returns.")
4219 #define FUNC_NAME s_scm_eval
4221 SCM_VALIDATE_MODULE (2, module
);
4223 return scm_internal_dynamic_wind
4224 (change_environment
, inner_eval
, restore_environment
,
4225 (void *) SCM_UNPACK (exp
),
4226 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4231 /* At this point, scm_deval and scm_dapply are generated.
4234 #ifdef DEBUG_EXTENSIONS
4244 scm_init_opts (scm_evaluator_traps
,
4245 scm_evaluator_trap_table
,
4246 SCM_N_EVALUATOR_TRAPS
);
4247 scm_init_opts (scm_eval_options_interface
,
4249 SCM_N_EVAL_OPTIONS
);
4251 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4252 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4253 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4255 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4256 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4257 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4258 scm_listofnull
= scm_list_1 (SCM_EOL
);
4260 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4265 #include "libguile/eval.x"
4267 scm_add_feature ("delay");