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
156 scm_ilookup (SCM iloc
, SCM env
)
158 register long ir
= SCM_IFRAME (iloc
);
159 register SCM er
= env
;
160 for (; 0 != ir
; --ir
)
163 for (ir
= SCM_IDIST (iloc
); 0 != ir
; --ir
)
165 if (SCM_ICDRP (iloc
))
166 return SCM_CDRLOC (er
);
167 return SCM_CARLOC (SCM_CDR (er
));
172 /* The Lookup Car Race
175 Memoization of variables and special forms is done while executing
176 the code for the first time. As long as there is only one thread
177 everything is fine, but as soon as two threads execute the same
178 code concurrently `for the first time' they can come into conflict.
180 This memoization includes rewriting variable references into more
181 efficient forms and expanding macros. Furthermore, macro expansion
182 includes `compiling' special forms like `let', `cond', etc. into
183 tree-code instructions.
185 There shouldn't normally be a problem with memoizing local and
186 global variable references (into ilocs and variables), because all
187 threads will mutate the code in *exactly* the same way and (if I
188 read the C code correctly) it is not possible to observe a half-way
189 mutated cons cell. The lookup procedure can handle this
190 transparently without any critical sections.
192 It is different with macro expansion, because macro expansion
193 happens outside of the lookup procedure and can't be
194 undone. Therefore the lookup procedure can't cope with it. It has
195 to indicate failure when it detects a lost race and hope that the
196 caller can handle it. Luckily, it turns out that this is the case.
198 An example to illustrate this: Suppose that the following form will
199 be memoized concurrently by two threads
203 Let's first examine the lookup of X in the body. The first thread
204 decides that it has to find the symbol "x" in the environment and
205 starts to scan it. Then the other thread takes over and actually
206 overtakes the first. It looks up "x" and substitutes an
207 appropriate iloc for it. Now the first thread continues and
208 completes its lookup. It comes to exactly the same conclusions as
209 the second one and could - without much ado - just overwrite the
210 iloc with the same iloc.
212 But let's see what will happen when the race occurs while looking
213 up the symbol "let" at the start of the form. It could happen that
214 the second thread interrupts the lookup of the first thread and not
215 only substitutes a variable for it but goes right ahead and
216 replaces it with the compiled form (#@let* (x 12) x). Now, when
217 the first thread completes its lookup, it would replace the #@let*
218 with a variable containing the "let" binding, effectively reverting
219 the form to (let (x 12) x). This is wrong. It has to detect that
220 it has lost the race and the evaluator has to reconsider the
221 changed form completely.
223 This race condition could be resolved with some kind of traffic
224 light (like mutexes) around scm_lookupcar, but I think that it is
225 best to avoid them in this case. They would serialize memoization
226 completely and because lookup involves calling arbitrary Scheme
227 code (via the lookup-thunk), threads could be blocked for an
228 arbitrary amount of time or even deadlock. But with the current
229 solution a lot of unnecessary work is potentially done. */
231 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
232 return NULL to indicate a failed lookup due to some race conditions
233 between threads. This only happens when VLOC is the first cell of
234 a special form that will eventually be memoized (like `let', etc.)
235 In that case the whole lookup is bogus and the caller has to
236 reconsider the complete special form.
238 SCM_LOOKUPCAR is still there, of course. It just calls
239 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
240 should only be called when it is known that VLOC is not the first
241 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
242 for NULL. I think I've found the only places where this
245 #endif /* USE_THREADS */
247 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
251 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
254 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
258 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
259 register SCM iloc
= SCM_ILOC00
;
260 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
262 if (!SCM_CONSP (SCM_CAR (env
)))
264 al
= SCM_CARLOC (env
);
265 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
269 if (SCM_EQ_P (fl
, var
))
272 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
275 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
276 return SCM_CDRLOC (*al
);
281 al
= SCM_CDRLOC (*al
);
282 if (SCM_EQ_P (SCM_CAR (fl
), var
))
284 if (SCM_UNBNDP (SCM_CAR (*al
)))
290 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
293 SCM_SETCAR (vloc
, iloc
);
294 return SCM_CARLOC (*al
);
296 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
298 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
301 SCM top_thunk
, real_var
;
304 top_thunk
= SCM_CAR (env
); /* env now refers to a
305 top level env thunk */
309 top_thunk
= SCM_BOOL_F
;
310 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
311 if (SCM_FALSEP (real_var
))
314 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
320 scm_error (scm_unbound_variable_key
, NULL
,
321 "Unbound variable: ~S",
322 scm_list_1 (var
), SCM_BOOL_F
);
324 scm_misc_error (NULL
, "Damaged environment: ~S",
329 /* A variable could not be found, but we shall
330 not throw an error. */
331 static SCM undef_object
= SCM_UNDEFINED
;
332 return &undef_object
;
337 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
339 /* Some other thread has changed the very cell we are working
340 on. In effect, it must have done our job or messed it up
343 var
= SCM_CAR (vloc
);
344 if (SCM_VARIABLEP (var
))
345 return SCM_VARIABLE_LOC (var
);
346 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
347 return scm_ilookup (var
, genv
);
348 /* We can't cope with anything else than variables and ilocs. When
349 a special form has been memoized (i.e. `let' into `#@let') we
350 return NULL and expect the calling function to do the right
351 thing. For the evaluator, this means going back and redoing
352 the dispatch on the car of the form. */
355 #endif /* USE_THREADS */
357 SCM_SETCAR (vloc
, real_var
);
358 return SCM_VARIABLE_LOC (real_var
);
364 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
366 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
373 #define unmemocar scm_unmemocar
375 SCM_SYMBOL (sym_three_question_marks
, "???");
378 scm_unmemocar (SCM form
, SCM env
)
380 if (!SCM_CONSP (form
))
384 SCM c
= SCM_CAR (form
);
385 if (SCM_VARIABLEP (c
))
387 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
388 if (SCM_FALSEP (sym
))
389 sym
= sym_three_question_marks
;
390 SCM_SETCAR (form
, sym
);
392 else if (SCM_ILOCP (c
))
394 unsigned long int ir
;
396 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
398 env
= SCM_CAAR (env
);
399 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
401 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
409 scm_eval_car (SCM pair
, SCM env
)
411 return SCM_XEVALCAR (pair
, env
);
416 * The following rewrite expressions and
417 * some memoized forms have different syntax
420 const char scm_s_expression
[] = "missing or extra expression";
421 const char scm_s_test
[] = "bad test";
422 const char scm_s_body
[] = "bad body";
423 const char scm_s_bindings
[] = "bad bindings";
424 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
425 const char scm_s_variable
[] = "bad variable";
426 const char scm_s_clauses
[] = "bad or missing clauses";
427 const char scm_s_formals
[] = "bad formals";
428 const char scm_s_duplicate_formals
[] = "duplicate formals";
429 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
431 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
432 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
433 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
434 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
435 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
439 #ifdef DEBUG_EXTENSIONS
440 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
441 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
442 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
443 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
447 /* Check that the body denoted by XORIG is valid and rewrite it into
448 its internal form. The internal form of a body is just the body
449 itself, but prefixed with an ISYM that denotes to what kind of
450 outer construct this body belongs. A lambda body starts with
451 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
452 etc. The one exception is a body that belongs to a letrec that has
453 been formed by rewriting internal defines: it starts with
456 /* XXX - Besides controlling the rewriting of internal defines, the
457 additional ISYM could be used for improved error messages.
458 This is not done yet. */
461 scm_m_body (SCM op
, SCM xorig
, const char *what
)
463 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
465 /* Don't add another ISYM if one is present already. */
466 if (SCM_ISYMP (SCM_CAR (xorig
)))
469 /* Retain possible doc string. */
470 if (!SCM_CONSP (SCM_CAR (xorig
)))
472 if (!SCM_NULLP (SCM_CDR (xorig
)))
473 return scm_cons (SCM_CAR (xorig
),
474 scm_m_body (op
, SCM_CDR (xorig
), what
));
478 return scm_cons (op
, xorig
);
482 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
483 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
486 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
488 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
489 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
493 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
494 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
497 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
499 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
500 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
504 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
505 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
508 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
510 long len
= scm_ilength (SCM_CDR (xorig
));
511 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
512 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
516 /* Will go into the RnRS module when Guile is factorized.
517 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
518 const char scm_s_set_x
[] = "set!";
519 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
522 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
524 SCM x
= SCM_CDR (xorig
);
525 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
526 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
527 return scm_cons (SCM_IM_SET_X
, x
);
531 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
532 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
535 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
537 long len
= scm_ilength (SCM_CDR (xorig
));
538 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
540 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
546 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
547 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
550 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
552 long len
= scm_ilength (SCM_CDR (xorig
));
553 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
555 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
561 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
562 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
565 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
568 SCM cdrx
= SCM_CDR (xorig
);
569 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
570 clauses
= SCM_CDR (cdrx
);
571 while (!SCM_NULLP (clauses
))
573 SCM clause
= SCM_CAR (clauses
);
574 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
575 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
576 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
577 && SCM_NULLP (SCM_CDR (clauses
))),
578 scm_s_clauses
, s_case
);
579 clauses
= SCM_CDR (clauses
);
581 return scm_cons (SCM_IM_CASE
, cdrx
);
585 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
586 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
589 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
591 SCM cdrx
= SCM_CDR (xorig
);
593 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
594 while (!SCM_NULLP (clauses
))
596 SCM clause
= SCM_CAR (clauses
);
597 long len
= scm_ilength (clause
);
598 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
599 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
601 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
602 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
604 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
606 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
607 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
609 clauses
= SCM_CDR (clauses
);
611 return scm_cons (SCM_IM_COND
, cdrx
);
615 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
616 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
618 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
619 * cdr of the last cons. (Thus, LIST is not required to be a proper
620 * list and OBJ can also be found in the improper ending.) */
622 scm_c_improper_memq (SCM obj
, SCM list
)
624 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
626 if (SCM_EQ_P (SCM_CAR (list
), obj
))
629 return SCM_EQ_P (list
, obj
);
633 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
636 SCM x
= SCM_CDR (xorig
);
638 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
640 formals
= SCM_CAR (x
);
641 while (SCM_CONSP (formals
))
643 SCM formal
= SCM_CAR (formals
);
644 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
645 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
646 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
647 formals
= SCM_CDR (formals
);
649 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
650 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
652 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
653 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
657 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
658 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
660 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
661 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
663 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
666 SCM x
= SCM_CDR (xorig
);
670 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
672 bindings
= SCM_CAR (x
);
673 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
674 while (!SCM_NULLP (bindings
))
676 SCM binding
= SCM_CAR (bindings
);
677 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
678 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
679 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
680 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
681 bindings
= SCM_CDR (bindings
);
684 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
685 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
689 /* DO gets the most radically altered syntax. The order of the vars is
690 * reversed here. In contrast, the order of the inits and steps is reversed
691 * during the evaluation:
693 (do ((<var1> <init1> <step1>)
701 (#@do (varn ... var2 var1)
702 (<init1> <init2> ... <initn>)
705 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
708 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
709 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
712 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
715 SCM x
= SCM_CDR (xorig
);
718 SCM
*initloc
= &inits
;
720 SCM
*steploc
= &steps
;
721 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
722 bindings
= SCM_CAR (x
);
723 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
724 while (!SCM_NULLP (bindings
))
726 SCM binding
= SCM_CAR (bindings
);
727 long len
= scm_ilength (binding
);
728 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
730 SCM name
= SCM_CAR (binding
);
731 SCM init
= SCM_CADR (binding
);
732 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
733 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
734 vars
= scm_cons (name
, vars
);
735 *initloc
= scm_list_1 (init
);
736 initloc
= SCM_CDRLOC (*initloc
);
737 *steploc
= scm_list_1 (step
);
738 steploc
= SCM_CDRLOC (*steploc
);
739 bindings
= SCM_CDR (bindings
);
743 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
744 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
745 x
= scm_cons2 (vars
, inits
, x
);
746 return scm_cons (SCM_IM_DO
, x
);
750 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
751 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
753 /* Internal function to handle a quasiquotation: 'form' is the parameter in
754 * the call (quasiquotation form), 'env' is the environment where unquoted
755 * expressions will be evaluated, and 'depth' is the current quasiquotation
756 * nesting level and is known to be greater than zero. */
758 iqq (SCM form
, SCM env
, unsigned long int depth
)
760 if (SCM_CONSP (form
))
762 SCM tmp
= SCM_CAR (form
);
763 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
765 SCM args
= SCM_CDR (form
);
766 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
767 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
769 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
771 SCM args
= SCM_CDR (form
);
772 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
774 return scm_eval_car (args
, env
);
776 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
778 else if (SCM_CONSP (tmp
)
779 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
781 SCM args
= SCM_CDR (tmp
);
782 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
785 SCM list
= scm_eval_car (args
, env
);
786 SCM rest
= SCM_CDR (form
);
787 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
788 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
791 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
792 iqq (SCM_CDR (form
), env
, depth
));
795 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
796 iqq (SCM_CDR (form
), env
, depth
));
798 else if (SCM_VECTORP (form
))
800 size_t i
= SCM_VECTOR_LENGTH (form
);
801 SCM
*data
= SCM_VELTS (form
);
804 tmp
= scm_cons (data
[--i
], tmp
);
805 scm_remember_upto_here_1 (form
);
806 return scm_vector (iqq (tmp
, env
, depth
));
813 scm_m_quasiquote (SCM xorig
, SCM env
)
815 SCM x
= SCM_CDR (xorig
);
816 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
817 return iqq (SCM_CAR (x
), env
, 1);
821 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
822 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
824 /* Promises are implemented as closures with an empty parameter list. Thus,
825 * (delay <expression>) is transformed into (#@delay '() <expression>), where
826 * the empty list represents the empty parameter list. This representation
827 * allows for easy creation of the closure during evaluation. */
829 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
831 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
832 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
836 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
837 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
839 /* Guile provides an extension to R5RS' define syntax to represent function
840 * currying in a compact way. With this extension, it is allowed to write
841 * (define <nested-variable> <body>), where <nested-variable> has of one of
842 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
843 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
844 * should be either a sequence of zero or more variables, or a sequence of one
845 * or more variables followed by a space-delimited period and another
846 * variable. Each level of argument nesting wraps the <body> within another
847 * lambda expression. For example, the following forms are allowed, each one
848 * followed by an equivalent, more explicit implementation.
850 * (define ((a b . c) . d) <body>) is equivalent to
851 * (define a (lambda (b . c) (lambda d <body>)))
853 * (define (((a) b) c . d) <body>) is equivalent to
854 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
856 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
857 * module that does not implement this extension. */
859 scm_m_define (SCM x
, SCM env
)
863 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
866 while (SCM_CONSP (name
))
868 /* This while loop realizes function currying by variable nesting. */
869 SCM formals
= SCM_CDR (name
);
870 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
871 name
= SCM_CAR (name
);
873 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
874 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
875 if (SCM_TOP_LEVEL (env
))
878 x
= scm_eval_car (x
, env
);
879 if (SCM_REC_PROCNAMES_P
)
882 while (SCM_MACROP (tmp
))
883 tmp
= SCM_MACRO_CODE (tmp
);
884 if (SCM_CLOSUREP (tmp
)
885 /* Only the first definition determines the name. */
886 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
887 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
889 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
890 SCM_VARIABLE_SET (var
, x
);
891 return SCM_UNSPECIFIED
;
894 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
898 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
899 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
900 * reversed here, the list of inits gets reversed during evaluation. */
902 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
908 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
912 SCM binding
= SCM_CAR (bindings
);
913 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
914 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
915 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
916 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
917 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
918 *initloc
= scm_list_1 (SCM_CADR (binding
));
919 initloc
= SCM_CDRLOC (*initloc
);
920 bindings
= SCM_CDR (bindings
);
922 while (!SCM_NULLP (bindings
));
928 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
929 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
932 scm_m_letrec (SCM xorig
, SCM env
)
934 SCM x
= SCM_CDR (xorig
);
935 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
937 if (SCM_NULLP (SCM_CAR (x
)))
939 /* null binding, let* faster */
940 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
941 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
945 SCM rvars
, inits
, body
;
946 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
947 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
948 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
953 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
954 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
957 scm_m_let (SCM xorig
, SCM env
)
959 SCM x
= SCM_CDR (xorig
);
962 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
965 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
967 /* null or single binding, let* is faster */
969 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
970 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
972 else if (SCM_CONSP (temp
))
976 SCM rvars
, inits
, body
;
977 transform_bindings (bindings
, &rvars
, &inits
, "let");
978 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
979 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
983 /* named let: Transform (let name ((var init) ...) body ...) into
984 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
990 SCM
*initloc
= &inits
;
993 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
995 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
996 bindings
= SCM_CAR (x
);
997 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
998 while (!SCM_NULLP (bindings
))
999 { /* vars and inits both in order */
1000 SCM binding
= SCM_CAR (bindings
);
1001 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
1002 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
1003 *varloc
= scm_list_1 (SCM_CAR (binding
));
1004 varloc
= SCM_CDRLOC (*varloc
);
1005 *initloc
= scm_list_1 (SCM_CADR (binding
));
1006 initloc
= SCM_CDRLOC (*initloc
);
1007 bindings
= SCM_CDR (bindings
);
1011 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
1012 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
1013 SCM rvar
= scm_list_1 (name
);
1014 SCM init
= scm_list_1 (lambda_form
);
1015 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
1016 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1017 return scm_cons (letrec
, inits
);
1023 SCM_SYNTAX (s_atapply
,"@apply", scm_makmmacro
, scm_m_apply
);
1024 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1025 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1028 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1030 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1031 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1035 SCM_SYNTAX(s_atcall_cc
,"@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1036 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
,s_atcall_cc
);
1040 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1042 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1043 scm_s_expression
, s_atcall_cc
);
1044 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1047 #ifdef SCM_ENABLE_ELISP
1049 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1052 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1054 long len
= scm_ilength (SCM_CDR (xorig
));
1055 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1056 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1059 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1062 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1064 SCM x
= SCM_CDR (xorig
), var
;
1065 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1066 var
= scm_symbol_fref (SCM_CAR (x
));
1067 /* Passing the symbol name as the `subr' arg here isn't really
1068 right, but without it it can be very difficult to work out from
1069 the error message which function definition was missing. In any
1070 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1071 something equivalent to (signal void-function (list SYM)) in
1073 SCM_ASSYNT (SCM_VARIABLEP (var
),
1074 "Symbol's function definition is void",
1075 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1076 /* Support `defalias'. */
1077 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1079 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1080 SCM_ASSYNT (SCM_VARIABLEP (var
),
1081 "Symbol's function definition is void",
1082 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1084 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1085 former allows for automatically picking up redefinitions of the
1086 corresponding symbol. */
1087 SCM_SETCAR (x
, var
);
1088 /* If the variable contains a procedure, leave the
1089 `transformer-macro' in place so that the procedure's arguments
1090 get properly transformed, and change the initial @fop to
1092 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1094 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1097 /* Otherwise (the variable contains a macro), the arguments should
1098 not be transformed, so cut the `transformer-macro' out and return
1099 the resulting expression starting with the variable. */
1100 SCM_SETCDR (x
, SCM_CDADR (x
));
1104 #endif /* SCM_ENABLE_ELISP */
1106 /* (@bind ((var exp) ...) body ...)
1108 This will assign the values of the `exp's to the global variables
1109 named by `var's (symbols, not evaluated), creating them if they
1110 don't exist, executes body, and then restores the previous values of
1111 the `var's. Additionally, whenever control leaves body, the values
1112 of the `var's are saved and restored when control returns. It is an
1113 error when a symbol appears more than once among the `var's.
1114 All `exp's are evaluated before any `var' is set.
1116 Think of this as `let' for dynamic scope.
1118 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1120 XXX - also implement `@bind*'.
1123 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1126 scm_m_atbind (SCM xorig
, SCM env
)
1128 SCM x
= SCM_CDR (xorig
);
1129 SCM top_level
= scm_env_top_level (env
);
1130 SCM vars
= SCM_EOL
, var
;
1133 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1136 while (SCM_NIMP (x
))
1139 SCM sym_exp
= SCM_CAR (x
);
1140 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1141 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1143 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1144 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1145 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1146 /* The first call to scm_sym2var will look beyond the current
1147 module, while the second call wont. */
1148 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1149 if (SCM_FALSEP (var
))
1150 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1151 vars
= scm_cons (var
, vars
);
1152 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1154 return scm_cons (SCM_IM_BIND
,
1155 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1159 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1160 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1163 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1165 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1166 scm_s_expression
, s_at_call_with_values
);
1167 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1171 scm_m_expand_body (SCM xorig
, SCM env
)
1173 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1174 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1176 while (SCM_NIMP (x
))
1178 SCM form
= SCM_CAR (x
);
1179 if (!SCM_CONSP (form
))
1181 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1184 form
= scm_macroexp (scm_cons_source (form
,
1189 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1191 defs
= scm_cons (SCM_CDR (form
), defs
);
1194 else if (!SCM_IMP (defs
))
1198 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1200 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1204 x
= scm_cons (form
, SCM_CDR (x
));
1209 if (!SCM_NULLP (defs
))
1211 SCM rvars
, inits
, body
, letrec
;
1212 transform_bindings (defs
, &rvars
, &inits
, what
);
1213 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1214 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1215 SCM_SETCAR (xorig
, letrec
);
1216 SCM_SETCDR (xorig
, SCM_EOL
);
1220 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1221 SCM_SETCAR (xorig
, SCM_CAR (x
));
1222 SCM_SETCDR (xorig
, SCM_CDR (x
));
1229 scm_macroexp (SCM x
, SCM env
)
1231 SCM res
, proc
, orig_sym
;
1233 /* Don't bother to produce error messages here. We get them when we
1234 eventually execute the code for real. */
1237 orig_sym
= SCM_CAR (x
);
1238 if (!SCM_SYMBOLP (orig_sym
))
1243 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1244 if (proc_ptr
== NULL
)
1246 /* We have lost the race. */
1252 proc
= *scm_lookupcar (x
, env
, 0);
1255 /* Only handle memoizing macros. `Acros' and `macros' are really
1256 special forms and should not be evaluated here. */
1258 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1261 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1262 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1264 if (scm_ilength (res
) <= 0)
1265 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1268 SCM_SETCAR (x
, SCM_CAR (res
));
1269 SCM_SETCDR (x
, SCM_CDR (res
));
1275 /* scm_unmemocopy takes a memoized expression together with its
1276 * environment and rewrites it to its original form. Thus, it is the
1277 * inversion of the rewrite rules above. The procedure is not
1278 * optimized for speed. It's used in scm_iprin1 when printing the
1279 * code of a closure, in scm_procedure_source, in display_frame when
1280 * generating the source for a stackframe in a backtrace, and in
1281 * display_expression.
1283 * Unmemoizing is not a reliable process. You cannot in general
1284 * expect to get the original source back.
1286 * However, GOOPS currently relies on this for method compilation.
1287 * This ought to change.
1290 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1293 build_binding_list (SCM names
, SCM inits
)
1295 SCM bindings
= SCM_EOL
;
1296 while (!SCM_NULLP (names
))
1298 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1299 bindings
= scm_cons (binding
, bindings
);
1300 names
= SCM_CDR (names
);
1301 inits
= SCM_CDR (inits
);
1307 unmemocopy (SCM x
, SCM env
)
1310 #ifdef DEBUG_EXTENSIONS
1315 #ifdef DEBUG_EXTENSIONS
1316 p
= scm_whash_lookup (scm_source_whash
, x
);
1318 switch (SCM_ITAG7 (SCM_CAR (x
)))
1320 case SCM_BIT8(SCM_IM_AND
):
1321 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1323 case SCM_BIT8(SCM_IM_BEGIN
):
1324 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1326 case SCM_BIT8(SCM_IM_CASE
):
1327 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1329 case SCM_BIT8(SCM_IM_COND
):
1330 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1332 case SCM_BIT8 (SCM_IM_DO
):
1334 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1335 * where nx is the name of a local variable, ix is an initializer for
1336 * the local variable, test is the test clause of the do loop, body is
1337 * the body of the do loop and sx are the step clauses for the local
1339 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1342 names
= SCM_CAR (x
);
1344 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1345 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1347 test
= unmemocopy (SCM_CAR (x
), env
);
1349 memoized_body
= SCM_CAR (x
);
1351 steps
= scm_reverse (unmemocopy (x
, env
));
1353 /* build transformed binding list */
1355 while (!SCM_NULLP (names
))
1357 SCM name
= SCM_CAR (names
);
1358 SCM init
= SCM_CAR (inits
);
1359 SCM step
= SCM_CAR (steps
);
1360 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1362 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1364 names
= SCM_CDR (names
);
1365 inits
= SCM_CDR (inits
);
1366 steps
= SCM_CDR (steps
);
1368 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1369 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1371 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1374 case SCM_BIT8(SCM_IM_IF
):
1375 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1377 case SCM_BIT8 (SCM_IM_LET
):
1379 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1380 * where nx is the name of a local variable, ix is an initializer for
1381 * the local variable and by are the body clauses. */
1382 SCM names
, inits
, bindings
;
1385 names
= SCM_CAR (x
);
1387 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1388 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1390 bindings
= build_binding_list (names
, inits
);
1391 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1392 ls
= scm_cons (scm_sym_let
, z
);
1395 case SCM_BIT8 (SCM_IM_LETREC
):
1397 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1398 * where nx is the name of a local variable, ix is an initializer for
1399 * the local variable and by are the body clauses. */
1400 SCM names
, inits
, bindings
;
1403 names
= SCM_CAR (x
);
1404 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1406 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1408 bindings
= build_binding_list (names
, inits
);
1409 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1410 ls
= scm_cons (scm_sym_letrec
, z
);
1413 case SCM_BIT8(SCM_IM_LETSTAR
):
1421 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1424 y
= z
= scm_acons (SCM_CAR (b
),
1426 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1428 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1432 SCM_SETCDR (y
, SCM_EOL
);
1433 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1438 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1440 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1443 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1446 while (SCM_NIMP (b
));
1447 SCM_SETCDR (z
, SCM_EOL
);
1449 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1452 case SCM_BIT8(SCM_IM_OR
):
1453 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1455 case SCM_BIT8(SCM_IM_LAMBDA
):
1457 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1458 ls
= scm_cons (scm_sym_lambda
, z
);
1459 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1461 case SCM_BIT8(SCM_IM_QUOTE
):
1462 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1464 case SCM_BIT8(SCM_IM_SET_X
):
1465 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1467 case SCM_BIT8(SCM_IM_DEFINE
):
1472 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1473 ls
= scm_cons (scm_sym_define
, z
);
1474 if (!SCM_NULLP (env
))
1475 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1480 case SCM_BIT8(SCM_MAKISYM (0)):
1484 switch (SCM_ISYMNUM (z
))
1486 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1487 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1489 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1490 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1492 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1493 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1496 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1497 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1500 /* appease the Sun compiler god: */ ;
1504 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1510 while (SCM_CONSP (x
))
1512 SCM form
= SCM_CAR (x
);
1513 if (!SCM_ISYMP (form
))
1515 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1516 SCM_SETCDR (z
, unmemocar (copy
, env
));
1522 #ifdef DEBUG_EXTENSIONS
1523 if (!SCM_FALSEP (p
))
1524 scm_whash_insert (scm_source_whash
, ls
, p
);
1531 scm_unmemocopy (SCM x
, SCM env
)
1533 if (!SCM_NULLP (env
))
1534 /* Make a copy of the lowest frame to protect it from
1535 modifications by SCM_IM_DEFINE */
1536 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1538 return unmemocopy (x
, env
);
1543 scm_badargsp (SCM formals
, SCM args
)
1545 while (!SCM_NULLP (formals
))
1547 if (!SCM_CONSP (formals
))
1549 if (SCM_NULLP (args
))
1551 formals
= SCM_CDR (formals
);
1552 args
= SCM_CDR (args
);
1554 return !SCM_NULLP (args
) ? 1 : 0;
1559 scm_badformalsp (SCM closure
, int n
)
1561 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1562 while (!SCM_NULLP (formals
))
1564 if (!SCM_CONSP (formals
))
1569 formals
= SCM_CDR (formals
);
1576 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1578 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1579 while (SCM_CONSP (l
))
1581 res
= EVALCAR (l
, env
);
1583 *lloc
= scm_list_1 (res
);
1584 lloc
= SCM_CDRLOC (*lloc
);
1588 scm_wrong_num_args (proc
);
1593 scm_eval_body (SCM code
, SCM env
)
1597 next
= SCM_CDR (code
);
1598 while (!SCM_NULLP (next
))
1600 if (SCM_IMP (SCM_CAR (code
)))
1602 if (SCM_ISYMP (SCM_CAR (code
)))
1604 code
= scm_m_expand_body (code
, env
);
1609 SCM_XEVAL (SCM_CAR (code
), env
);
1611 next
= SCM_CDR (code
);
1613 return SCM_XEVALCAR (code
, env
);
1620 /* SECTION: This code is specific for the debugging support. One
1621 * branch is read when DEVAL isn't defined, the other when DEVAL is
1627 #define SCM_APPLY scm_apply
1628 #define PREP_APPLY(proc, args)
1630 #define RETURN(x) do { return x; } while (0)
1631 #ifdef STACK_CHECKING
1632 #ifndef NO_CEVAL_STACK_CHECKING
1633 #define EVAL_STACK_CHECKING
1640 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1642 #define SCM_APPLY scm_dapply
1644 #define PREP_APPLY(p, l) \
1645 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1647 #define ENTER_APPLY \
1649 SCM_SET_ARGSREADY (debug);\
1650 if (scm_check_apply_p && SCM_TRAPS_P)\
1651 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1653 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1654 SCM_SET_TRACED_FRAME (debug); \
1656 if (SCM_CHEAPTRAPS_P)\
1658 tmp = scm_make_debugobj (&debug);\
1659 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1664 tmp = scm_make_continuation (&first);\
1666 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1672 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1673 #ifdef STACK_CHECKING
1674 #ifndef EVAL_STACK_CHECKING
1675 #define EVAL_STACK_CHECKING
1679 /* scm_ceval_ptr points to the currently selected evaluator.
1680 * *fixme*: Although efficiency is important here, this state variable
1681 * should probably not be a global. It should be related to the
1686 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1688 /* scm_last_debug_frame contains a pointer to the last debugging
1689 * information stack frame. It is accessed very often from the
1690 * debugging evaluator, so it should probably not be indirectly
1691 * addressed. Better to save and restore it from the current root at
1696 scm_t_debug_frame
*scm_last_debug_frame
;
1699 /* scm_debug_eframe_size is the number of slots available for pseudo
1700 * stack frames at each real stack frame.
1703 long scm_debug_eframe_size
;
1705 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1707 long scm_eval_stack
;
1709 scm_t_option scm_eval_opts
[] = {
1710 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1713 scm_t_option scm_debug_opts
[] = {
1714 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1715 "*Flyweight representation of the stack at traps." },
1716 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1717 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1718 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1719 "Record procedure names at definition." },
1720 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1721 "Display backtrace in anti-chronological order." },
1722 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1723 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1724 { SCM_OPTION_INTEGER
, "frames", 3,
1725 "Maximum number of tail-recursive frames in backtrace." },
1726 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1727 "Maximal number of stored backtrace frames." },
1728 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1729 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1730 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1731 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1732 { 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."}
1735 scm_t_option scm_evaluator_trap_table
[] = {
1736 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1737 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1738 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1739 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1740 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1741 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1742 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1745 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1747 "Option interface for the evaluation options. Instead of using\n"
1748 "this procedure directly, use the procedures @code{eval-enable},\n"
1749 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1750 #define FUNC_NAME s_scm_eval_options_interface
1754 ans
= scm_options (setting
,
1758 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1764 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1766 "Option interface for the evaluator trap options.")
1767 #define FUNC_NAME s_scm_evaluator_traps
1771 ans
= scm_options (setting
,
1772 scm_evaluator_trap_table
,
1773 SCM_N_EVALUATOR_TRAPS
,
1775 SCM_RESET_DEBUG_MODE
;
1782 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1784 SCM
*results
= lloc
, res
;
1785 while (SCM_CONSP (l
))
1787 res
= EVALCAR (l
, env
);
1789 *lloc
= scm_list_1 (res
);
1790 lloc
= SCM_CDRLOC (*lloc
);
1794 scm_wrong_num_args (proc
);
1801 /* SECTION: This code is compiled twice.
1805 /* Update the toplevel environment frame ENV so that it refers to the
1806 * current module. */
1807 #define UPDATE_TOPLEVEL_ENV(env) \
1809 SCM p = scm_current_module_lookup_closure (); \
1810 if (p != SCM_CAR(env)) \
1811 env = scm_top_level_env (p); \
1815 /* This is the evaluator. Like any real monster, it has three heads:
1817 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1818 * version. Both are implemented using a common code base, using the
1819 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1820 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1821 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1822 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1823 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1824 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1825 * are enclosed within #ifdef DEVAL ... #endif.
1827 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1828 * take two input parameters, x and env: x is a single expression to be
1829 * evalutated. env is the environment in which bindings are searched.
1831 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1832 * is a single expression, it is necessarily in a tail position. If x is just
1833 * a call to another function like in the expression (foo exp1 exp2 ...), the
1834 * realization of that call therefore _must_not_ increase stack usage (the
1835 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1836 * making extensive use of 'goto' statements within the evaluator: The gotos
1837 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1838 * that SCM_CEVAL was already using. If, however, x represents some form that
1839 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1840 * then recursive calls to SCM_CEVAL are performed for all but the last
1841 * expression of that sequence. */
1845 scm_ceval (SCM x
, SCM env
)
1851 scm_deval (SCM x
, SCM env
)
1856 SCM_CEVAL (SCM x
, SCM env
)
1860 scm_t_debug_frame debug
;
1861 scm_t_debug_info
*debug_info_end
;
1862 debug
.prev
= scm_last_debug_frame
;
1865 * The debug.vect contains twice as much scm_t_debug_info frames as the
1866 * user has specified with (debug-set! frames <n>).
1868 * Even frames are eval frames, odd frames are apply frames.
1870 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1871 * sizeof (scm_t_debug_info
));
1872 debug
.info
= debug
.vect
;
1873 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1874 scm_last_debug_frame
= &debug
;
1876 #ifdef EVAL_STACK_CHECKING
1877 if (scm_stack_checking_enabled_p
1878 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1881 debug
.info
->e
.exp
= x
;
1882 debug
.info
->e
.env
= env
;
1884 scm_report_stack_overflow ();
1894 SCM_CLEAR_ARGSREADY (debug
);
1895 if (SCM_OVERFLOWP (debug
))
1898 * In theory, this should be the only place where it is necessary to
1899 * check for space in debug.vect since both eval frames and
1900 * available space are even.
1902 * For this to be the case, however, it is necessary that primitive
1903 * special forms which jump back to `loop', `begin' or some similar
1904 * label call PREP_APPLY.
1906 else if (++debug
.info
>= debug_info_end
)
1908 SCM_SET_OVERFLOW (debug
);
1913 debug
.info
->e
.exp
= x
;
1914 debug
.info
->e
.env
= env
;
1915 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1917 if (SCM_ENTER_FRAME_P
1918 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1921 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1922 SCM_SET_TAILREC (debug
);
1923 if (SCM_CHEAPTRAPS_P
)
1924 stackrep
= scm_make_debugobj (&debug
);
1928 SCM val
= scm_make_continuation (&first
);
1938 /* This gives the possibility for the debugger to
1939 modify the source expression before evaluation. */
1944 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1945 scm_sym_enter_frame
,
1948 scm_unmemocopy (x
, env
));
1953 #if defined (USE_THREADS) || defined (DEVAL)
1957 switch (SCM_TYP7 (x
))
1959 case scm_tc7_symbol
:
1960 /* Only happens when called at top level. */
1961 x
= scm_cons (x
, SCM_UNDEFINED
);
1962 RETURN (*scm_lookupcar (x
, env
, 1));
1964 case SCM_BIT8 (SCM_IM_AND
):
1966 while (!SCM_NULLP (SCM_CDR (x
)))
1968 SCM test_result
= EVALCAR (x
, env
);
1969 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1970 RETURN (SCM_BOOL_F
);
1974 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1977 case SCM_BIT8 (SCM_IM_BEGIN
):
1980 RETURN (SCM_UNSPECIFIED
);
1982 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1985 /* If we are on toplevel with a lookup closure, we need to sync
1986 with the current module. */
1987 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1989 UPDATE_TOPLEVEL_ENV (env
);
1990 while (!SCM_NULLP (SCM_CDR (x
)))
1993 UPDATE_TOPLEVEL_ENV (env
);
1999 goto nontoplevel_begin
;
2002 while (!SCM_NULLP (SCM_CDR (x
)))
2004 SCM form
= SCM_CAR (x
);
2007 if (SCM_ISYMP (form
))
2009 x
= scm_m_expand_body (x
, env
);
2010 goto nontoplevel_begin
;
2013 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2016 SCM_CEVAL (form
, env
);
2022 /* scm_eval last form in list */
2023 SCM last_form
= SCM_CAR (x
);
2025 if (SCM_CONSP (last_form
))
2027 /* This is by far the most frequent case. */
2029 goto loop
; /* tail recurse */
2031 else if (SCM_IMP (last_form
))
2032 RETURN (SCM_EVALIM (last_form
, env
));
2033 else if (SCM_VARIABLEP (last_form
))
2034 RETURN (SCM_VARIABLE_REF (last_form
));
2035 else if (SCM_SYMBOLP (last_form
))
2036 RETURN (*scm_lookupcar (x
, env
, 1));
2042 case SCM_BIT8 (SCM_IM_CASE
):
2045 SCM key
= EVALCAR (x
, env
);
2047 while (!SCM_NULLP (x
))
2049 SCM clause
= SCM_CAR (x
);
2050 SCM labels
= SCM_CAR (clause
);
2051 if (SCM_EQ_P (labels
, scm_sym_else
))
2053 x
= SCM_CDR (clause
);
2054 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2057 while (!SCM_NULLP (labels
))
2059 SCM label
= SCM_CAR (labels
);
2060 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2062 x
= SCM_CDR (clause
);
2063 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2066 labels
= SCM_CDR (labels
);
2071 RETURN (SCM_UNSPECIFIED
);
2074 case SCM_BIT8 (SCM_IM_COND
):
2076 while (!SCM_NULLP (x
))
2078 SCM clause
= SCM_CAR (x
);
2079 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2081 x
= SCM_CDR (clause
);
2082 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2087 arg1
= EVALCAR (clause
, env
);
2088 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2090 x
= SCM_CDR (clause
);
2093 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2095 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2101 proc
= EVALCAR (proc
, env
);
2102 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2103 PREP_APPLY (proc
, scm_list_1 (arg1
));
2105 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2106 goto umwrongnumargs
;
2114 RETURN (SCM_UNSPECIFIED
);
2117 case SCM_BIT8 (SCM_IM_DO
):
2120 /* Compute the initialization values and the initial environment. */
2121 SCM init_forms
= SCM_CADR (x
);
2122 SCM init_values
= SCM_EOL
;
2123 while (!SCM_NULLP (init_forms
))
2125 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2126 init_forms
= SCM_CDR (init_forms
);
2128 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2132 SCM test_form
= SCM_CAR (x
);
2133 SCM body_forms
= SCM_CADR (x
);
2134 SCM step_forms
= SCM_CDDR (x
);
2136 SCM test_result
= EVALCAR (test_form
, env
);
2138 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2141 /* Evaluate body forms. */
2143 for (temp_forms
= body_forms
;
2144 !SCM_NULLP (temp_forms
);
2145 temp_forms
= SCM_CDR (temp_forms
))
2147 SCM form
= SCM_CAR (temp_forms
);
2148 /* Dirk:FIXME: We only need to eval forms, that may have a
2149 * side effect here. This is only true for forms that start
2150 * with a pair. All others are just constants. However,
2151 * since in the common case there is no constant expression
2152 * in a body of a do form, we just check for immediates here
2153 * and have SCM_CEVAL take care of other cases. In the long
2154 * run it would make sense to get rid of this test and have
2155 * the macro transformer of 'do' eliminate all forms that
2156 * have no sideeffect. */
2157 if (!SCM_IMP (form
))
2158 SCM_CEVAL (form
, env
);
2163 /* Evaluate the step expressions. */
2165 SCM step_values
= SCM_EOL
;
2166 for (temp_forms
= step_forms
;
2167 !SCM_NULLP (temp_forms
);
2168 temp_forms
= SCM_CDR (temp_forms
))
2170 SCM value
= EVALCAR (temp_forms
, env
);
2171 step_values
= scm_cons (value
, step_values
);
2173 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2176 test_result
= EVALCAR (test_form
, env
);
2181 RETURN (SCM_UNSPECIFIED
);
2182 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2183 goto nontoplevel_begin
;
2186 case SCM_BIT8 (SCM_IM_IF
):
2189 SCM test_result
= EVALCAR (x
, env
);
2190 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2196 RETURN (SCM_UNSPECIFIED
);
2199 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2203 case SCM_BIT8 (SCM_IM_LET
):
2206 SCM init_forms
= SCM_CADR (x
);
2207 SCM init_values
= SCM_EOL
;
2210 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2211 init_forms
= SCM_CDR (init_forms
);
2213 while (!SCM_NULLP (init_forms
));
2214 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2217 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2218 goto nontoplevel_begin
;
2221 case SCM_BIT8 (SCM_IM_LETREC
):
2223 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2226 SCM init_forms
= SCM_CAR (x
);
2227 SCM init_values
= SCM_EOL
;
2230 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2231 init_forms
= SCM_CDR (init_forms
);
2233 while (!SCM_NULLP (init_forms
));
2234 SCM_SETCDR (SCM_CAR (env
), init_values
);
2237 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2238 goto nontoplevel_begin
;
2241 case SCM_BIT8 (SCM_IM_LETSTAR
):
2244 SCM bindings
= SCM_CAR (x
);
2245 if (SCM_NULLP (bindings
))
2246 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2251 SCM name
= SCM_CAR (bindings
);
2252 SCM init
= SCM_CDR (bindings
);
2253 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2254 bindings
= SCM_CDR (init
);
2256 while (!SCM_NULLP (bindings
));
2260 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2261 goto nontoplevel_begin
;
2264 case SCM_BIT8 (SCM_IM_OR
):
2266 while (!SCM_NULLP (SCM_CDR (x
)))
2268 SCM val
= EVALCAR (x
, env
);
2269 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2274 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2278 case SCM_BIT8 (SCM_IM_LAMBDA
):
2279 RETURN (scm_closure (SCM_CDR (x
), env
));
2282 case SCM_BIT8 (SCM_IM_QUOTE
):
2283 RETURN (SCM_CADR (x
));
2286 case SCM_BIT8 (SCM_IM_SET_X
):
2290 SCM variable
= SCM_CAR (x
);
2291 if (SCM_ILOCP (variable
))
2292 location
= scm_ilookup (variable
, env
);
2294 if (SCM_VARIABLEP (variable
))
2295 location
= SCM_VARIABLE_LOC (variable
);
2296 else /* (SCM_SYMBOLP (variable)) is known to be true */
2297 location
= scm_lookupcar (x
, env
, 1);
2299 *location
= EVALCAR (x
, env
);
2301 RETURN (SCM_UNSPECIFIED
);
2304 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2305 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2308 /* new syntactic forms go here. */
2309 case SCM_BIT8 (SCM_MAKISYM (0)):
2311 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2312 switch (SCM_ISYMNUM (proc
))
2316 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2318 proc
= EVALCAR (proc
, env
);
2319 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2320 if (SCM_CLOSUREP (proc
))
2322 PREP_APPLY (proc
, SCM_EOL
);
2323 arg1
= SCM_CDDR (x
);
2324 arg1
= EVALCAR (arg1
, env
);
2326 /* Go here to tail-call a closure. PROC is the closure
2327 and ARG1 is the list of arguments. Do not forget to
2330 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2332 debug
.info
->a
.args
= arg1
;
2334 if (scm_badargsp (formals
, arg1
))
2335 scm_wrong_num_args (proc
);
2337 /* Copy argument list */
2338 if (SCM_NULL_OR_NIL_P (arg1
))
2339 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2342 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2344 arg1
= SCM_CDR (arg1
);
2345 while (!SCM_NULL_OR_NIL_P (arg1
))
2347 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2348 SCM_SETCDR (tail
, new_tail
);
2350 arg1
= SCM_CDR (arg1
);
2352 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2355 x
= SCM_CLOSURE_BODY (proc
);
2356 goto nontoplevel_begin
;
2366 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2369 SCM val
= scm_make_continuation (&first
);
2377 proc
= scm_eval_car (proc
, env
);
2378 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2379 PREP_APPLY (proc
, scm_list_1 (arg1
));
2381 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2382 goto umwrongnumargs
;
2388 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2389 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2392 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2394 /* If not done yet, evaluate the operand forms. The result is a
2395 * list of arguments stored in arg1, which is used to perform the
2396 * function dispatch. */
2397 SCM operand_forms
= SCM_CADR (x
);
2398 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2399 if (SCM_ILOCP (operand_forms
))
2400 arg1
= *scm_ilookup (operand_forms
, env
);
2401 else if (SCM_VARIABLEP (operand_forms
))
2402 arg1
= SCM_VARIABLE_REF (operand_forms
);
2403 else if (!SCM_CONSP (operand_forms
))
2404 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2407 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2408 operand_forms
= SCM_CDR (operand_forms
);
2409 while (!SCM_NULLP (operand_forms
))
2411 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2412 SCM_SETCDR (tail
, new_tail
);
2414 operand_forms
= SCM_CDR (operand_forms
);
2419 /* The type dispatch code is duplicated below
2420 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2421 * cuts down execution time for type dispatch to 50%. */
2422 type_dispatch
: /* inputs: x, arg1 */
2423 /* Type dispatch means to determine from the types of the function
2424 * arguments (i. e. the 'signature' of the call), which method from
2425 * a generic function is to be called. This process of selecting
2426 * the right method takes some time. To speed it up, guile uses
2427 * caching: Together with the macro call to dispatch the signatures
2428 * of some previous calls to that generic function from the same
2429 * place are stored (in the code!) in a cache that we call the
2430 * 'method cache'. This is done since it is likely, that
2431 * consecutive calls to dispatch from that position in the code will
2432 * have the same signature. Thus, the type dispatch works as
2433 * follows: First, determine a hash value from the signature of the
2434 * actual arguments. Second, use this hash value as an index to
2435 * find that same signature in the method cache stored at this
2436 * position in the code. If found, you have also found the
2437 * corresponding method that belongs to that signature. If the
2438 * signature is not found in the method cache, you have to perform a
2439 * full search over all signatures stored with the generic
2442 unsigned long int specializers
;
2443 unsigned long int hash_value
;
2444 unsigned long int cache_end_pos
;
2445 unsigned long int mask
;
2449 SCM z
= SCM_CDDR (x
);
2450 SCM tmp
= SCM_CADR (z
);
2451 specializers
= SCM_INUM (SCM_CAR (z
));
2453 /* Compute a hash value for searching the method cache. There
2454 * are two variants for computing the hash value, a (rather)
2455 * complicated one, and a simple one. For the complicated one
2456 * explained below, tmp holds a number that is used in the
2458 if (SCM_INUMP (tmp
))
2460 /* Use the signature of the actual arguments to determine
2461 * the hash value. This is done as follows: Each class has
2462 * an array of random numbers, that are determined when the
2463 * class is created. The integer 'hashset' is an index into
2464 * that array of random numbers. Now, from all classes that
2465 * are part of the signature of the actual arguments, the
2466 * random numbers at index 'hashset' are taken and summed
2467 * up, giving the hash value. The value of 'hashset' is
2468 * stored at the call to dispatch. This allows to have
2469 * different 'formulas' for calculating the hash value at
2470 * different places where dispatch is called. This allows
2471 * to optimize the hash formula at every individual place
2472 * where dispatch is called, such that hopefully the hash
2473 * value that is computed will directly point to the right
2474 * method in the method cache. */
2475 unsigned long int hashset
= SCM_INUM (tmp
);
2476 unsigned long int counter
= specializers
+ 1;
2479 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2481 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2482 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2483 tmp_arg
= SCM_CDR (tmp_arg
);
2487 method_cache
= SCM_CADR (z
);
2488 mask
= SCM_INUM (SCM_CAR (z
));
2490 cache_end_pos
= hash_value
;
2494 /* This method of determining the hash value is much
2495 * simpler: Set the hash value to zero and just perform a
2496 * linear search through the method cache. */
2498 mask
= (unsigned long int) ((long) -1);
2500 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2505 /* Search the method cache for a method with a matching
2506 * signature. Start the search at position 'hash_value'. The
2507 * hashing implementation uses linear probing for conflict
2508 * resolution, that is, if the signature in question is not
2509 * found at the starting index in the hash table, the next table
2510 * entry is tried, and so on, until in the worst case the whole
2511 * cache has been searched, but still the signature has not been
2516 SCM args
= arg1
; /* list of arguments */
2517 z
= SCM_VELTS (method_cache
)[hash_value
];
2518 while (!SCM_NULLP (args
))
2520 /* More arguments than specifiers => CLASS != ENV */
2521 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2522 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2524 args
= SCM_CDR (args
);
2527 /* Fewer arguments than specifiers => CAR != ENV */
2528 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2531 hash_value
= (hash_value
+ 1) & mask
;
2532 } while (hash_value
!= cache_end_pos
);
2534 /* No appropriate method was found in the cache. */
2535 z
= scm_memoize_method (x
, arg1
);
2537 apply_cmethod
: /* inputs: z, arg1 */
2539 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2540 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2541 x
= SCM_CMETHOD_BODY (z
);
2542 goto nontoplevel_begin
;
2548 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2551 SCM instance
= EVALCAR (x
, env
);
2552 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2553 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2557 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2560 SCM instance
= EVALCAR (x
, env
);
2561 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2562 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2563 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2564 RETURN (SCM_UNSPECIFIED
);
2568 #ifdef SCM_ENABLE_ELISP
2570 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2572 SCM test_form
= SCM_CDR (x
);
2573 x
= SCM_CDR (test_form
);
2574 while (!SCM_NULL_OR_NIL_P (x
))
2576 SCM test_result
= EVALCAR (test_form
, env
);
2577 if (!(SCM_FALSEP (test_result
)
2578 || SCM_NULL_OR_NIL_P (test_result
)))
2580 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2581 RETURN (test_result
);
2582 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2587 test_form
= SCM_CDR (x
);
2588 x
= SCM_CDR (test_form
);
2592 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2596 #endif /* SCM_ENABLE_ELISP */
2598 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2600 SCM vars
, exps
, vals
;
2603 vars
= SCM_CAAR (x
);
2604 exps
= SCM_CDAR (x
);
2608 while (SCM_NIMP (exps
))
2610 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2611 exps
= SCM_CDR (exps
);
2614 scm_swap_bindings (vars
, vals
);
2615 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2617 /* Ignore all but the last evaluation result. */
2618 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2620 if (SCM_CONSP (SCM_CAR (x
)))
2621 SCM_CEVAL (SCM_CAR (x
), env
);
2623 proc
= EVALCAR (x
, env
);
2625 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2626 scm_swap_bindings (vars
, vals
);
2632 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2635 x
= EVALCAR (proc
, env
);
2636 proc
= SCM_CDR (proc
);
2637 proc
= EVALCAR (proc
, env
);
2638 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2639 if (SCM_VALUESP (arg1
))
2640 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2642 arg1
= scm_list_1 (arg1
);
2643 if (SCM_CLOSUREP (proc
))
2645 PREP_APPLY (proc
, arg1
);
2648 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2659 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2660 case scm_tc7_vector
:
2664 case scm_tc7_byvect
:
2671 #ifdef HAVE_LONG_LONGS
2672 case scm_tc7_llvect
:
2675 case scm_tc7_string
:
2677 case scm_tcs_closures
:
2681 case scm_tcs_struct
:
2684 case scm_tc7_variable
:
2685 RETURN (SCM_VARIABLE_REF(x
));
2687 case SCM_BIT8(SCM_ILOC00
):
2688 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2689 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2692 case scm_tcs_cons_nimcar
:
2693 if (SCM_SYMBOLP (SCM_CAR (x
)))
2695 SCM orig_sym
= SCM_CAR (x
);
2698 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2699 if (location
== NULL
)
2701 /* we have lost the race, start again. */
2707 proc
= *scm_lookupcar (x
, env
, 1);
2712 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2716 if (SCM_MACROP (proc
))
2718 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2720 handle_a_macro
: /* inputs: x, env, proc */
2722 /* Set a flag during macro expansion so that macro
2723 application frames can be deleted from the backtrace. */
2724 SCM_SET_MACROEXP (debug
);
2726 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2727 scm_cons (env
, scm_listofnull
));
2730 SCM_CLEAR_MACROEXP (debug
);
2732 switch (SCM_MACRO_TYPE (proc
))
2735 if (scm_ilength (arg1
) <= 0)
2736 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2738 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2741 SCM_SETCAR (x
, SCM_CAR (arg1
));
2742 SCM_SETCDR (x
, SCM_CDR (arg1
));
2746 /* Prevent memoizing of debug info expression. */
2747 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2752 SCM_SETCAR (x
, SCM_CAR (arg1
));
2753 SCM_SETCDR (x
, SCM_CDR (arg1
));
2755 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2761 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2772 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2773 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2776 if (SCM_CLOSUREP (proc
))
2778 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2779 SCM args
= SCM_CDR (x
);
2780 while (!SCM_NULLP (formals
))
2782 if (!SCM_CONSP (formals
))
2785 goto umwrongnumargs
;
2786 formals
= SCM_CDR (formals
);
2787 args
= SCM_CDR (args
);
2789 if (!SCM_NULLP (args
))
2790 goto umwrongnumargs
;
2792 else if (SCM_MACROP (proc
))
2793 goto handle_a_macro
;
2797 evapply
: /* inputs: x, proc */
2798 PREP_APPLY (proc
, SCM_EOL
);
2799 if (SCM_NULLP (SCM_CDR (x
))) {
2802 switch (SCM_TYP7 (proc
))
2803 { /* no arguments given */
2804 case scm_tc7_subr_0
:
2805 RETURN (SCM_SUBRF (proc
) ());
2806 case scm_tc7_subr_1o
:
2807 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2809 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2810 case scm_tc7_rpsubr
:
2811 RETURN (SCM_BOOL_T
);
2813 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2815 if (!SCM_SMOB_APPLICABLE_P (proc
))
2817 RETURN (SCM_SMOB_APPLY_0 (proc
));
2820 proc
= SCM_CCLO_SUBR (proc
);
2822 debug
.info
->a
.proc
= proc
;
2823 debug
.info
->a
.args
= scm_list_1 (arg1
);
2827 proc
= SCM_PROCEDURE (proc
);
2829 debug
.info
->a
.proc
= proc
;
2831 if (!SCM_CLOSUREP (proc
))
2833 if (scm_badformalsp (proc
, 0))
2834 goto umwrongnumargs
;
2835 case scm_tcs_closures
:
2836 x
= SCM_CLOSURE_BODY (proc
);
2837 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2838 goto nontoplevel_begin
;
2839 case scm_tcs_struct
:
2840 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2842 x
= SCM_ENTITY_PROCEDURE (proc
);
2846 else if (!SCM_I_OPERATORP (proc
))
2851 proc
= (SCM_I_ENTITYP (proc
)
2852 ? SCM_ENTITY_PROCEDURE (proc
)
2853 : SCM_OPERATOR_PROCEDURE (proc
));
2855 debug
.info
->a
.proc
= proc
;
2856 debug
.info
->a
.args
= scm_list_1 (arg1
);
2858 if (SCM_NIMP (proc
))
2863 case scm_tc7_subr_1
:
2864 case scm_tc7_subr_2
:
2865 case scm_tc7_subr_2o
:
2867 case scm_tc7_subr_3
:
2868 case scm_tc7_lsubr_2
:
2871 scm_wrong_num_args (proc
);
2873 /* handle macros here */
2878 /* must handle macros by here */
2881 arg1
= EVALCAR (x
, env
);
2883 scm_wrong_num_args (proc
);
2885 debug
.info
->a
.args
= scm_list_1 (arg1
);
2893 evap1
: /* inputs: proc, arg1 */
2894 switch (SCM_TYP7 (proc
))
2895 { /* have one argument in arg1 */
2896 case scm_tc7_subr_2o
:
2897 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2898 case scm_tc7_subr_1
:
2899 case scm_tc7_subr_1o
:
2900 RETURN (SCM_SUBRF (proc
) (arg1
));
2902 if (SCM_SUBRF (proc
))
2904 if (SCM_INUMP (arg1
))
2906 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2908 else if (SCM_REALP (arg1
))
2910 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2913 else if (SCM_BIGP (arg1
))
2915 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2918 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2919 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2921 proc
= SCM_SNAME (proc
);
2923 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2924 while ('c' != *--chrs
)
2926 SCM_ASSERT (SCM_CONSP (arg1
),
2927 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2928 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2932 case scm_tc7_rpsubr
:
2933 RETURN (SCM_BOOL_T
);
2935 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2938 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2940 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2943 if (!SCM_SMOB_APPLICABLE_P (proc
))
2945 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2949 proc
= SCM_CCLO_SUBR (proc
);
2951 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2952 debug
.info
->a
.proc
= proc
;
2956 proc
= SCM_PROCEDURE (proc
);
2958 debug
.info
->a
.proc
= proc
;
2960 if (!SCM_CLOSUREP (proc
))
2962 if (scm_badformalsp (proc
, 1))
2963 goto umwrongnumargs
;
2964 case scm_tcs_closures
:
2966 x
= SCM_CLOSURE_BODY (proc
);
2968 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2970 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2972 goto nontoplevel_begin
;
2973 case scm_tcs_struct
:
2974 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2976 x
= SCM_ENTITY_PROCEDURE (proc
);
2978 arg1
= debug
.info
->a
.args
;
2980 arg1
= scm_list_1 (arg1
);
2984 else if (!SCM_I_OPERATORP (proc
))
2990 proc
= (SCM_I_ENTITYP (proc
)
2991 ? SCM_ENTITY_PROCEDURE (proc
)
2992 : SCM_OPERATOR_PROCEDURE (proc
));
2994 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2995 debug
.info
->a
.proc
= proc
;
2997 if (SCM_NIMP (proc
))
3002 case scm_tc7_subr_2
:
3003 case scm_tc7_subr_0
:
3004 case scm_tc7_subr_3
:
3005 case scm_tc7_lsubr_2
:
3006 scm_wrong_num_args (proc
);
3012 arg2
= EVALCAR (x
, env
);
3014 scm_wrong_num_args (proc
);
3016 { /* have two or more arguments */
3018 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3021 if (SCM_NULLP (x
)) {
3024 switch (SCM_TYP7 (proc
))
3025 { /* have two arguments */
3026 case scm_tc7_subr_2
:
3027 case scm_tc7_subr_2o
:
3028 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3031 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3033 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3035 case scm_tc7_lsubr_2
:
3036 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3037 case scm_tc7_rpsubr
:
3039 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3041 if (!SCM_SMOB_APPLICABLE_P (proc
))
3043 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3047 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3048 scm_cons (proc
, debug
.info
->a
.args
),
3051 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3052 scm_cons2 (proc
, arg1
,
3059 case scm_tcs_struct
:
3060 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3062 x
= SCM_ENTITY_PROCEDURE (proc
);
3064 arg1
= debug
.info
->a
.args
;
3066 arg1
= scm_list_2 (arg1
, arg2
);
3070 else if (!SCM_I_OPERATORP (proc
))
3076 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3077 ? SCM_ENTITY_PROCEDURE (proc
)
3078 : SCM_OPERATOR_PROCEDURE (proc
),
3079 scm_cons (proc
, debug
.info
->a
.args
),
3082 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3083 ? SCM_ENTITY_PROCEDURE (proc
)
3084 : SCM_OPERATOR_PROCEDURE (proc
),
3085 scm_cons2 (proc
, arg1
,
3093 case scm_tc7_subr_0
:
3095 case scm_tc7_subr_1o
:
3096 case scm_tc7_subr_1
:
3097 case scm_tc7_subr_3
:
3098 scm_wrong_num_args (proc
);
3102 proc
= SCM_PROCEDURE (proc
);
3104 debug
.info
->a
.proc
= proc
;
3106 if (!SCM_CLOSUREP (proc
))
3108 if (scm_badformalsp (proc
, 2))
3109 goto umwrongnumargs
;
3110 case scm_tcs_closures
:
3113 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3117 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3118 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3120 x
= SCM_CLOSURE_BODY (proc
);
3121 goto nontoplevel_begin
;
3125 scm_wrong_num_args (proc
);
3127 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3128 deval_args (x
, env
, proc
,
3129 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3133 switch (SCM_TYP7 (proc
))
3134 { /* have 3 or more arguments */
3136 case scm_tc7_subr_3
:
3137 if (!SCM_NULLP (SCM_CDR (x
)))
3138 scm_wrong_num_args (proc
);
3140 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3141 SCM_CADDR (debug
.info
->a
.args
)));
3143 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3144 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3147 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3148 arg2
= SCM_CDR (arg2
);
3150 while (SCM_NIMP (arg2
));
3152 case scm_tc7_rpsubr
:
3153 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3154 RETURN (SCM_BOOL_F
);
3155 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3158 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3159 RETURN (SCM_BOOL_F
);
3160 arg2
= SCM_CAR (arg1
);
3161 arg1
= SCM_CDR (arg1
);
3163 while (SCM_NIMP (arg1
));
3164 RETURN (SCM_BOOL_T
);
3165 case scm_tc7_lsubr_2
:
3166 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3167 SCM_CDDR (debug
.info
->a
.args
)));
3169 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3171 if (!SCM_SMOB_APPLICABLE_P (proc
))
3173 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3174 SCM_CDDR (debug
.info
->a
.args
)));
3178 proc
= SCM_PROCEDURE (proc
);
3179 debug
.info
->a
.proc
= proc
;
3180 if (!SCM_CLOSUREP (proc
))
3182 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3183 goto umwrongnumargs
;
3184 case scm_tcs_closures
:
3185 SCM_SET_ARGSREADY (debug
);
3186 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3189 x
= SCM_CLOSURE_BODY (proc
);
3190 goto nontoplevel_begin
;
3192 case scm_tc7_subr_3
:
3193 if (!SCM_NULLP (SCM_CDR (x
)))
3194 scm_wrong_num_args (proc
);
3196 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3198 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3201 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3204 while (SCM_NIMP (x
));
3206 case scm_tc7_rpsubr
:
3207 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3208 RETURN (SCM_BOOL_F
);
3211 arg1
= EVALCAR (x
, env
);
3212 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3213 RETURN (SCM_BOOL_F
);
3217 while (SCM_NIMP (x
));
3218 RETURN (SCM_BOOL_T
);
3219 case scm_tc7_lsubr_2
:
3220 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3222 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3224 scm_eval_args (x
, env
, proc
))));
3226 if (!SCM_SMOB_APPLICABLE_P (proc
))
3228 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3229 scm_eval_args (x
, env
, proc
)));
3233 proc
= SCM_PROCEDURE (proc
);
3234 if (!SCM_CLOSUREP (proc
))
3237 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3238 if (SCM_NULLP (formals
)
3239 || (SCM_CONSP (formals
)
3240 && (SCM_NULLP (SCM_CDR (formals
))
3241 || (SCM_CONSP (SCM_CDR (formals
))
3242 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3243 goto umwrongnumargs
;
3245 case scm_tcs_closures
:
3247 SCM_SET_ARGSREADY (debug
);
3249 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3252 scm_eval_args (x
, env
, proc
)),
3254 x
= SCM_CLOSURE_BODY (proc
);
3255 goto nontoplevel_begin
;
3257 case scm_tcs_struct
:
3258 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3261 arg1
= debug
.info
->a
.args
;
3263 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3265 x
= SCM_ENTITY_PROCEDURE (proc
);
3268 else if (!SCM_I_OPERATORP (proc
))
3272 case scm_tc7_subr_2
:
3273 case scm_tc7_subr_1o
:
3274 case scm_tc7_subr_2o
:
3275 case scm_tc7_subr_0
:
3277 case scm_tc7_subr_1
:
3278 scm_wrong_num_args (proc
);
3286 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3287 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3289 SCM_CLEAR_TRACED_FRAME (debug
);
3290 if (SCM_CHEAPTRAPS_P
)
3291 arg1
= scm_make_debugobj (&debug
);
3295 SCM val
= scm_make_continuation (&first
);
3306 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3310 scm_last_debug_frame
= debug
.prev
;
3316 /* SECTION: This code is compiled once.
3322 /* Simple procedure calls
3326 scm_call_0 (SCM proc
)
3328 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3332 scm_call_1 (SCM proc
, SCM arg1
)
3334 return scm_apply (proc
, arg1
, scm_listofnull
);
3338 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3340 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3344 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3346 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3350 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3352 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3353 scm_cons (arg4
, scm_listofnull
)));
3356 /* Simple procedure applies
3360 scm_apply_0 (SCM proc
, SCM args
)
3362 return scm_apply (proc
, args
, SCM_EOL
);
3366 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3368 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3372 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3374 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3378 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3380 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3384 /* This code processes the arguments to apply:
3386 (apply PROC ARG1 ... ARGS)
3388 Given a list (ARG1 ... ARGS), this function conses the ARG1
3389 ... arguments onto the front of ARGS, and returns the resulting
3390 list. Note that ARGS is a list; thus, the argument to this
3391 function is a list whose last element is a list.
3393 Apply calls this function, and applies PROC to the elements of the
3394 result. apply:nconc2last takes care of building the list of
3395 arguments, given (ARG1 ... ARGS).
3397 Rather than do new consing, apply:nconc2last destroys its argument.
3398 On that topic, this code came into my care with the following
3399 beautifully cryptic comment on that topic: "This will only screw
3400 you if you do (scm_apply scm_apply '( ... ))" If you know what
3401 they're referring to, send me a patch to this comment. */
3403 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3405 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3406 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3407 "@var{args}, and returns the resulting list. Note that\n"
3408 "@var{args} is a list; thus, the argument to this function is\n"
3409 "a list whose last element is a list.\n"
3410 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3411 "destroys its argument, so use with care.")
3412 #define FUNC_NAME s_scm_nconc2last
3415 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3417 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3418 SCM_NULL_OR_NIL_P, but not
3419 needed in 99.99% of cases,
3420 and it could seriously hurt
3421 performance. - Neil */
3422 lloc
= SCM_CDRLOC (*lloc
);
3423 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3424 *lloc
= SCM_CAR (*lloc
);
3432 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3433 * It is compiled twice.
3438 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3444 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3449 /* Apply a function to a list of arguments.
3451 This function is exported to the Scheme level as taking two
3452 required arguments and a tail argument, as if it were:
3453 (lambda (proc arg1 . args) ...)
3454 Thus, if you just have a list of arguments to pass to a procedure,
3455 pass the list as ARG1, and '() for ARGS. If you have some fixed
3456 args, pass the first as ARG1, then cons any remaining fixed args
3457 onto the front of your argument list, and pass that as ARGS. */
3460 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3462 #ifdef DEBUG_EXTENSIONS
3464 scm_t_debug_frame debug
;
3465 scm_t_debug_info debug_vect_body
;
3466 debug
.prev
= scm_last_debug_frame
;
3467 debug
.status
= SCM_APPLYFRAME
;
3468 debug
.vect
= &debug_vect_body
;
3469 debug
.vect
[0].a
.proc
= proc
;
3470 debug
.vect
[0].a
.args
= SCM_EOL
;
3471 scm_last_debug_frame
= &debug
;
3474 return scm_dapply (proc
, arg1
, args
);
3478 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3480 /* If ARGS is the empty list, then we're calling apply with only two
3481 arguments --- ARG1 is the list of arguments for PROC. Whatever
3482 the case, futz with things so that ARG1 is the first argument to
3483 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3486 Setting the debug apply frame args this way is pretty messy.
3487 Perhaps we should store arg1 and args directly in the frame as
3488 received, and let scm_frame_arguments unpack them, because that's
3489 a relatively rare operation. This works for now; if the Guile
3490 developer archives are still around, see Mikael's post of
3492 if (SCM_NULLP (args
))
3494 if (SCM_NULLP (arg1
))
3496 arg1
= SCM_UNDEFINED
;
3498 debug
.vect
[0].a
.args
= SCM_EOL
;
3504 debug
.vect
[0].a
.args
= arg1
;
3506 args
= SCM_CDR (arg1
);
3507 arg1
= SCM_CAR (arg1
);
3512 args
= scm_nconc2last (args
);
3514 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3518 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3521 if (SCM_CHEAPTRAPS_P
)
3522 tmp
= scm_make_debugobj (&debug
);
3527 tmp
= scm_make_continuation (&first
);
3532 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3539 switch (SCM_TYP7 (proc
))
3541 case scm_tc7_subr_2o
:
3542 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3543 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3544 case scm_tc7_subr_2
:
3545 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3546 scm_wrong_num_args (proc
);
3547 args
= SCM_CAR (args
);
3548 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3549 case scm_tc7_subr_0
:
3550 if (!SCM_UNBNDP (arg1
))
3551 scm_wrong_num_args (proc
);
3553 RETURN (SCM_SUBRF (proc
) ());
3554 case scm_tc7_subr_1
:
3555 if (SCM_UNBNDP (arg1
))
3556 scm_wrong_num_args (proc
);
3557 case scm_tc7_subr_1o
:
3558 if (!SCM_NULLP (args
))
3559 scm_wrong_num_args (proc
);
3561 RETURN (SCM_SUBRF (proc
) (arg1
));
3563 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3564 scm_wrong_num_args (proc
);
3565 if (SCM_SUBRF (proc
))
3567 if (SCM_INUMP (arg1
))
3569 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3571 else if (SCM_REALP (arg1
))
3573 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3576 else if (SCM_BIGP (arg1
))
3577 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3579 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3580 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3582 proc
= SCM_SNAME (proc
);
3584 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3585 while ('c' != *--chrs
)
3587 SCM_ASSERT (SCM_CONSP (arg1
),
3588 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3589 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3593 case scm_tc7_subr_3
:
3594 if (SCM_NULLP (args
)
3595 || SCM_NULLP (SCM_CDR (args
))
3596 || !SCM_NULLP (SCM_CDDR (args
)))
3597 scm_wrong_num_args (proc
);
3599 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3602 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3604 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3606 case scm_tc7_lsubr_2
:
3607 if (!SCM_CONSP (args
))
3608 scm_wrong_num_args (proc
);
3610 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3612 if (SCM_NULLP (args
))
3613 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3614 while (SCM_NIMP (args
))
3616 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3617 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3618 args
= SCM_CDR (args
);
3621 case scm_tc7_rpsubr
:
3622 if (SCM_NULLP (args
))
3623 RETURN (SCM_BOOL_T
);
3624 while (SCM_NIMP (args
))
3626 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3627 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3628 RETURN (SCM_BOOL_F
);
3629 arg1
= SCM_CAR (args
);
3630 args
= SCM_CDR (args
);
3632 RETURN (SCM_BOOL_T
);
3633 case scm_tcs_closures
:
3635 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3637 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3639 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3640 scm_wrong_num_args (proc
);
3642 /* Copy argument list */
3647 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3648 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3650 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3654 SCM_SETCDR (tl
, arg1
);
3657 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3658 proc
= SCM_CLOSURE_BODY (proc
);
3661 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3663 if (SCM_IMP (SCM_CAR (proc
)))
3665 if (SCM_ISYMP (SCM_CAR (proc
)))
3667 proc
= scm_m_expand_body (proc
, args
);
3671 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3674 SCM_CEVAL (SCM_CAR (proc
), args
);
3677 RETURN (EVALCAR (proc
, args
));
3679 if (!SCM_SMOB_APPLICABLE_P (proc
))
3681 if (SCM_UNBNDP (arg1
))
3682 RETURN (SCM_SMOB_APPLY_0 (proc
));
3683 else if (SCM_NULLP (args
))
3684 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3685 else if (SCM_NULLP (SCM_CDR (args
)))
3686 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3688 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3691 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3693 proc
= SCM_CCLO_SUBR (proc
);
3694 debug
.vect
[0].a
.proc
= proc
;
3695 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3697 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3699 proc
= SCM_CCLO_SUBR (proc
);
3703 proc
= SCM_PROCEDURE (proc
);
3705 debug
.vect
[0].a
.proc
= proc
;
3708 case scm_tcs_struct
:
3709 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3712 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3714 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3716 RETURN (scm_apply_generic (proc
, args
));
3718 else if (!SCM_I_OPERATORP (proc
))
3723 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3725 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3728 proc
= (SCM_I_ENTITYP (proc
)
3729 ? SCM_ENTITY_PROCEDURE (proc
)
3730 : SCM_OPERATOR_PROCEDURE (proc
));
3732 debug
.vect
[0].a
.proc
= proc
;
3733 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3735 if (SCM_NIMP (proc
))
3742 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3746 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3747 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3749 SCM_CLEAR_TRACED_FRAME (debug
);
3750 if (SCM_CHEAPTRAPS_P
)
3751 arg1
= scm_make_debugobj (&debug
);
3755 SCM val
= scm_make_continuation (&first
);
3766 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3770 scm_last_debug_frame
= debug
.prev
;
3776 /* SECTION: The rest of this file is only read once.
3781 /* Typechecking for multi-argument MAP and FOR-EACH.
3783 Verify that each element of the vector ARGV, except for the first,
3784 is a proper list whose length is LEN. Attribute errors to WHO,
3785 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3787 check_map_args (SCM argv
,
3794 SCM
*ve
= SCM_VELTS (argv
);
3797 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3799 long elt_len
= scm_ilength (ve
[i
]);
3804 scm_apply_generic (gf
, scm_cons (proc
, args
));
3806 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3810 scm_out_of_range (who
, ve
[i
]);
3813 scm_remember_upto_here_1 (argv
);
3817 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3819 /* Note: Currently, scm_map applies PROC to the argument list(s)
3820 sequentially, starting with the first element(s). This is used in
3821 evalext.c where the Scheme procedure `map-in-order', which guarantees
3822 sequential behaviour, is implemented using scm_map. If the
3823 behaviour changes, we need to update `map-in-order'.
3827 scm_map (SCM proc
, SCM arg1
, SCM args
)
3828 #define FUNC_NAME s_map
3833 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3835 len
= scm_ilength (arg1
);
3836 SCM_GASSERTn (len
>= 0,
3837 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3838 SCM_VALIDATE_REST_ARGUMENT (args
);
3839 if (SCM_NULLP (args
))
3841 while (SCM_NIMP (arg1
))
3843 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3844 pres
= SCM_CDRLOC (*pres
);
3845 arg1
= SCM_CDR (arg1
);
3849 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3850 ve
= SCM_VELTS (args
);
3851 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3855 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3857 if (SCM_IMP (ve
[i
]))
3859 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3860 ve
[i
] = SCM_CDR (ve
[i
]);
3862 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3863 pres
= SCM_CDRLOC (*pres
);
3869 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3872 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3873 #define FUNC_NAME s_for_each
3875 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3877 len
= scm_ilength (arg1
);
3878 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3879 SCM_ARG2
, s_for_each
);
3880 SCM_VALIDATE_REST_ARGUMENT (args
);
3881 if (SCM_NULLP (args
))
3883 while (SCM_NIMP (arg1
))
3885 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3886 arg1
= SCM_CDR (arg1
);
3888 return SCM_UNSPECIFIED
;
3890 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3891 ve
= SCM_VELTS (args
);
3892 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3896 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3898 if (SCM_IMP (ve
[i
]))
3899 return SCM_UNSPECIFIED
;
3900 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3901 ve
[i
] = SCM_CDR (ve
[i
]);
3903 scm_apply (proc
, arg1
, SCM_EOL
);
3910 scm_closure (SCM code
, SCM env
)
3913 SCM closcar
= scm_cons (code
, SCM_EOL
);
3914 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3915 scm_remember_upto_here (closcar
);
3920 scm_t_bits scm_tc16_promise
;
3923 scm_makprom (SCM code
)
3925 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3931 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3933 int writingp
= SCM_WRITINGP (pstate
);
3934 scm_puts ("#<promise ", port
);
3935 SCM_SET_WRITINGP (pstate
, 1);
3936 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3937 SCM_SET_WRITINGP (pstate
, writingp
);
3938 scm_putc ('>', port
);
3943 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3945 "If the promise @var{x} has not been computed yet, compute and\n"
3946 "return @var{x}, otherwise just return the previously computed\n"
3948 #define FUNC_NAME s_scm_force
3950 SCM_VALIDATE_SMOB (1, x
, promise
);
3951 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3953 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3954 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3957 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3958 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3962 return SCM_CELL_OBJECT_1 (x
);
3967 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3969 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3970 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3971 #define FUNC_NAME s_scm_promise_p
3973 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3978 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3979 (SCM xorig
, SCM x
, SCM y
),
3980 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3981 "Any source properties associated with @var{xorig} are also associated\n"
3982 "with the new pair.")
3983 #define FUNC_NAME s_scm_cons_source
3986 z
= scm_cons (x
, y
);
3987 /* Copy source properties possibly associated with xorig. */
3988 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3990 scm_whash_insert (scm_source_whash
, z
, p
);
3996 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3998 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3999 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4000 "contents of both pairs and vectors (since both cons cells and vector\n"
4001 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4002 "any other object.")
4003 #define FUNC_NAME s_scm_copy_tree
4008 if (SCM_VECTORP (obj
))
4010 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4011 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4013 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
4016 if (!SCM_CONSP (obj
))
4018 ans
= tl
= scm_cons_source (obj
,
4019 scm_copy_tree (SCM_CAR (obj
)),
4021 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4023 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4027 SCM_SETCDR (tl
, obj
);
4033 /* We have three levels of EVAL here:
4035 - scm_i_eval (exp, env)
4037 evaluates EXP in environment ENV. ENV is a lexical environment
4038 structure as used by the actual tree code evaluator. When ENV is
4039 a top-level environment, then changes to the current module are
4040 tracked by updating ENV so that it continues to be in sync with
4043 - scm_primitive_eval (exp)
4045 evaluates EXP in the top-level environment as determined by the
4046 current module. This is done by constructing a suitable
4047 environment and calling scm_i_eval. Thus, changes to the
4048 top-level module are tracked normally.
4050 - scm_eval (exp, mod)
4052 evaluates EXP while MOD is the current module. This is done by
4053 setting the current module to MOD, invoking scm_primitive_eval on
4054 EXP, and then restoring the current module to the value it had
4055 previously. That is, while EXP is evaluated, changes to the
4056 current module are tracked, but these changes do not persist when
4059 For each level of evals, there are two variants, distinguished by a
4060 _x suffix: the ordinary variant does not modify EXP while the _x
4061 variant can destructively modify EXP into something completely
4062 unintelligible. A Scheme data structure passed as EXP to one of the
4063 _x variants should not ever be used again for anything. So when in
4064 doubt, use the ordinary variant.
4069 scm_i_eval_x (SCM exp
, SCM env
)
4071 return SCM_XEVAL (exp
, env
);
4075 scm_i_eval (SCM exp
, SCM env
)
4077 exp
= scm_copy_tree (exp
);
4078 return SCM_XEVAL (exp
, env
);
4082 scm_primitive_eval_x (SCM exp
)
4085 SCM transformer
= scm_current_module_transformer ();
4086 if (SCM_NIMP (transformer
))
4087 exp
= scm_call_1 (transformer
, exp
);
4088 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4089 return scm_i_eval_x (exp
, env
);
4092 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4094 "Evaluate @var{exp} in the top-level environment specified by\n"
4095 "the current module.")
4096 #define FUNC_NAME s_scm_primitive_eval
4099 SCM transformer
= scm_current_module_transformer ();
4100 if (SCM_NIMP (transformer
))
4101 exp
= scm_call_1 (transformer
, exp
);
4102 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4103 return scm_i_eval (exp
, env
);
4107 /* Eval does not take the second arg optionally. This is intentional
4108 * in order to be R5RS compatible, and to prepare for the new module
4109 * system, where we would like to make the choice of evaluation
4110 * environment explicit. */
4113 change_environment (void *data
)
4115 SCM pair
= SCM_PACK (data
);
4116 SCM new_module
= SCM_CAR (pair
);
4117 SCM old_module
= scm_current_module ();
4118 SCM_SETCDR (pair
, old_module
);
4119 scm_set_current_module (new_module
);
4124 restore_environment (void *data
)
4126 SCM pair
= SCM_PACK (data
);
4127 SCM old_module
= SCM_CDR (pair
);
4128 SCM new_module
= scm_current_module ();
4129 SCM_SETCAR (pair
, new_module
);
4130 scm_set_current_module (old_module
);
4134 inner_eval_x (void *data
)
4136 return scm_primitive_eval_x (SCM_PACK(data
));
4140 scm_eval_x (SCM exp
, SCM module
)
4141 #define FUNC_NAME "eval!"
4143 SCM_VALIDATE_MODULE (2, module
);
4145 return scm_internal_dynamic_wind
4146 (change_environment
, inner_eval_x
, restore_environment
,
4147 (void *) SCM_UNPACK (exp
),
4148 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4153 inner_eval (void *data
)
4155 return scm_primitive_eval (SCM_PACK(data
));
4158 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4159 (SCM exp
, SCM module
),
4160 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4161 "in the top-level environment specified by @var{module}.\n"
4162 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4163 "@var{module} is made the current module. The current module\n"
4164 "is reset to its previous value when @var{eval} returns.")
4165 #define FUNC_NAME s_scm_eval
4167 SCM_VALIDATE_MODULE (2, module
);
4169 return scm_internal_dynamic_wind
4170 (change_environment
, inner_eval
, restore_environment
,
4171 (void *) SCM_UNPACK (exp
),
4172 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4177 /* At this point, scm_deval and scm_dapply are generated.
4180 #ifdef DEBUG_EXTENSIONS
4190 scm_init_opts (scm_evaluator_traps
,
4191 scm_evaluator_trap_table
,
4192 SCM_N_EVALUATOR_TRAPS
);
4193 scm_init_opts (scm_eval_options_interface
,
4195 SCM_N_EVAL_OPTIONS
);
4197 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4198 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4199 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4201 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4202 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4203 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4204 scm_listofnull
= scm_list_1 (SCM_EOL
);
4206 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4211 #include "libguile/eval.x"
4213 scm_add_feature ("delay");