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 SCM_SETCAR (SCM_CAR (env
), scm_cons (n
, SCM_CAAR (env
)));
1478 case SCM_BIT8(SCM_MAKISYM (0)):
1482 switch (SCM_ISYMNUM (z
))
1484 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1485 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1487 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1488 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1490 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1491 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1494 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1495 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1498 /* appease the Sun compiler god: */ ;
1502 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1508 while (SCM_CONSP (x
))
1510 SCM form
= SCM_CAR (x
);
1511 if (!SCM_ISYMP (form
))
1513 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1514 SCM_SETCDR (z
, unmemocar (copy
, env
));
1520 #ifdef DEBUG_EXTENSIONS
1521 if (!SCM_FALSEP (p
))
1522 scm_whash_insert (scm_source_whash
, ls
, p
);
1529 scm_unmemocopy (SCM x
, SCM env
)
1531 if (!SCM_NULLP (env
))
1532 /* Make a copy of the lowest frame to protect it from
1533 modifications by SCM_IM_DEFINE */
1534 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1536 return unmemocopy (x
, env
);
1541 scm_badargsp (SCM formals
, SCM args
)
1543 while (!SCM_NULLP (formals
))
1545 if (!SCM_CONSP (formals
))
1547 if (SCM_NULLP (args
))
1549 formals
= SCM_CDR (formals
);
1550 args
= SCM_CDR (args
);
1552 return !SCM_NULLP (args
) ? 1 : 0;
1557 scm_badformalsp (SCM closure
, int n
)
1559 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1560 while (!SCM_NULLP (formals
))
1562 if (!SCM_CONSP (formals
))
1567 formals
= SCM_CDR (formals
);
1574 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1576 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1577 while (SCM_CONSP (l
))
1579 res
= EVALCAR (l
, env
);
1581 *lloc
= scm_list_1 (res
);
1582 lloc
= SCM_CDRLOC (*lloc
);
1587 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
);
1795 scm_wrong_num_args (proc
);
1803 /* SECTION: This code is compiled twice.
1807 /* Update the toplevel environment frame ENV so that it refers to the
1808 * current module. */
1809 #define UPDATE_TOPLEVEL_ENV(env) \
1811 SCM p = scm_current_module_lookup_closure (); \
1812 if (p != SCM_CAR(env)) \
1813 env = scm_top_level_env (p); \
1817 /* This is the evaluator. Like any real monster, it has three heads:
1819 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1820 * version. Both are implemented using a common code base, using the
1821 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1822 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1823 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1824 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1825 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1826 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1827 * are enclosed within #ifdef DEVAL ... #endif.
1829 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1830 * take two input parameters, x and env: x is a single expression to be
1831 * evalutated. env is the environment in which bindings are searched.
1833 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1834 * is a single expression, it is necessarily in a tail position. If x is just
1835 * a call to another function like in the expression (foo exp1 exp2 ...), the
1836 * realization of that call therefore _must_not_ increase stack usage (the
1837 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1838 * making extensive use of 'goto' statements within the evaluator: The gotos
1839 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1840 * that SCM_CEVAL was already using. If, however, x represents some form that
1841 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1842 * then recursive calls to SCM_CEVAL are performed for all but the last
1843 * expression of that sequence. */
1847 scm_ceval (SCM x
, SCM env
)
1853 scm_deval (SCM x
, SCM env
)
1858 SCM_CEVAL (SCM x
, SCM env
)
1862 scm_t_debug_frame debug
;
1863 scm_t_debug_info
*debug_info_end
;
1864 debug
.prev
= scm_last_debug_frame
;
1867 * The debug.vect contains twice as much scm_t_debug_info frames as the
1868 * user has specified with (debug-set! frames <n>).
1870 * Even frames are eval frames, odd frames are apply frames.
1872 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1873 * sizeof (scm_t_debug_info
));
1874 debug
.info
= debug
.vect
;
1875 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1876 scm_last_debug_frame
= &debug
;
1878 #ifdef EVAL_STACK_CHECKING
1879 if (scm_stack_checking_enabled_p
1880 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1883 debug
.info
->e
.exp
= x
;
1884 debug
.info
->e
.env
= env
;
1886 scm_report_stack_overflow ();
1896 SCM_CLEAR_ARGSREADY (debug
);
1897 if (SCM_OVERFLOWP (debug
))
1900 * In theory, this should be the only place where it is necessary to
1901 * check for space in debug.vect since both eval frames and
1902 * available space are even.
1904 * For this to be the case, however, it is necessary that primitive
1905 * special forms which jump back to `loop', `begin' or some similar
1906 * label call PREP_APPLY.
1908 else if (++debug
.info
>= debug_info_end
)
1910 SCM_SET_OVERFLOW (debug
);
1915 debug
.info
->e
.exp
= x
;
1916 debug
.info
->e
.env
= env
;
1917 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1919 if (SCM_ENTER_FRAME_P
1920 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1923 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1924 SCM_SET_TAILREC (debug
);
1925 if (SCM_CHEAPTRAPS_P
)
1926 stackrep
= scm_make_debugobj (&debug
);
1930 SCM val
= scm_make_continuation (&first
);
1940 /* This gives the possibility for the debugger to
1941 modify the source expression before evaluation. */
1946 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1947 scm_sym_enter_frame
,
1950 scm_unmemocopy (x
, env
));
1955 #if defined (USE_THREADS) || defined (DEVAL)
1959 switch (SCM_TYP7 (x
))
1961 case scm_tc7_symbol
:
1962 /* Only happens when called at top level. */
1963 x
= scm_cons (x
, SCM_UNDEFINED
);
1964 RETURN (*scm_lookupcar (x
, env
, 1));
1966 case SCM_BIT8 (SCM_IM_AND
):
1968 while (!SCM_NULLP (SCM_CDR (x
)))
1970 SCM test_result
= EVALCAR (x
, env
);
1971 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1972 RETURN (SCM_BOOL_F
);
1976 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1979 case SCM_BIT8 (SCM_IM_BEGIN
):
1982 RETURN (SCM_UNSPECIFIED
);
1984 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1987 /* If we are on toplevel with a lookup closure, we need to sync
1988 with the current module. */
1989 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1991 UPDATE_TOPLEVEL_ENV (env
);
1992 while (!SCM_NULLP (SCM_CDR (x
)))
1995 UPDATE_TOPLEVEL_ENV (env
);
2001 goto nontoplevel_begin
;
2004 while (!SCM_NULLP (SCM_CDR (x
)))
2006 SCM form
= SCM_CAR (x
);
2009 if (SCM_ISYMP (form
))
2011 x
= scm_m_expand_body (x
, env
);
2012 goto nontoplevel_begin
;
2015 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
2018 SCM_CEVAL (form
, env
);
2024 /* scm_eval last form in list */
2025 SCM last_form
= SCM_CAR (x
);
2027 if (SCM_CONSP (last_form
))
2029 /* This is by far the most frequent case. */
2031 goto loop
; /* tail recurse */
2033 else if (SCM_IMP (last_form
))
2034 RETURN (SCM_EVALIM (last_form
, env
));
2035 else if (SCM_VARIABLEP (last_form
))
2036 RETURN (SCM_VARIABLE_REF (last_form
));
2037 else if (SCM_SYMBOLP (last_form
))
2038 RETURN (*scm_lookupcar (x
, env
, 1));
2044 case SCM_BIT8 (SCM_IM_CASE
):
2047 SCM key
= EVALCAR (x
, env
);
2049 while (!SCM_NULLP (x
))
2051 SCM clause
= SCM_CAR (x
);
2052 SCM labels
= SCM_CAR (clause
);
2053 if (SCM_EQ_P (labels
, scm_sym_else
))
2055 x
= SCM_CDR (clause
);
2056 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2059 while (!SCM_NULLP (labels
))
2061 SCM label
= SCM_CAR (labels
);
2062 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2064 x
= SCM_CDR (clause
);
2065 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2068 labels
= SCM_CDR (labels
);
2073 RETURN (SCM_UNSPECIFIED
);
2076 case SCM_BIT8 (SCM_IM_COND
):
2078 while (!SCM_NULLP (x
))
2080 SCM clause
= SCM_CAR (x
);
2081 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2083 x
= SCM_CDR (clause
);
2084 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2089 arg1
= EVALCAR (clause
, env
);
2090 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2092 x
= SCM_CDR (clause
);
2095 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2097 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2103 proc
= EVALCAR (proc
, env
);
2104 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2105 PREP_APPLY (proc
, scm_list_1 (arg1
));
2107 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2108 goto umwrongnumargs
;
2116 RETURN (SCM_UNSPECIFIED
);
2119 case SCM_BIT8 (SCM_IM_DO
):
2122 /* Compute the initialization values and the initial environment. */
2123 SCM init_forms
= SCM_CADR (x
);
2124 SCM init_values
= SCM_EOL
;
2125 while (!SCM_NULLP (init_forms
))
2127 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2128 init_forms
= SCM_CDR (init_forms
);
2130 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2134 SCM test_form
= SCM_CAR (x
);
2135 SCM body_forms
= SCM_CADR (x
);
2136 SCM step_forms
= SCM_CDDR (x
);
2138 SCM test_result
= EVALCAR (test_form
, env
);
2140 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2143 /* Evaluate body forms. */
2145 for (temp_forms
= body_forms
;
2146 !SCM_NULLP (temp_forms
);
2147 temp_forms
= SCM_CDR (temp_forms
))
2149 SCM form
= SCM_CAR (temp_forms
);
2150 /* Dirk:FIXME: We only need to eval forms, that may have a
2151 * side effect here. This is only true for forms that start
2152 * with a pair. All others are just constants. However,
2153 * since in the common case there is no constant expression
2154 * in a body of a do form, we just check for immediates here
2155 * and have SCM_CEVAL take care of other cases. In the long
2156 * run it would make sense to get rid of this test and have
2157 * the macro transformer of 'do' eliminate all forms that
2158 * have no sideeffect. */
2159 if (!SCM_IMP (form
))
2160 SCM_CEVAL (form
, env
);
2165 /* Evaluate the step expressions. */
2167 SCM step_values
= SCM_EOL
;
2168 for (temp_forms
= step_forms
;
2169 !SCM_NULLP (temp_forms
);
2170 temp_forms
= SCM_CDR (temp_forms
))
2172 SCM value
= EVALCAR (temp_forms
, env
);
2173 step_values
= scm_cons (value
, step_values
);
2175 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2178 test_result
= EVALCAR (test_form
, env
);
2183 RETURN (SCM_UNSPECIFIED
);
2184 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2185 goto nontoplevel_begin
;
2188 case SCM_BIT8 (SCM_IM_IF
):
2191 SCM test_result
= EVALCAR (x
, env
);
2192 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2198 RETURN (SCM_UNSPECIFIED
);
2201 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2205 case SCM_BIT8 (SCM_IM_LET
):
2208 SCM init_forms
= SCM_CADR (x
);
2209 SCM init_values
= SCM_EOL
;
2212 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2213 init_forms
= SCM_CDR (init_forms
);
2215 while (!SCM_NULLP (init_forms
));
2216 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2219 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2220 goto nontoplevel_begin
;
2223 case SCM_BIT8 (SCM_IM_LETREC
):
2225 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2228 SCM init_forms
= SCM_CAR (x
);
2229 SCM init_values
= SCM_EOL
;
2232 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2233 init_forms
= SCM_CDR (init_forms
);
2235 while (!SCM_NULLP (init_forms
));
2236 SCM_SETCDR (SCM_CAR (env
), init_values
);
2239 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2240 goto nontoplevel_begin
;
2243 case SCM_BIT8 (SCM_IM_LETSTAR
):
2246 SCM bindings
= SCM_CAR (x
);
2247 if (SCM_NULLP (bindings
))
2248 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2253 SCM name
= SCM_CAR (bindings
);
2254 SCM init
= SCM_CDR (bindings
);
2255 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2256 bindings
= SCM_CDR (init
);
2258 while (!SCM_NULLP (bindings
));
2262 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2263 goto nontoplevel_begin
;
2266 case SCM_BIT8 (SCM_IM_OR
):
2268 while (!SCM_NULLP (SCM_CDR (x
)))
2270 SCM val
= EVALCAR (x
, env
);
2271 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2276 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2280 case SCM_BIT8 (SCM_IM_LAMBDA
):
2281 RETURN (scm_closure (SCM_CDR (x
), env
));
2284 case SCM_BIT8 (SCM_IM_QUOTE
):
2285 RETURN (SCM_CADR (x
));
2288 case SCM_BIT8 (SCM_IM_SET_X
):
2292 SCM variable
= SCM_CAR (x
);
2293 if (SCM_ILOCP (variable
))
2294 location
= scm_ilookup (variable
, env
);
2296 if (SCM_VARIABLEP (variable
))
2297 location
= SCM_VARIABLE_LOC (variable
);
2298 else /* (SCM_SYMBOLP (variable)) is known to be true */
2299 location
= scm_lookupcar (x
, env
, 1);
2301 *location
= EVALCAR (x
, env
);
2303 RETURN (SCM_UNSPECIFIED
);
2306 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2307 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2310 /* new syntactic forms go here. */
2311 case SCM_BIT8 (SCM_MAKISYM (0)):
2313 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2314 switch (SCM_ISYMNUM (proc
))
2318 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2320 proc
= EVALCAR (proc
, env
);
2321 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2322 if (SCM_CLOSUREP (proc
))
2324 PREP_APPLY (proc
, SCM_EOL
);
2325 arg1
= SCM_CDDR (x
);
2326 arg1
= EVALCAR (arg1
, env
);
2328 /* Go here to tail-call a closure. PROC is the closure
2329 and ARG1 is the list of arguments. Do not forget to
2332 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2334 debug
.info
->a
.args
= arg1
;
2336 if (scm_badargsp (formals
, arg1
))
2337 scm_wrong_num_args (proc
);
2339 /* Copy argument list */
2340 if (SCM_NULL_OR_NIL_P (arg1
))
2341 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2344 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2346 arg1
= SCM_CDR (arg1
);
2347 while (!SCM_NULL_OR_NIL_P (arg1
))
2349 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2350 SCM_SETCDR (tail
, new_tail
);
2352 arg1
= SCM_CDR (arg1
);
2354 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2357 x
= SCM_CLOSURE_BODY (proc
);
2358 goto nontoplevel_begin
;
2368 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2371 SCM val
= scm_make_continuation (&first
);
2379 proc
= scm_eval_car (proc
, env
);
2380 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2381 PREP_APPLY (proc
, scm_list_1 (arg1
));
2383 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2384 goto umwrongnumargs
;
2390 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2391 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2394 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2396 /* If not done yet, evaluate the operand forms. The result is a
2397 * list of arguments stored in arg1, which is used to perform the
2398 * function dispatch. */
2399 SCM operand_forms
= SCM_CADR (x
);
2400 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2401 if (SCM_ILOCP (operand_forms
))
2402 arg1
= *scm_ilookup (operand_forms
, env
);
2403 else if (SCM_VARIABLEP (operand_forms
))
2404 arg1
= SCM_VARIABLE_REF (operand_forms
);
2405 else if (!SCM_CONSP (operand_forms
))
2406 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2409 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2410 operand_forms
= SCM_CDR (operand_forms
);
2411 while (!SCM_NULLP (operand_forms
))
2413 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2414 SCM_SETCDR (tail
, new_tail
);
2416 operand_forms
= SCM_CDR (operand_forms
);
2421 /* The type dispatch code is duplicated below
2422 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2423 * cuts down execution time for type dispatch to 50%. */
2424 type_dispatch
: /* inputs: x, arg1 */
2425 /* Type dispatch means to determine from the types of the function
2426 * arguments (i. e. the 'signature' of the call), which method from
2427 * a generic function is to be called. This process of selecting
2428 * the right method takes some time. To speed it up, guile uses
2429 * caching: Together with the macro call to dispatch the signatures
2430 * of some previous calls to that generic function from the same
2431 * place are stored (in the code!) in a cache that we call the
2432 * 'method cache'. This is done since it is likely, that
2433 * consecutive calls to dispatch from that position in the code will
2434 * have the same signature. Thus, the type dispatch works as
2435 * follows: First, determine a hash value from the signature of the
2436 * actual arguments. Second, use this hash value as an index to
2437 * find that same signature in the method cache stored at this
2438 * position in the code. If found, you have also found the
2439 * corresponding method that belongs to that signature. If the
2440 * signature is not found in the method cache, you have to perform a
2441 * full search over all signatures stored with the generic
2444 unsigned long int specializers
;
2445 unsigned long int hash_value
;
2446 unsigned long int cache_end_pos
;
2447 unsigned long int mask
;
2451 SCM z
= SCM_CDDR (x
);
2452 SCM tmp
= SCM_CADR (z
);
2453 specializers
= SCM_INUM (SCM_CAR (z
));
2455 /* Compute a hash value for searching the method cache. There
2456 * are two variants for computing the hash value, a (rather)
2457 * complicated one, and a simple one. For the complicated one
2458 * explained below, tmp holds a number that is used in the
2460 if (SCM_INUMP (tmp
))
2462 /* Use the signature of the actual arguments to determine
2463 * the hash value. This is done as follows: Each class has
2464 * an array of random numbers, that are determined when the
2465 * class is created. The integer 'hashset' is an index into
2466 * that array of random numbers. Now, from all classes that
2467 * are part of the signature of the actual arguments, the
2468 * random numbers at index 'hashset' are taken and summed
2469 * up, giving the hash value. The value of 'hashset' is
2470 * stored at the call to dispatch. This allows to have
2471 * different 'formulas' for calculating the hash value at
2472 * different places where dispatch is called. This allows
2473 * to optimize the hash formula at every individual place
2474 * where dispatch is called, such that hopefully the hash
2475 * value that is computed will directly point to the right
2476 * method in the method cache. */
2477 unsigned long int hashset
= SCM_INUM (tmp
);
2478 unsigned long int counter
= specializers
+ 1;
2481 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2483 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2484 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2485 tmp_arg
= SCM_CDR (tmp_arg
);
2489 method_cache
= SCM_CADR (z
);
2490 mask
= SCM_INUM (SCM_CAR (z
));
2492 cache_end_pos
= hash_value
;
2496 /* This method of determining the hash value is much
2497 * simpler: Set the hash value to zero and just perform a
2498 * linear search through the method cache. */
2500 mask
= (unsigned long int) ((long) -1);
2502 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2507 /* Search the method cache for a method with a matching
2508 * signature. Start the search at position 'hash_value'. The
2509 * hashing implementation uses linear probing for conflict
2510 * resolution, that is, if the signature in question is not
2511 * found at the starting index in the hash table, the next table
2512 * entry is tried, and so on, until in the worst case the whole
2513 * cache has been searched, but still the signature has not been
2518 SCM args
= arg1
; /* list of arguments */
2519 z
= SCM_VELTS (method_cache
)[hash_value
];
2520 while (!SCM_NULLP (args
))
2522 /* More arguments than specifiers => CLASS != ENV */
2523 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2524 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2526 args
= SCM_CDR (args
);
2529 /* Fewer arguments than specifiers => CAR != ENV */
2530 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2533 hash_value
= (hash_value
+ 1) & mask
;
2534 } while (hash_value
!= cache_end_pos
);
2536 /* No appropriate method was found in the cache. */
2537 z
= scm_memoize_method (x
, arg1
);
2539 apply_cmethod
: /* inputs: z, arg1 */
2541 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2542 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2543 x
= SCM_CMETHOD_BODY (z
);
2544 goto nontoplevel_begin
;
2550 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2553 SCM instance
= EVALCAR (x
, env
);
2554 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2555 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2559 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2562 SCM instance
= EVALCAR (x
, env
);
2563 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2564 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2565 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2566 RETURN (SCM_UNSPECIFIED
);
2570 #ifdef SCM_ENABLE_ELISP
2572 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2574 SCM test_form
= SCM_CDR (x
);
2575 x
= SCM_CDR (test_form
);
2576 while (!SCM_NULL_OR_NIL_P (x
))
2578 SCM test_result
= EVALCAR (test_form
, env
);
2579 if (!(SCM_FALSEP (test_result
)
2580 || SCM_NULL_OR_NIL_P (test_result
)))
2582 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2583 RETURN (test_result
);
2584 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2589 test_form
= SCM_CDR (x
);
2590 x
= SCM_CDR (test_form
);
2594 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2598 #endif /* SCM_ENABLE_ELISP */
2600 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2602 SCM vars
, exps
, vals
;
2605 vars
= SCM_CAAR (x
);
2606 exps
= SCM_CDAR (x
);
2610 while (SCM_NIMP (exps
))
2612 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2613 exps
= SCM_CDR (exps
);
2616 scm_swap_bindings (vars
, vals
);
2617 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2619 /* Ignore all but the last evaluation result. */
2620 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2622 if (SCM_CONSP (SCM_CAR (x
)))
2623 SCM_CEVAL (SCM_CAR (x
), env
);
2625 proc
= EVALCAR (x
, env
);
2627 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2628 scm_swap_bindings (vars
, vals
);
2634 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2637 x
= EVALCAR (proc
, env
);
2638 proc
= SCM_CDR (proc
);
2639 proc
= EVALCAR (proc
, env
);
2640 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2641 if (SCM_VALUESP (arg1
))
2642 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2644 arg1
= scm_list_1 (arg1
);
2645 if (SCM_CLOSUREP (proc
))
2647 PREP_APPLY (proc
, arg1
);
2650 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2661 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2662 case scm_tc7_vector
:
2666 case scm_tc7_byvect
:
2673 #ifdef HAVE_LONG_LONGS
2674 case scm_tc7_llvect
:
2677 case scm_tc7_string
:
2679 case scm_tcs_closures
:
2683 case scm_tcs_struct
:
2686 case scm_tc7_variable
:
2687 RETURN (SCM_VARIABLE_REF(x
));
2689 case SCM_BIT8(SCM_ILOC00
):
2690 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2691 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2697 case scm_tcs_cons_nimcar
:
2698 if (SCM_SYMBOLP (SCM_CAR (x
)))
2700 SCM orig_sym
= SCM_CAR (x
);
2703 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2704 if (location
== NULL
)
2706 /* we have lost the race, start again. */
2712 proc
= *scm_lookupcar (x
, env
, 1);
2717 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2721 if (SCM_MACROP (proc
))
2723 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2725 handle_a_macro
: /* inputs: x, env, proc */
2727 /* Set a flag during macro expansion so that macro
2728 application frames can be deleted from the backtrace. */
2729 SCM_SET_MACROEXP (debug
);
2731 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2732 scm_cons (env
, scm_listofnull
));
2735 SCM_CLEAR_MACROEXP (debug
);
2737 switch (SCM_MACRO_TYPE (proc
))
2740 if (scm_ilength (arg1
) <= 0)
2741 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2743 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2746 SCM_SETCAR (x
, SCM_CAR (arg1
));
2747 SCM_SETCDR (x
, SCM_CDR (arg1
));
2751 /* Prevent memoizing of debug info expression. */
2752 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2757 SCM_SETCAR (x
, SCM_CAR (arg1
));
2758 SCM_SETCDR (x
, SCM_CDR (arg1
));
2760 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2766 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2777 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2778 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2782 if (SCM_CLOSUREP (proc
))
2784 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2785 SCM args
= SCM_CDR (x
);
2786 while (!SCM_NULLP (formals
))
2788 if (!SCM_CONSP (formals
))
2791 goto umwrongnumargs
;
2792 formals
= SCM_CDR (formals
);
2793 args
= SCM_CDR (args
);
2795 if (!SCM_NULLP (args
))
2796 goto umwrongnumargs
;
2798 else if (SCM_MACROP (proc
))
2799 goto handle_a_macro
;
2803 evapply
: /* inputs: x, proc */
2804 PREP_APPLY (proc
, SCM_EOL
);
2805 if (SCM_NULLP (SCM_CDR (x
))) {
2808 switch (SCM_TYP7 (proc
))
2809 { /* no arguments given */
2810 case scm_tc7_subr_0
:
2811 RETURN (SCM_SUBRF (proc
) ());
2812 case scm_tc7_subr_1o
:
2813 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2815 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2816 case scm_tc7_rpsubr
:
2817 RETURN (SCM_BOOL_T
);
2819 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2821 if (!SCM_SMOB_APPLICABLE_P (proc
))
2823 RETURN (SCM_SMOB_APPLY_0 (proc
));
2826 proc
= SCM_CCLO_SUBR (proc
);
2828 debug
.info
->a
.proc
= proc
;
2829 debug
.info
->a
.args
= scm_list_1 (arg1
);
2833 proc
= SCM_PROCEDURE (proc
);
2835 debug
.info
->a
.proc
= proc
;
2837 if (!SCM_CLOSUREP (proc
))
2839 if (scm_badformalsp (proc
, 0))
2840 goto umwrongnumargs
;
2841 case scm_tcs_closures
:
2842 x
= SCM_CLOSURE_BODY (proc
);
2843 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2844 goto nontoplevel_begin
;
2845 case scm_tcs_struct
:
2846 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2848 x
= SCM_ENTITY_PROCEDURE (proc
);
2852 else if (!SCM_I_OPERATORP (proc
))
2857 proc
= (SCM_I_ENTITYP (proc
)
2858 ? SCM_ENTITY_PROCEDURE (proc
)
2859 : SCM_OPERATOR_PROCEDURE (proc
));
2861 debug
.info
->a
.proc
= proc
;
2862 debug
.info
->a
.args
= scm_list_1 (arg1
);
2864 if (SCM_NIMP (proc
))
2869 case scm_tc7_subr_1
:
2870 case scm_tc7_subr_2
:
2871 case scm_tc7_subr_2o
:
2873 case scm_tc7_subr_3
:
2874 case scm_tc7_lsubr_2
:
2877 scm_wrong_num_args (proc
);
2879 /* handle macros here */
2884 /* must handle macros by here */
2888 arg1
= EVALCAR (x
, env
);
2890 scm_wrong_num_args (proc
);
2892 arg1
= EVALCAR (x
, env
);
2895 debug
.info
->a
.args
= scm_list_1 (arg1
);
2903 evap1
: /* inputs: proc, arg1 */
2904 switch (SCM_TYP7 (proc
))
2905 { /* have one argument in arg1 */
2906 case scm_tc7_subr_2o
:
2907 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2908 case scm_tc7_subr_1
:
2909 case scm_tc7_subr_1o
:
2910 RETURN (SCM_SUBRF (proc
) (arg1
));
2912 if (SCM_SUBRF (proc
))
2914 if (SCM_INUMP (arg1
))
2916 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2918 else if (SCM_REALP (arg1
))
2920 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2923 else if (SCM_BIGP (arg1
))
2925 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2928 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2929 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2931 proc
= SCM_SNAME (proc
);
2933 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2934 while ('c' != *--chrs
)
2936 SCM_ASSERT (SCM_CONSP (arg1
),
2937 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2938 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2942 case scm_tc7_rpsubr
:
2943 RETURN (SCM_BOOL_T
);
2945 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2948 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2950 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2953 if (!SCM_SMOB_APPLICABLE_P (proc
))
2955 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2959 proc
= SCM_CCLO_SUBR (proc
);
2961 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2962 debug
.info
->a
.proc
= proc
;
2966 proc
= SCM_PROCEDURE (proc
);
2968 debug
.info
->a
.proc
= proc
;
2970 if (!SCM_CLOSUREP (proc
))
2972 if (scm_badformalsp (proc
, 1))
2973 goto umwrongnumargs
;
2974 case scm_tcs_closures
:
2976 x
= SCM_CLOSURE_BODY (proc
);
2978 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2980 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2982 goto nontoplevel_begin
;
2983 case scm_tcs_struct
:
2984 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2986 x
= SCM_ENTITY_PROCEDURE (proc
);
2988 arg1
= debug
.info
->a
.args
;
2990 arg1
= scm_list_1 (arg1
);
2994 else if (!SCM_I_OPERATORP (proc
))
3000 proc
= (SCM_I_ENTITYP (proc
)
3001 ? SCM_ENTITY_PROCEDURE (proc
)
3002 : SCM_OPERATOR_PROCEDURE (proc
));
3004 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3005 debug
.info
->a
.proc
= proc
;
3007 if (SCM_NIMP (proc
))
3012 case scm_tc7_subr_2
:
3013 case scm_tc7_subr_0
:
3014 case scm_tc7_subr_3
:
3015 case scm_tc7_lsubr_2
:
3016 scm_wrong_num_args (proc
);
3023 arg2
= EVALCAR (x
, env
);
3025 scm_wrong_num_args (proc
);
3027 arg2
= EVALCAR (x
, env
);
3029 { /* have two or more arguments */
3031 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3034 if (SCM_NULLP (x
)) {
3037 switch (SCM_TYP7 (proc
))
3038 { /* have two arguments */
3039 case scm_tc7_subr_2
:
3040 case scm_tc7_subr_2o
:
3041 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3044 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3046 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3048 case scm_tc7_lsubr_2
:
3049 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3050 case scm_tc7_rpsubr
:
3052 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3054 if (!SCM_SMOB_APPLICABLE_P (proc
))
3056 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3060 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3061 scm_cons (proc
, debug
.info
->a
.args
),
3064 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3065 scm_cons2 (proc
, arg1
,
3072 case scm_tcs_struct
:
3073 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3075 x
= SCM_ENTITY_PROCEDURE (proc
);
3077 arg1
= debug
.info
->a
.args
;
3079 arg1
= scm_list_2 (arg1
, arg2
);
3083 else if (!SCM_I_OPERATORP (proc
))
3089 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3090 ? SCM_ENTITY_PROCEDURE (proc
)
3091 : SCM_OPERATOR_PROCEDURE (proc
),
3092 scm_cons (proc
, debug
.info
->a
.args
),
3095 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3096 ? SCM_ENTITY_PROCEDURE (proc
)
3097 : SCM_OPERATOR_PROCEDURE (proc
),
3098 scm_cons2 (proc
, arg1
,
3106 case scm_tc7_subr_0
:
3108 case scm_tc7_subr_1o
:
3109 case scm_tc7_subr_1
:
3110 case scm_tc7_subr_3
:
3111 scm_wrong_num_args (proc
);
3115 proc
= SCM_PROCEDURE (proc
);
3117 debug
.info
->a
.proc
= proc
;
3119 if (!SCM_CLOSUREP (proc
))
3121 if (scm_badformalsp (proc
, 2))
3122 goto umwrongnumargs
;
3123 case scm_tcs_closures
:
3126 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3130 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3131 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3133 x
= SCM_CLOSURE_BODY (proc
);
3134 goto nontoplevel_begin
;
3139 scm_wrong_num_args (proc
);
3142 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3143 deval_args (x
, env
, proc
,
3144 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3148 switch (SCM_TYP7 (proc
))
3149 { /* have 3 or more arguments */
3151 case scm_tc7_subr_3
:
3152 if (!SCM_NULLP (SCM_CDR (x
)))
3153 scm_wrong_num_args (proc
);
3155 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3156 SCM_CADDR (debug
.info
->a
.args
)));
3158 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3159 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3162 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3163 arg2
= SCM_CDR (arg2
);
3165 while (SCM_NIMP (arg2
));
3167 case scm_tc7_rpsubr
:
3168 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3169 RETURN (SCM_BOOL_F
);
3170 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3173 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3174 RETURN (SCM_BOOL_F
);
3175 arg2
= SCM_CAR (arg1
);
3176 arg1
= SCM_CDR (arg1
);
3178 while (SCM_NIMP (arg1
));
3179 RETURN (SCM_BOOL_T
);
3180 case scm_tc7_lsubr_2
:
3181 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3182 SCM_CDDR (debug
.info
->a
.args
)));
3184 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3186 if (!SCM_SMOB_APPLICABLE_P (proc
))
3188 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3189 SCM_CDDR (debug
.info
->a
.args
)));
3193 proc
= SCM_PROCEDURE (proc
);
3194 debug
.info
->a
.proc
= proc
;
3195 if (!SCM_CLOSUREP (proc
))
3197 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3198 goto umwrongnumargs
;
3199 case scm_tcs_closures
:
3200 SCM_SET_ARGSREADY (debug
);
3201 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3204 x
= SCM_CLOSURE_BODY (proc
);
3205 goto nontoplevel_begin
;
3207 case scm_tc7_subr_3
:
3208 if (!SCM_NULLP (SCM_CDR (x
)))
3209 scm_wrong_num_args (proc
);
3211 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3213 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3216 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3219 while (SCM_NIMP (x
));
3221 case scm_tc7_rpsubr
:
3222 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3223 RETURN (SCM_BOOL_F
);
3226 arg1
= EVALCAR (x
, env
);
3227 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3228 RETURN (SCM_BOOL_F
);
3232 while (SCM_NIMP (x
));
3233 RETURN (SCM_BOOL_T
);
3234 case scm_tc7_lsubr_2
:
3235 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3237 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3239 scm_eval_args (x
, env
, proc
))));
3241 if (!SCM_SMOB_APPLICABLE_P (proc
))
3243 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3244 scm_eval_args (x
, env
, proc
)));
3248 proc
= SCM_PROCEDURE (proc
);
3249 if (!SCM_CLOSUREP (proc
))
3252 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3253 if (SCM_NULLP (formals
)
3254 || (SCM_CONSP (formals
)
3255 && (SCM_NULLP (SCM_CDR (formals
))
3256 || (SCM_CONSP (SCM_CDR (formals
))
3257 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3258 goto umwrongnumargs
;
3260 case scm_tcs_closures
:
3262 SCM_SET_ARGSREADY (debug
);
3264 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3267 scm_eval_args (x
, env
, proc
)),
3269 x
= SCM_CLOSURE_BODY (proc
);
3270 goto nontoplevel_begin
;
3272 case scm_tcs_struct
:
3273 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3276 arg1
= debug
.info
->a
.args
;
3278 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3280 x
= SCM_ENTITY_PROCEDURE (proc
);
3283 else if (!SCM_I_OPERATORP (proc
))
3287 case scm_tc7_subr_2
:
3288 case scm_tc7_subr_1o
:
3289 case scm_tc7_subr_2o
:
3290 case scm_tc7_subr_0
:
3292 case scm_tc7_subr_1
:
3293 scm_wrong_num_args (proc
);
3301 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3302 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3304 SCM_CLEAR_TRACED_FRAME (debug
);
3305 if (SCM_CHEAPTRAPS_P
)
3306 arg1
= scm_make_debugobj (&debug
);
3310 SCM val
= scm_make_continuation (&first
);
3321 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3325 scm_last_debug_frame
= debug
.prev
;
3331 /* SECTION: This code is compiled once.
3337 /* Simple procedure calls
3341 scm_call_0 (SCM proc
)
3343 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3347 scm_call_1 (SCM proc
, SCM arg1
)
3349 return scm_apply (proc
, arg1
, scm_listofnull
);
3353 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3355 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3359 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3361 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3365 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3367 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3368 scm_cons (arg4
, scm_listofnull
)));
3371 /* Simple procedure applies
3375 scm_apply_0 (SCM proc
, SCM args
)
3377 return scm_apply (proc
, args
, SCM_EOL
);
3381 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3383 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3387 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3389 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3393 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3395 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3399 /* This code processes the arguments to apply:
3401 (apply PROC ARG1 ... ARGS)
3403 Given a list (ARG1 ... ARGS), this function conses the ARG1
3404 ... arguments onto the front of ARGS, and returns the resulting
3405 list. Note that ARGS is a list; thus, the argument to this
3406 function is a list whose last element is a list.
3408 Apply calls this function, and applies PROC to the elements of the
3409 result. apply:nconc2last takes care of building the list of
3410 arguments, given (ARG1 ... ARGS).
3412 Rather than do new consing, apply:nconc2last destroys its argument.
3413 On that topic, this code came into my care with the following
3414 beautifully cryptic comment on that topic: "This will only screw
3415 you if you do (scm_apply scm_apply '( ... ))" If you know what
3416 they're referring to, send me a patch to this comment. */
3418 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3420 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3421 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3422 "@var{args}, and returns the resulting list. Note that\n"
3423 "@var{args} is a list; thus, the argument to this function is\n"
3424 "a list whose last element is a list.\n"
3425 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3426 "destroys its argument, so use with care.")
3427 #define FUNC_NAME s_scm_nconc2last
3430 SCM_VALIDATE_NONEMPTYLIST (1,lst
);
3432 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3433 SCM_NULL_OR_NIL_P, but not
3434 needed in 99.99% of cases,
3435 and it could seriously hurt
3436 performance. - Neil */
3437 lloc
= SCM_CDRLOC (*lloc
);
3438 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3439 *lloc
= SCM_CAR (*lloc
);
3447 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3448 * It is compiled twice.
3453 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3459 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3464 /* Apply a function to a list of arguments.
3466 This function is exported to the Scheme level as taking two
3467 required arguments and a tail argument, as if it were:
3468 (lambda (proc arg1 . args) ...)
3469 Thus, if you just have a list of arguments to pass to a procedure,
3470 pass the list as ARG1, and '() for ARGS. If you have some fixed
3471 args, pass the first as ARG1, then cons any remaining fixed args
3472 onto the front of your argument list, and pass that as ARGS. */
3475 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3477 #ifdef DEBUG_EXTENSIONS
3479 scm_t_debug_frame debug
;
3480 scm_t_debug_info debug_vect_body
;
3481 debug
.prev
= scm_last_debug_frame
;
3482 debug
.status
= SCM_APPLYFRAME
;
3483 debug
.vect
= &debug_vect_body
;
3484 debug
.vect
[0].a
.proc
= proc
;
3485 debug
.vect
[0].a
.args
= SCM_EOL
;
3486 scm_last_debug_frame
= &debug
;
3489 return scm_dapply (proc
, arg1
, args
);
3493 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3495 /* If ARGS is the empty list, then we're calling apply with only two
3496 arguments --- ARG1 is the list of arguments for PROC. Whatever
3497 the case, futz with things so that ARG1 is the first argument to
3498 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3501 Setting the debug apply frame args this way is pretty messy.
3502 Perhaps we should store arg1 and args directly in the frame as
3503 received, and let scm_frame_arguments unpack them, because that's
3504 a relatively rare operation. This works for now; if the Guile
3505 developer archives are still around, see Mikael's post of
3507 if (SCM_NULLP (args
))
3509 if (SCM_NULLP (arg1
))
3511 arg1
= SCM_UNDEFINED
;
3513 debug
.vect
[0].a
.args
= SCM_EOL
;
3519 debug
.vect
[0].a
.args
= arg1
;
3521 args
= SCM_CDR (arg1
);
3522 arg1
= SCM_CAR (arg1
);
3527 args
= scm_nconc2last (args
);
3529 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3533 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3536 if (SCM_CHEAPTRAPS_P
)
3537 tmp
= scm_make_debugobj (&debug
);
3542 tmp
= scm_make_continuation (&first
);
3547 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3554 switch (SCM_TYP7 (proc
))
3556 case scm_tc7_subr_2o
:
3557 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3558 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3559 case scm_tc7_subr_2
:
3560 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3561 scm_wrong_num_args (proc
);
3562 args
= SCM_CAR (args
);
3563 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3564 case scm_tc7_subr_0
:
3565 if (!SCM_UNBNDP (arg1
))
3566 scm_wrong_num_args (proc
);
3568 RETURN (SCM_SUBRF (proc
) ());
3569 case scm_tc7_subr_1
:
3570 if (SCM_UNBNDP (arg1
))
3571 scm_wrong_num_args (proc
);
3572 case scm_tc7_subr_1o
:
3573 if (!SCM_NULLP (args
))
3574 scm_wrong_num_args (proc
);
3576 RETURN (SCM_SUBRF (proc
) (arg1
));
3578 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3579 scm_wrong_num_args (proc
);
3580 if (SCM_SUBRF (proc
))
3582 if (SCM_INUMP (arg1
))
3584 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3586 else if (SCM_REALP (arg1
))
3588 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3591 else if (SCM_BIGP (arg1
))
3592 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3594 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3595 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3597 proc
= SCM_SNAME (proc
);
3599 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3600 while ('c' != *--chrs
)
3602 SCM_ASSERT (SCM_CONSP (arg1
),
3603 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3604 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3608 case scm_tc7_subr_3
:
3609 if (SCM_NULLP (args
)
3610 || SCM_NULLP (SCM_CDR (args
))
3611 || !SCM_NULLP (SCM_CDDR (args
)))
3612 scm_wrong_num_args (proc
);
3614 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3617 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3619 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3621 case scm_tc7_lsubr_2
:
3622 if (!SCM_CONSP (args
))
3623 scm_wrong_num_args (proc
);
3625 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3627 if (SCM_NULLP (args
))
3628 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3629 while (SCM_NIMP (args
))
3631 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3632 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3633 args
= SCM_CDR (args
);
3636 case scm_tc7_rpsubr
:
3637 if (SCM_NULLP (args
))
3638 RETURN (SCM_BOOL_T
);
3639 while (SCM_NIMP (args
))
3641 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3642 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3643 RETURN (SCM_BOOL_F
);
3644 arg1
= SCM_CAR (args
);
3645 args
= SCM_CDR (args
);
3647 RETURN (SCM_BOOL_T
);
3648 case scm_tcs_closures
:
3650 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3652 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3654 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3655 scm_wrong_num_args (proc
);
3657 /* Copy argument list */
3662 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3663 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3665 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3669 SCM_SETCDR (tl
, arg1
);
3672 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3673 proc
= SCM_CLOSURE_BODY (proc
);
3676 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3678 if (SCM_IMP (SCM_CAR (proc
)))
3680 if (SCM_ISYMP (SCM_CAR (proc
)))
3682 proc
= scm_m_expand_body (proc
, args
);
3686 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3689 SCM_CEVAL (SCM_CAR (proc
), args
);
3692 RETURN (EVALCAR (proc
, args
));
3694 if (!SCM_SMOB_APPLICABLE_P (proc
))
3696 if (SCM_UNBNDP (arg1
))
3697 RETURN (SCM_SMOB_APPLY_0 (proc
));
3698 else if (SCM_NULLP (args
))
3699 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3700 else if (SCM_NULLP (SCM_CDR (args
)))
3701 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3703 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3706 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3708 proc
= SCM_CCLO_SUBR (proc
);
3709 debug
.vect
[0].a
.proc
= proc
;
3710 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3712 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3714 proc
= SCM_CCLO_SUBR (proc
);
3718 proc
= SCM_PROCEDURE (proc
);
3720 debug
.vect
[0].a
.proc
= proc
;
3723 case scm_tcs_struct
:
3724 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3727 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3729 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3731 RETURN (scm_apply_generic (proc
, args
));
3733 else if (!SCM_I_OPERATORP (proc
))
3738 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3740 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3743 proc
= (SCM_I_ENTITYP (proc
)
3744 ? SCM_ENTITY_PROCEDURE (proc
)
3745 : SCM_OPERATOR_PROCEDURE (proc
));
3747 debug
.vect
[0].a
.proc
= proc
;
3748 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3750 if (SCM_NIMP (proc
))
3757 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3761 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3762 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3764 SCM_CLEAR_TRACED_FRAME (debug
);
3765 if (SCM_CHEAPTRAPS_P
)
3766 arg1
= scm_make_debugobj (&debug
);
3770 SCM val
= scm_make_continuation (&first
);
3781 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3785 scm_last_debug_frame
= debug
.prev
;
3791 /* SECTION: The rest of this file is only read once.
3796 /* Typechecking for multi-argument MAP and FOR-EACH.
3798 Verify that each element of the vector ARGV, except for the first,
3799 is a proper list whose length is LEN. Attribute errors to WHO,
3800 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3802 check_map_args (SCM argv
,
3809 SCM
*ve
= SCM_VELTS (argv
);
3812 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3814 long elt_len
= scm_ilength (ve
[i
]);
3819 scm_apply_generic (gf
, scm_cons (proc
, args
));
3821 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3825 scm_out_of_range (who
, ve
[i
]);
3828 scm_remember_upto_here_1 (argv
);
3832 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3834 /* Note: Currently, scm_map applies PROC to the argument list(s)
3835 sequentially, starting with the first element(s). This is used in
3836 evalext.c where the Scheme procedure `map-in-order', which guarantees
3837 sequential behaviour, is implemented using scm_map. If the
3838 behaviour changes, we need to update `map-in-order'.
3842 scm_map (SCM proc
, SCM arg1
, SCM args
)
3843 #define FUNC_NAME s_map
3848 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3850 len
= scm_ilength (arg1
);
3851 SCM_GASSERTn (len
>= 0,
3852 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3853 SCM_VALIDATE_REST_ARGUMENT (args
);
3854 if (SCM_NULLP (args
))
3856 while (SCM_NIMP (arg1
))
3858 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3859 pres
= SCM_CDRLOC (*pres
);
3860 arg1
= SCM_CDR (arg1
);
3864 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3865 ve
= SCM_VELTS (args
);
3866 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3870 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3872 if (SCM_IMP (ve
[i
]))
3874 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3875 ve
[i
] = SCM_CDR (ve
[i
]);
3877 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3878 pres
= SCM_CDRLOC (*pres
);
3884 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3887 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3888 #define FUNC_NAME s_for_each
3890 SCM
*ve
= &args
; /* Keep args from being optimized away. */
3892 len
= scm_ilength (arg1
);
3893 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3894 SCM_ARG2
, s_for_each
);
3895 SCM_VALIDATE_REST_ARGUMENT (args
);
3896 if (SCM_NULLP (args
))
3898 while (SCM_NIMP (arg1
))
3900 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3901 arg1
= SCM_CDR (arg1
);
3903 return SCM_UNSPECIFIED
;
3905 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3906 ve
= SCM_VELTS (args
);
3907 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3911 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3913 if (SCM_IMP (ve
[i
]))
3914 return SCM_UNSPECIFIED
;
3915 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3916 ve
[i
] = SCM_CDR (ve
[i
]);
3918 scm_apply (proc
, arg1
, SCM_EOL
);
3925 scm_closure (SCM code
, SCM env
)
3928 SCM closcar
= scm_cons (code
, SCM_EOL
);
3929 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3930 scm_remember_upto_here (closcar
);
3935 scm_t_bits scm_tc16_promise
;
3938 scm_makprom (SCM code
)
3940 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3946 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3948 int writingp
= SCM_WRITINGP (pstate
);
3949 scm_puts ("#<promise ", port
);
3950 SCM_SET_WRITINGP (pstate
, 1);
3951 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3952 SCM_SET_WRITINGP (pstate
, writingp
);
3953 scm_putc ('>', port
);
3958 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3960 "If the promise @var{x} has not been computed yet, compute and\n"
3961 "return @var{x}, otherwise just return the previously computed\n"
3963 #define FUNC_NAME s_scm_force
3965 SCM_VALIDATE_SMOB (1, x
, promise
);
3966 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3968 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3969 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3972 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3973 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3977 return SCM_CELL_OBJECT_1 (x
);
3982 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3984 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3985 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3986 #define FUNC_NAME s_scm_promise_p
3988 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3993 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3994 (SCM xorig
, SCM x
, SCM y
),
3995 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3996 "Any source properties associated with @var{xorig} are also associated\n"
3997 "with the new pair.")
3998 #define FUNC_NAME s_scm_cons_source
4001 z
= scm_cons (x
, y
);
4002 /* Copy source properties possibly associated with xorig. */
4003 p
= scm_whash_lookup (scm_source_whash
, xorig
);
4005 scm_whash_insert (scm_source_whash
, z
, p
);
4011 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
4013 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
4014 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
4015 "contents of both pairs and vectors (since both cons cells and vector\n"
4016 "cells may point to arbitrary objects), and stops recursing when it hits\n"
4017 "any other object.")
4018 #define FUNC_NAME s_scm_copy_tree
4023 if (SCM_VECTORP (obj
))
4025 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
4026 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
4028 SCM_VELTS (ans
)[i
] = scm_copy_tree (SCM_VELTS (obj
)[i
]);
4031 if (!SCM_CONSP (obj
))
4033 ans
= tl
= scm_cons_source (obj
,
4034 scm_copy_tree (SCM_CAR (obj
)),
4036 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
4038 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
4042 SCM_SETCDR (tl
, obj
);
4048 /* We have three levels of EVAL here:
4050 - scm_i_eval (exp, env)
4052 evaluates EXP in environment ENV. ENV is a lexical environment
4053 structure as used by the actual tree code evaluator. When ENV is
4054 a top-level environment, then changes to the current module are
4055 tracked by updating ENV so that it continues to be in sync with
4058 - scm_primitive_eval (exp)
4060 evaluates EXP in the top-level environment as determined by the
4061 current module. This is done by constructing a suitable
4062 environment and calling scm_i_eval. Thus, changes to the
4063 top-level module are tracked normally.
4065 - scm_eval (exp, mod)
4067 evaluates EXP while MOD is the current module. This is done by
4068 setting the current module to MOD, invoking scm_primitive_eval on
4069 EXP, and then restoring the current module to the value it had
4070 previously. That is, while EXP is evaluated, changes to the
4071 current module are tracked, but these changes do not persist when
4074 For each level of evals, there are two variants, distinguished by a
4075 _x suffix: the ordinary variant does not modify EXP while the _x
4076 variant can destructively modify EXP into something completely
4077 unintelligible. A Scheme data structure passed as EXP to one of the
4078 _x variants should not ever be used again for anything. So when in
4079 doubt, use the ordinary variant.
4084 scm_i_eval_x (SCM exp
, SCM env
)
4086 return SCM_XEVAL (exp
, env
);
4090 scm_i_eval (SCM exp
, SCM env
)
4092 exp
= scm_copy_tree (exp
);
4093 return SCM_XEVAL (exp
, env
);
4097 scm_primitive_eval_x (SCM exp
)
4100 SCM transformer
= scm_current_module_transformer ();
4101 if (SCM_NIMP (transformer
))
4102 exp
= scm_call_1 (transformer
, exp
);
4103 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4104 return scm_i_eval_x (exp
, env
);
4107 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4109 "Evaluate @var{exp} in the top-level environment specified by\n"
4110 "the current module.")
4111 #define FUNC_NAME s_scm_primitive_eval
4114 SCM transformer
= scm_current_module_transformer ();
4115 if (SCM_NIMP (transformer
))
4116 exp
= scm_call_1 (transformer
, exp
);
4117 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4118 return scm_i_eval (exp
, env
);
4122 /* Eval does not take the second arg optionally. This is intentional
4123 * in order to be R5RS compatible, and to prepare for the new module
4124 * system, where we would like to make the choice of evaluation
4125 * environment explicit. */
4128 change_environment (void *data
)
4130 SCM pair
= SCM_PACK (data
);
4131 SCM new_module
= SCM_CAR (pair
);
4132 SCM old_module
= scm_current_module ();
4133 SCM_SETCDR (pair
, old_module
);
4134 scm_set_current_module (new_module
);
4139 restore_environment (void *data
)
4141 SCM pair
= SCM_PACK (data
);
4142 SCM old_module
= SCM_CDR (pair
);
4143 SCM new_module
= scm_current_module ();
4144 SCM_SETCAR (pair
, new_module
);
4145 scm_set_current_module (old_module
);
4149 inner_eval_x (void *data
)
4151 return scm_primitive_eval_x (SCM_PACK(data
));
4155 scm_eval_x (SCM exp
, SCM module
)
4156 #define FUNC_NAME "eval!"
4158 SCM_VALIDATE_MODULE (2, module
);
4160 return scm_internal_dynamic_wind
4161 (change_environment
, inner_eval_x
, restore_environment
,
4162 (void *) SCM_UNPACK (exp
),
4163 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4168 inner_eval (void *data
)
4170 return scm_primitive_eval (SCM_PACK(data
));
4173 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4174 (SCM exp
, SCM module
),
4175 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4176 "in the top-level environment specified by @var{module}.\n"
4177 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4178 "@var{module} is made the current module. The current module\n"
4179 "is reset to its previous value when @var{eval} returns.")
4180 #define FUNC_NAME s_scm_eval
4182 SCM_VALIDATE_MODULE (2, module
);
4184 return scm_internal_dynamic_wind
4185 (change_environment
, inner_eval
, restore_environment
,
4186 (void *) SCM_UNPACK (exp
),
4187 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4192 /* At this point, scm_deval and scm_dapply are generated.
4195 #ifdef DEBUG_EXTENSIONS
4205 scm_init_opts (scm_evaluator_traps
,
4206 scm_evaluator_trap_table
,
4207 SCM_N_EVALUATOR_TRAPS
);
4208 scm_init_opts (scm_eval_options_interface
,
4210 SCM_N_EVAL_OPTIONS
);
4212 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4213 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4214 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4216 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4217 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4218 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4219 scm_listofnull
= scm_list_1 (SCM_EOL
);
4221 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4226 #include "libguile/eval.x"
4228 scm_add_feature ("delay");