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
));
170 /* The Lookup Car Race
173 Memoization of variables and special forms is done while executing
174 the code for the first time. As long as there is only one thread
175 everything is fine, but as soon as two threads execute the same
176 code concurrently `for the first time' they can come into conflict.
178 This memoization includes rewriting variable references into more
179 efficient forms and expanding macros. Furthermore, macro expansion
180 includes `compiling' special forms like `let', `cond', etc. into
181 tree-code instructions.
183 There shouldn't normally be a problem with memoizing local and
184 global variable references (into ilocs and variables), because all
185 threads will mutate the code in *exactly* the same way and (if I
186 read the C code correctly) it is not possible to observe a half-way
187 mutated cons cell. The lookup procedure can handle this
188 transparently without any critical sections.
190 It is different with macro expansion, because macro expansion
191 happens outside of the lookup procedure and can't be
192 undone. Therefore the lookup procedure can't cope with it. It has
193 to indicate failure when it detects a lost race and hope that the
194 caller can handle it. Luckily, it turns out that this is the case.
196 An example to illustrate this: Suppose that the following form will
197 be memoized concurrently by two threads
201 Let's first examine the lookup of X in the body. The first thread
202 decides that it has to find the symbol "x" in the environment and
203 starts to scan it. Then the other thread takes over and actually
204 overtakes the first. It looks up "x" and substitutes an
205 appropriate iloc for it. Now the first thread continues and
206 completes its lookup. It comes to exactly the same conclusions as
207 the second one and could - without much ado - just overwrite the
208 iloc with the same iloc.
210 But let's see what will happen when the race occurs while looking
211 up the symbol "let" at the start of the form. It could happen that
212 the second thread interrupts the lookup of the first thread and not
213 only substitutes a variable for it but goes right ahead and
214 replaces it with the compiled form (#@let* (x 12) x). Now, when
215 the first thread completes its lookup, it would replace the #@let*
216 with a variable containing the "let" binding, effectively reverting
217 the form to (let (x 12) x). This is wrong. It has to detect that
218 it has lost the race and the evaluator has to reconsider the
219 changed form completely.
221 This race condition could be resolved with some kind of traffic
222 light (like mutexes) around scm_lookupcar, but I think that it is
223 best to avoid them in this case. They would serialize memoization
224 completely and because lookup involves calling arbitrary Scheme
225 code (via the lookup-thunk), threads could be blocked for an
226 arbitrary amount of time or even deadlock. But with the current
227 solution a lot of unnecessary work is potentially done. */
229 /* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to
230 return NULL to indicate a failed lookup due to some race conditions
231 between threads. This only happens when VLOC is the first cell of
232 a special form that will eventually be memoized (like `let', etc.)
233 In that case the whole lookup is bogus and the caller has to
234 reconsider the complete special form.
236 SCM_LOOKUPCAR is still there, of course. It just calls
237 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
238 should only be called when it is known that VLOC is not the first
239 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
240 for NULL. I think I've found the only places where this
243 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
246 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
249 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
250 register SCM iloc
= SCM_ILOC00
;
251 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
253 if (!SCM_CONSP (SCM_CAR (env
)))
255 al
= SCM_CARLOC (env
);
256 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
260 if (SCM_EQ_P (fl
, var
))
262 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
264 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
265 return SCM_CDRLOC (*al
);
270 al
= SCM_CDRLOC (*al
);
271 if (SCM_EQ_P (SCM_CAR (fl
), var
))
273 if (SCM_UNBNDP (SCM_CAR (*al
)))
278 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
280 SCM_SETCAR (vloc
, iloc
);
281 return SCM_CARLOC (*al
);
283 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
285 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
288 SCM top_thunk
, real_var
;
291 top_thunk
= SCM_CAR (env
); /* env now refers to a
292 top level env thunk */
296 top_thunk
= SCM_BOOL_F
;
297 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
298 if (SCM_FALSEP (real_var
))
301 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
307 scm_error (scm_unbound_variable_key
, NULL
,
308 "Unbound variable: ~S",
309 scm_list_1 (var
), SCM_BOOL_F
);
311 scm_misc_error (NULL
, "Damaged environment: ~S",
316 /* A variable could not be found, but we shall
317 not throw an error. */
318 static SCM undef_object
= SCM_UNDEFINED
;
319 return &undef_object
;
323 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
325 /* Some other thread has changed the very cell we are working
326 on. In effect, it must have done our job or messed it up
329 var
= SCM_CAR (vloc
);
330 if (SCM_VARIABLEP (var
))
331 return SCM_VARIABLE_LOC (var
);
332 if (SCM_ITAG7 (var
) == SCM_ITAG7 (SCM_ILOC00
))
333 return scm_ilookup (var
, genv
);
334 /* We can't cope with anything else than variables and ilocs. When
335 a special form has been memoized (i.e. `let' into `#@let') we
336 return NULL and expect the calling function to do the right
337 thing. For the evaluator, this means going back and redoing
338 the dispatch on the car of the form. */
342 SCM_SETCAR (vloc
, real_var
);
343 return SCM_VARIABLE_LOC (real_var
);
348 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
350 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
356 #define unmemocar scm_unmemocar
358 SCM_SYMBOL (sym_three_question_marks
, "???");
361 scm_unmemocar (SCM form
, SCM env
)
363 if (!SCM_CONSP (form
))
367 SCM c
= SCM_CAR (form
);
368 if (SCM_VARIABLEP (c
))
370 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
371 if (SCM_FALSEP (sym
))
372 sym
= sym_three_question_marks
;
373 SCM_SETCAR (form
, sym
);
375 else if (SCM_ILOCP (c
))
377 unsigned long int ir
;
379 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
381 env
= SCM_CAAR (env
);
382 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
384 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
392 scm_eval_car (SCM pair
, SCM env
)
394 return SCM_XEVALCAR (pair
, env
);
399 * The following rewrite expressions and
400 * some memoized forms have different syntax
403 const char scm_s_expression
[] = "missing or extra expression";
404 const char scm_s_test
[] = "bad test";
405 const char scm_s_body
[] = "bad body";
406 const char scm_s_bindings
[] = "bad bindings";
407 const char scm_s_duplicate_bindings
[] = "duplicate bindings";
408 const char scm_s_variable
[] = "bad variable";
409 const char scm_s_clauses
[] = "bad or missing clauses";
410 const char scm_s_formals
[] = "bad formals";
411 const char scm_s_duplicate_formals
[] = "duplicate formals";
412 static const char s_splicing
[] = "bad (non-list) result for unquote-splicing";
414 SCM_GLOBAL_SYMBOL (scm_sym_dot
, ".");
415 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
416 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
417 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
418 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
422 #ifdef DEBUG_EXTENSIONS
423 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
424 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
425 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
426 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
430 /* Check that the body denoted by XORIG is valid and rewrite it into
431 its internal form. The internal form of a body is just the body
432 itself, but prefixed with an ISYM that denotes to what kind of
433 outer construct this body belongs. A lambda body starts with
434 SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
435 etc. The one exception is a body that belongs to a letrec that has
436 been formed by rewriting internal defines: it starts with
439 /* XXX - Besides controlling the rewriting of internal defines, the
440 additional ISYM could be used for improved error messages.
441 This is not done yet. */
444 scm_m_body (SCM op
, SCM xorig
, const char *what
)
446 SCM_ASSYNT (scm_ilength (xorig
) >= 1, scm_s_body
, what
);
448 /* Don't add another ISYM if one is present already. */
449 if (SCM_ISYMP (SCM_CAR (xorig
)))
452 /* Retain possible doc string. */
453 if (!SCM_CONSP (SCM_CAR (xorig
)))
455 if (!SCM_NULLP (SCM_CDR (xorig
)))
456 return scm_cons (SCM_CAR (xorig
),
457 scm_m_body (op
, SCM_CDR (xorig
), what
));
461 return scm_cons (op
, xorig
);
465 SCM_SYNTAX (s_quote
, "quote", scm_makmmacro
, scm_m_quote
);
466 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
469 scm_m_quote (SCM xorig
, SCM env SCM_UNUSED
)
471 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1, scm_s_expression
, s_quote
);
472 return scm_cons (SCM_IM_QUOTE
, SCM_CDR (xorig
));
476 SCM_SYNTAX (s_begin
, "begin", scm_makmmacro
, scm_m_begin
);
477 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
480 scm_m_begin (SCM xorig
, SCM env SCM_UNUSED
)
482 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) >= 0, scm_s_expression
, s_begin
);
483 return scm_cons (SCM_IM_BEGIN
, SCM_CDR (xorig
));
487 SCM_SYNTAX (s_if
, "if", scm_makmmacro
, scm_m_if
);
488 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
491 scm_m_if (SCM xorig
, SCM env SCM_UNUSED
)
493 long len
= scm_ilength (SCM_CDR (xorig
));
494 SCM_ASSYNT (len
>= 2 && len
<= 3, scm_s_expression
, s_if
);
495 return scm_cons (SCM_IM_IF
, SCM_CDR (xorig
));
499 /* Will go into the RnRS module when Guile is factorized.
500 SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */
501 const char scm_s_set_x
[] = "set!";
502 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, scm_s_set_x
);
505 scm_m_set_x (SCM xorig
, SCM env SCM_UNUSED
)
507 SCM x
= SCM_CDR (xorig
);
508 SCM_ASSYNT (scm_ilength (x
) == 2, scm_s_expression
, scm_s_set_x
);
509 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x
)), scm_s_variable
, scm_s_set_x
);
510 return scm_cons (SCM_IM_SET_X
, x
);
514 SCM_SYNTAX (s_and
, "and", scm_makmmacro
, scm_m_and
);
515 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
518 scm_m_and (SCM xorig
, SCM env SCM_UNUSED
)
520 long len
= scm_ilength (SCM_CDR (xorig
));
521 SCM_ASSYNT (len
>= 0, scm_s_test
, s_and
);
523 return scm_cons (SCM_IM_AND
, SCM_CDR (xorig
));
529 SCM_SYNTAX (s_or
, "or", scm_makmmacro
, scm_m_or
);
530 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
533 scm_m_or (SCM xorig
, SCM env SCM_UNUSED
)
535 long len
= scm_ilength (SCM_CDR (xorig
));
536 SCM_ASSYNT (len
>= 0, scm_s_test
, s_or
);
538 return scm_cons (SCM_IM_OR
, SCM_CDR (xorig
));
544 SCM_SYNTAX (s_case
, "case", scm_makmmacro
, scm_m_case
);
545 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
548 scm_m_case (SCM xorig
, SCM env SCM_UNUSED
)
551 SCM cdrx
= SCM_CDR (xorig
);
552 SCM_ASSYNT (scm_ilength (cdrx
) >= 2, scm_s_clauses
, s_case
);
553 clauses
= SCM_CDR (cdrx
);
554 while (!SCM_NULLP (clauses
))
556 SCM clause
= SCM_CAR (clauses
);
557 SCM_ASSYNT (scm_ilength (clause
) >= 2, scm_s_clauses
, s_case
);
558 SCM_ASSYNT (scm_ilength (SCM_CAR (clause
)) >= 0
559 || (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
))
560 && SCM_NULLP (SCM_CDR (clauses
))),
561 scm_s_clauses
, s_case
);
562 clauses
= SCM_CDR (clauses
);
564 return scm_cons (SCM_IM_CASE
, cdrx
);
568 SCM_SYNTAX (s_cond
, "cond", scm_makmmacro
, scm_m_cond
);
569 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
572 scm_m_cond (SCM xorig
, SCM env SCM_UNUSED
)
574 SCM cdrx
= SCM_CDR (xorig
);
576 SCM_ASSYNT (scm_ilength (clauses
) >= 1, scm_s_clauses
, s_cond
);
577 while (!SCM_NULLP (clauses
))
579 SCM clause
= SCM_CAR (clauses
);
580 long len
= scm_ilength (clause
);
581 SCM_ASSYNT (len
>= 1, scm_s_clauses
, s_cond
);
582 if (SCM_EQ_P (scm_sym_else
, SCM_CAR (clause
)))
584 int last_clause_p
= SCM_NULLP (SCM_CDR (clauses
));
585 SCM_ASSYNT (len
>= 2 && last_clause_p
, "bad ELSE clause", s_cond
);
587 else if (len
>= 2 && SCM_EQ_P (scm_sym_arrow
, SCM_CADR (clause
)))
589 SCM_ASSYNT (len
> 2, "missing recipient", s_cond
);
590 SCM_ASSYNT (len
== 3, "bad recipient", s_cond
);
592 clauses
= SCM_CDR (clauses
);
594 return scm_cons (SCM_IM_COND
, cdrx
);
598 SCM_SYNTAX (s_lambda
, "lambda", scm_makmmacro
, scm_m_lambda
);
599 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
601 /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
602 * cdr of the last cons. (Thus, LIST is not required to be a proper
603 * list and OBJ can also be found in the improper ending.) */
605 scm_c_improper_memq (SCM obj
, SCM list
)
607 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
609 if (SCM_EQ_P (SCM_CAR (list
), obj
))
612 return SCM_EQ_P (list
, obj
);
616 scm_m_lambda (SCM xorig
, SCM env SCM_UNUSED
)
619 SCM x
= SCM_CDR (xorig
);
621 SCM_ASSYNT (SCM_CONSP (x
), scm_s_formals
, s_lambda
);
623 formals
= SCM_CAR (x
);
624 while (SCM_CONSP (formals
))
626 SCM formal
= SCM_CAR (formals
);
627 SCM_ASSYNT (SCM_SYMBOLP (formal
), scm_s_formals
, s_lambda
);
628 if (scm_c_improper_memq (formal
, SCM_CDR (formals
)))
629 scm_misc_error (s_lambda
, scm_s_duplicate_formals
, SCM_EOL
);
630 formals
= SCM_CDR (formals
);
632 if (!SCM_NULLP (formals
) && !SCM_SYMBOLP (formals
))
633 scm_misc_error (s_lambda
, scm_s_formals
, SCM_EOL
);
635 return scm_cons2 (SCM_IM_LAMBDA
, SCM_CAR (x
),
636 scm_m_body (SCM_IM_LAMBDA
, SCM_CDR (x
), s_lambda
));
640 SCM_SYNTAX (s_letstar
, "let*", scm_makmmacro
, scm_m_letstar
);
641 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
643 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
644 * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */
646 scm_m_letstar (SCM xorig
, SCM env SCM_UNUSED
)
649 SCM x
= SCM_CDR (xorig
);
653 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letstar
);
655 bindings
= SCM_CAR (x
);
656 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_letstar
);
657 while (!SCM_NULLP (bindings
))
659 SCM binding
= SCM_CAR (bindings
);
660 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_letstar
);
661 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_letstar
);
662 *varloc
= scm_list_2 (SCM_CAR (binding
), SCM_CADR (binding
));
663 varloc
= SCM_CDRLOC (SCM_CDR (*varloc
));
664 bindings
= SCM_CDR (bindings
);
667 return scm_cons2 (SCM_IM_LETSTAR
, vars
,
668 scm_m_body (SCM_IM_LETSTAR
, SCM_CDR (x
), s_letstar
));
672 /* DO gets the most radically altered syntax. The order of the vars is
673 * reversed here. In contrast, the order of the inits and steps is reversed
674 * during the evaluation:
676 (do ((<var1> <init1> <step1>)
684 (#@do (varn ... var2 var1)
685 (<init1> <init2> ... <initn>)
688 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
691 SCM_SYNTAX(s_do
, "do", scm_makmmacro
, scm_m_do
);
692 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
695 scm_m_do (SCM xorig
, SCM env SCM_UNUSED
)
698 SCM x
= SCM_CDR (xorig
);
701 SCM
*initloc
= &inits
;
703 SCM
*steploc
= &steps
;
704 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_test
, "do");
705 bindings
= SCM_CAR (x
);
706 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, "do");
707 while (!SCM_NULLP (bindings
))
709 SCM binding
= SCM_CAR (bindings
);
710 long len
= scm_ilength (binding
);
711 SCM_ASSYNT (len
== 2 || len
== 3, scm_s_bindings
, "do");
713 SCM name
= SCM_CAR (binding
);
714 SCM init
= SCM_CADR (binding
);
715 SCM step
= (len
== 2) ? name
: SCM_CADDR (binding
);
716 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, "do");
717 vars
= scm_cons (name
, vars
);
718 *initloc
= scm_list_1 (init
);
719 initloc
= SCM_CDRLOC (*initloc
);
720 *steploc
= scm_list_1 (step
);
721 steploc
= SCM_CDRLOC (*steploc
);
722 bindings
= SCM_CDR (bindings
);
726 SCM_ASSYNT (scm_ilength (SCM_CAR (x
)) >= 1, scm_s_test
, "do");
727 x
= scm_cons2 (SCM_CAR (x
), SCM_CDR (x
), steps
);
728 x
= scm_cons2 (vars
, inits
, x
);
729 return scm_cons (SCM_IM_DO
, x
);
733 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
734 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
736 /* Internal function to handle a quasiquotation: 'form' is the parameter in
737 * the call (quasiquotation form), 'env' is the environment where unquoted
738 * expressions will be evaluated, and 'depth' is the current quasiquotation
739 * nesting level and is known to be greater than zero. */
741 iqq (SCM form
, SCM env
, unsigned long int depth
)
743 if (SCM_CONSP (form
))
745 SCM tmp
= SCM_CAR (form
);
746 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
748 SCM args
= SCM_CDR (form
);
749 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
750 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
752 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
754 SCM args
= SCM_CDR (form
);
755 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
757 return scm_eval_car (args
, env
);
759 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
761 else if (SCM_CONSP (tmp
)
762 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
764 SCM args
= SCM_CDR (tmp
);
765 SCM_ASSYNT (scm_ilength (args
) == 1, scm_s_expression
, s_quasiquote
);
768 SCM list
= scm_eval_car (args
, env
);
769 SCM rest
= SCM_CDR (form
);
770 SCM_ASSYNT (scm_ilength (list
) >= 0, s_splicing
, s_quasiquote
);
771 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
774 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
775 iqq (SCM_CDR (form
), env
, depth
));
778 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
779 iqq (SCM_CDR (form
), env
, depth
));
781 else if (SCM_VECTORP (form
))
783 size_t i
= SCM_VECTOR_LENGTH (form
);
784 SCM
const *data
= SCM_VELTS (form
);
787 tmp
= scm_cons (data
[--i
], tmp
);
788 scm_remember_upto_here_1 (form
);
789 return scm_vector (iqq (tmp
, env
, depth
));
796 scm_m_quasiquote (SCM xorig
, SCM env
)
798 SCM x
= SCM_CDR (xorig
);
799 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_quasiquote
);
800 return iqq (SCM_CAR (x
), env
, 1);
804 SCM_SYNTAX (s_delay
, "delay", scm_makmmacro
, scm_m_delay
);
805 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
807 /* Promises are implemented as closures with an empty parameter list. Thus,
808 * (delay <expression>) is transformed into (#@delay '() <expression>), where
809 * the empty list represents the empty parameter list. This representation
810 * allows for easy creation of the closure during evaluation. */
812 scm_m_delay (SCM xorig
, SCM env SCM_UNUSED
)
814 SCM_ASSYNT (scm_ilength (xorig
) == 2, scm_s_expression
, s_delay
);
815 return scm_cons2 (SCM_IM_DELAY
, SCM_EOL
, SCM_CDR (xorig
));
819 SCM_SYNTAX(s_define
, "define", scm_makmmacro
, scm_m_define
);
820 SCM_GLOBAL_SYMBOL(scm_sym_define
, s_define
);
822 /* Guile provides an extension to R5RS' define syntax to represent function
823 * currying in a compact way. With this extension, it is allowed to write
824 * (define <nested-variable> <body>), where <nested-variable> has of one of
825 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
826 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
827 * should be either a sequence of zero or more variables, or a sequence of one
828 * or more variables followed by a space-delimited period and another
829 * variable. Each level of argument nesting wraps the <body> within another
830 * lambda expression. For example, the following forms are allowed, each one
831 * followed by an equivalent, more explicit implementation.
833 * (define ((a b . c) . d) <body>) is equivalent to
834 * (define a (lambda (b . c) (lambda d <body>)))
836 * (define (((a) b) c . d) <body>) is equivalent to
837 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
839 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
840 * module that does not implement this extension. */
842 scm_m_define (SCM x
, SCM env
)
846 SCM_ASSYNT (scm_ilength (x
) >= 2, scm_s_expression
, s_define
);
849 while (SCM_CONSP (name
))
851 /* This while loop realizes function currying by variable nesting. */
852 SCM formals
= SCM_CDR (name
);
853 x
= scm_list_1 (scm_cons2 (scm_sym_lambda
, formals
, x
));
854 name
= SCM_CAR (name
);
856 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_variable
, s_define
);
857 SCM_ASSYNT (scm_ilength (x
) == 1, scm_s_expression
, s_define
);
858 if (SCM_TOP_LEVEL (env
))
861 x
= scm_eval_car (x
, env
);
862 if (SCM_REC_PROCNAMES_P
)
865 while (SCM_MACROP (tmp
))
866 tmp
= SCM_MACRO_CODE (tmp
);
867 if (SCM_CLOSUREP (tmp
)
868 /* Only the first definition determines the name. */
869 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
870 scm_set_procedure_property_x (tmp
, scm_sym_name
, name
);
872 var
= scm_sym2var (name
, scm_env_top_level (env
), SCM_BOOL_T
);
873 SCM_VARIABLE_SET (var
, x
);
874 return SCM_UNSPECIFIED
;
877 return scm_cons2 (SCM_IM_DEFINE
, name
, x
);
881 /* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists
882 * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is
883 * reversed here, the list of inits gets reversed during evaluation. */
885 transform_bindings (SCM bindings
, SCM
*rvarloc
, SCM
*initloc
, const char *what
)
891 SCM_ASSYNT (scm_ilength (bindings
) >= 1, scm_s_bindings
, what
);
895 SCM binding
= SCM_CAR (bindings
);
896 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, what
);
897 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, what
);
898 if (scm_c_improper_memq (SCM_CAR (binding
), rvars
))
899 scm_misc_error (what
, scm_s_duplicate_bindings
, SCM_EOL
);
900 rvars
= scm_cons (SCM_CAR (binding
), rvars
);
901 *initloc
= scm_list_1 (SCM_CADR (binding
));
902 initloc
= SCM_CDRLOC (*initloc
);
903 bindings
= SCM_CDR (bindings
);
905 while (!SCM_NULLP (bindings
));
911 SCM_SYNTAX(s_letrec
, "letrec", scm_makmmacro
, scm_m_letrec
);
912 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
915 scm_m_letrec (SCM xorig
, SCM env
)
917 SCM x
= SCM_CDR (xorig
);
918 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_letrec
);
920 if (SCM_NULLP (SCM_CAR (x
)))
922 /* null binding, let* faster */
923 SCM body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), s_letrec
);
924 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), SCM_EOL
, body
), env
);
928 SCM rvars
, inits
, body
;
929 transform_bindings (SCM_CAR (x
), &rvars
, &inits
, "letrec");
930 body
= scm_m_body (SCM_IM_LETREC
, SCM_CDR (x
), "letrec");
931 return scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
936 SCM_SYNTAX(s_let
, "let", scm_makmmacro
, scm_m_let
);
937 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
940 scm_m_let (SCM xorig
, SCM env
)
942 SCM x
= SCM_CDR (xorig
);
945 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
948 || (scm_ilength (temp
) == 1 && SCM_CONSP (SCM_CAR (temp
))))
950 /* null or single binding, let* is faster */
952 SCM body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), s_let
);
953 return scm_m_letstar (scm_cons2 (SCM_CAR (xorig
), bindings
, body
), env
);
955 else if (SCM_CONSP (temp
))
959 SCM rvars
, inits
, body
;
960 transform_bindings (bindings
, &rvars
, &inits
, "let");
961 body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
962 return scm_cons2 (SCM_IM_LET
, rvars
, scm_cons (inits
, body
));
966 /* named let: Transform (let name ((var init) ...) body ...) into
967 * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */
973 SCM
*initloc
= &inits
;
976 SCM_ASSYNT (SCM_SYMBOLP (name
), scm_s_bindings
, s_let
);
978 SCM_ASSYNT (SCM_CONSP (x
), scm_s_bindings
, s_let
);
979 bindings
= SCM_CAR (x
);
980 SCM_ASSYNT (scm_ilength (bindings
) >= 0, scm_s_bindings
, s_let
);
981 while (!SCM_NULLP (bindings
))
982 { /* vars and inits both in order */
983 SCM binding
= SCM_CAR (bindings
);
984 SCM_ASSYNT (scm_ilength (binding
) == 2, scm_s_bindings
, s_let
);
985 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding
)), scm_s_variable
, s_let
);
986 *varloc
= scm_list_1 (SCM_CAR (binding
));
987 varloc
= SCM_CDRLOC (*varloc
);
988 *initloc
= scm_list_1 (SCM_CADR (binding
));
989 initloc
= SCM_CDRLOC (*initloc
);
990 bindings
= SCM_CDR (bindings
);
994 SCM lambda_body
= scm_m_body (SCM_IM_LET
, SCM_CDR (x
), "let");
995 SCM lambda_form
= scm_cons2 (scm_sym_lambda
, vars
, lambda_body
);
996 SCM rvar
= scm_list_1 (name
);
997 SCM init
= scm_list_1 (lambda_form
);
998 SCM body
= scm_m_body (SCM_IM_LET
, scm_list_1 (name
), "let");
999 SCM letrec
= scm_cons2 (SCM_IM_LETREC
, rvar
, scm_cons (init
, body
));
1000 return scm_cons (letrec
, inits
);
1006 SCM_SYNTAX (s_atapply
, "@apply", scm_makmmacro
, scm_m_apply
);
1007 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1008 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1011 scm_m_apply (SCM xorig
, SCM env SCM_UNUSED
)
1013 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2, scm_s_expression
, s_atapply
);
1014 return scm_cons (SCM_IM_APPLY
, SCM_CDR (xorig
));
1018 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_makmmacro
, scm_m_cont
);
1019 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1023 scm_m_cont (SCM xorig
, SCM env SCM_UNUSED
)
1025 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 1,
1026 scm_s_expression
, s_atcall_cc
);
1027 return scm_cons (SCM_IM_CONT
, SCM_CDR (xorig
));
1030 #ifdef SCM_ENABLE_ELISP
1032 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_makmmacro
, scm_m_nil_cond
);
1035 scm_m_nil_cond (SCM xorig
, SCM env SCM_UNUSED
)
1037 long len
= scm_ilength (SCM_CDR (xorig
));
1038 SCM_ASSYNT (len
>= 1 && (len
& 1) == 1, scm_s_expression
, "nil-cond");
1039 return scm_cons (SCM_IM_NIL_COND
, SCM_CDR (xorig
));
1042 SCM_SYNTAX (s_atfop
, "@fop", scm_makmmacro
, scm_m_atfop
);
1045 scm_m_atfop (SCM xorig
, SCM env SCM_UNUSED
)
1047 SCM x
= SCM_CDR (xorig
), var
;
1048 SCM_ASSYNT (scm_ilength (x
) >= 1, scm_s_expression
, "@fop");
1049 var
= scm_symbol_fref (SCM_CAR (x
));
1050 /* Passing the symbol name as the `subr' arg here isn't really
1051 right, but without it it can be very difficult to work out from
1052 the error message which function definition was missing. In any
1053 case, we shouldn't really use SCM_ASSYNT here at all, but instead
1054 something equivalent to (signal void-function (list SYM)) in
1056 SCM_ASSYNT (SCM_VARIABLEP (var
),
1057 "Symbol's function definition is void",
1058 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1059 /* Support `defalias'. */
1060 while (SCM_SYMBOLP (SCM_VARIABLE_REF (var
)))
1062 var
= scm_symbol_fref (SCM_VARIABLE_REF (var
));
1063 SCM_ASSYNT (SCM_VARIABLEP (var
),
1064 "Symbol's function definition is void",
1065 SCM_SYMBOL_CHARS (SCM_CAR (x
)));
1067 /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1068 former allows for automatically picking up redefinitions of the
1069 corresponding symbol. */
1070 SCM_SETCAR (x
, var
);
1071 /* If the variable contains a procedure, leave the
1072 `transformer-macro' in place so that the procedure's arguments
1073 get properly transformed, and change the initial @fop to
1075 if (!SCM_MACROP (SCM_VARIABLE_REF (var
)))
1077 SCM_SETCAR (xorig
, SCM_IM_APPLY
);
1080 /* Otherwise (the variable contains a macro), the arguments should
1081 not be transformed, so cut the `transformer-macro' out and return
1082 the resulting expression starting with the variable. */
1083 SCM_SETCDR (x
, SCM_CDADR (x
));
1087 #endif /* SCM_ENABLE_ELISP */
1089 /* (@bind ((var exp) ...) body ...)
1091 This will assign the values of the `exp's to the global variables
1092 named by `var's (symbols, not evaluated), creating them if they
1093 don't exist, executes body, and then restores the previous values of
1094 the `var's. Additionally, whenever control leaves body, the values
1095 of the `var's are saved and restored when control returns. It is an
1096 error when a symbol appears more than once among the `var's.
1097 All `exp's are evaluated before any `var' is set.
1099 Think of this as `let' for dynamic scope.
1101 It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1103 XXX - also implement `@bind*'.
1106 SCM_SYNTAX (s_atbind
, "@bind", scm_makmmacro
, scm_m_atbind
);
1109 scm_m_atbind (SCM xorig
, SCM env
)
1111 SCM x
= SCM_CDR (xorig
);
1112 SCM top_level
= scm_env_top_level (env
);
1113 SCM vars
= SCM_EOL
, var
;
1116 SCM_ASSYNT (scm_ilength (x
) > 1, scm_s_expression
, s_atbind
);
1119 while (SCM_NIMP (x
))
1122 SCM sym_exp
= SCM_CAR (x
);
1123 SCM_ASSYNT (scm_ilength (sym_exp
) == 2, scm_s_bindings
, s_atbind
);
1124 SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp
)), scm_s_bindings
, s_atbind
);
1126 for (rest
= x
; SCM_NIMP (rest
); rest
= SCM_CDR (rest
))
1127 if (SCM_EQ_P (SCM_CAR (sym_exp
), SCM_CAAR (rest
)))
1128 scm_misc_error (s_atbind
, scm_s_duplicate_bindings
, SCM_EOL
);
1129 /* The first call to scm_sym2var will look beyond the current
1130 module, while the second call wont. */
1131 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_F
);
1132 if (SCM_FALSEP (var
))
1133 var
= scm_sym2var (SCM_CAR (sym_exp
), top_level
, SCM_BOOL_T
);
1134 vars
= scm_cons (var
, vars
);
1135 exps
= scm_cons (SCM_CADR (sym_exp
), exps
);
1137 return scm_cons (SCM_IM_BIND
,
1138 scm_cons (scm_cons (scm_reverse_x (vars
, SCM_EOL
), exps
),
1142 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_makmmacro
, scm_m_at_call_with_values
);
1143 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1146 scm_m_at_call_with_values (SCM xorig
, SCM env SCM_UNUSED
)
1148 SCM_ASSYNT (scm_ilength (SCM_CDR (xorig
)) == 2,
1149 scm_s_expression
, s_at_call_with_values
);
1150 return scm_cons (SCM_IM_CALL_WITH_VALUES
, SCM_CDR (xorig
));
1154 scm_m_expand_body (SCM xorig
, SCM env
)
1156 SCM x
= SCM_CDR (xorig
), defs
= SCM_EOL
;
1157 char *what
= SCM_ISYMCHARS (SCM_CAR (xorig
)) + 2;
1159 while (SCM_NIMP (x
))
1161 SCM form
= SCM_CAR (x
);
1162 if (!SCM_CONSP (form
))
1164 if (!SCM_SYMBOLP (SCM_CAR (form
)))
1167 form
= scm_macroexp (scm_cons_source (form
,
1172 if (SCM_EQ_P (SCM_IM_DEFINE
, SCM_CAR (form
)))
1174 defs
= scm_cons (SCM_CDR (form
), defs
);
1177 else if (!SCM_IMP (defs
))
1181 else if (SCM_EQ_P (SCM_IM_BEGIN
, SCM_CAR (form
)))
1183 x
= scm_append (scm_list_2 (SCM_CDR (form
), SCM_CDR (x
)));
1187 x
= scm_cons (form
, SCM_CDR (x
));
1192 if (!SCM_NULLP (defs
))
1194 SCM rvars
, inits
, body
, letrec
;
1195 transform_bindings (defs
, &rvars
, &inits
, what
);
1196 body
= scm_m_body (SCM_IM_DEFINE
, x
, what
);
1197 letrec
= scm_cons2 (SCM_IM_LETREC
, rvars
, scm_cons (inits
, body
));
1198 SCM_SETCAR (xorig
, letrec
);
1199 SCM_SETCDR (xorig
, SCM_EOL
);
1203 SCM_ASSYNT (SCM_CONSP (x
), scm_s_body
, what
);
1204 SCM_SETCAR (xorig
, SCM_CAR (x
));
1205 SCM_SETCDR (xorig
, SCM_CDR (x
));
1212 scm_macroexp (SCM x
, SCM env
)
1214 SCM res
, proc
, orig_sym
;
1216 /* Don't bother to produce error messages here. We get them when we
1217 eventually execute the code for real. */
1220 orig_sym
= SCM_CAR (x
);
1221 if (!SCM_SYMBOLP (orig_sym
))
1225 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
1226 if (proc_ptr
== NULL
)
1228 /* We have lost the race. */
1234 /* Only handle memoizing macros. `Acros' and `macros' are really
1235 special forms and should not be evaluated here. */
1237 if (!SCM_MACROP (proc
) || SCM_MACRO_TYPE (proc
) != 2)
1240 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
1241 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
1243 if (scm_ilength (res
) <= 0)
1244 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
1247 SCM_SETCAR (x
, SCM_CAR (res
));
1248 SCM_SETCDR (x
, SCM_CDR (res
));
1254 /* scm_unmemocopy takes a memoized expression together with its
1255 * environment and rewrites it to its original form. Thus, it is the
1256 * inversion of the rewrite rules above. The procedure is not
1257 * optimized for speed. It's used in scm_iprin1 when printing the
1258 * code of a closure, in scm_procedure_source, in display_frame when
1259 * generating the source for a stackframe in a backtrace, and in
1260 * display_expression.
1262 * Unmemoizing is not a reliable process. You cannot in general
1263 * expect to get the original source back.
1265 * However, GOOPS currently relies on this for method compilation.
1266 * This ought to change.
1269 #define SCM_BIT8(x) (127 & SCM_UNPACK (x))
1272 build_binding_list (SCM names
, SCM inits
)
1274 SCM bindings
= SCM_EOL
;
1275 while (!SCM_NULLP (names
))
1277 SCM binding
= scm_list_2 (SCM_CAR (names
), SCM_CAR (inits
));
1278 bindings
= scm_cons (binding
, bindings
);
1279 names
= SCM_CDR (names
);
1280 inits
= SCM_CDR (inits
);
1286 unmemocopy (SCM x
, SCM env
)
1289 #ifdef DEBUG_EXTENSIONS
1294 #ifdef DEBUG_EXTENSIONS
1295 p
= scm_whash_lookup (scm_source_whash
, x
);
1297 switch (SCM_ITAG7 (SCM_CAR (x
)))
1299 case SCM_BIT8(SCM_IM_AND
):
1300 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
1302 case SCM_BIT8(SCM_IM_BEGIN
):
1303 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
1305 case SCM_BIT8(SCM_IM_CASE
):
1306 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
1308 case SCM_BIT8(SCM_IM_COND
):
1309 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
1311 case SCM_BIT8 (SCM_IM_DO
):
1313 /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk),
1314 * where nx is the name of a local variable, ix is an initializer for
1315 * the local variable, test is the test clause of the do loop, body is
1316 * the body of the do loop and sx are the step clauses for the local
1318 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
1321 names
= SCM_CAR (x
);
1323 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1324 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1326 test
= unmemocopy (SCM_CAR (x
), env
);
1328 memoized_body
= SCM_CAR (x
);
1330 steps
= scm_reverse (unmemocopy (x
, env
));
1332 /* build transformed binding list */
1334 while (!SCM_NULLP (names
))
1336 SCM name
= SCM_CAR (names
);
1337 SCM init
= SCM_CAR (inits
);
1338 SCM step
= SCM_CAR (steps
);
1339 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
1341 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
1343 names
= SCM_CDR (names
);
1344 inits
= SCM_CDR (inits
);
1345 steps
= SCM_CDR (steps
);
1347 z
= scm_cons (test
, SCM_UNSPECIFIED
);
1348 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
1350 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
1353 case SCM_BIT8(SCM_IM_IF
):
1354 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
1356 case SCM_BIT8 (SCM_IM_LET
):
1358 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
1359 * where nx is the name of a local variable, ix is an initializer for
1360 * the local variable and by are the body clauses. */
1361 SCM names
, inits
, bindings
;
1364 names
= SCM_CAR (x
);
1366 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1367 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1369 bindings
= build_binding_list (names
, inits
);
1370 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1371 ls
= scm_cons (scm_sym_let
, z
);
1374 case SCM_BIT8 (SCM_IM_LETREC
):
1376 /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),
1377 * where nx is the name of a local variable, ix is an initializer for
1378 * the local variable and by are the body clauses. */
1379 SCM names
, inits
, bindings
;
1382 names
= SCM_CAR (x
);
1383 env
= EXTEND_ENV (names
, SCM_EOL
, env
);
1385 inits
= scm_reverse (unmemocopy (SCM_CAR (x
), env
));
1387 bindings
= build_binding_list (names
, inits
);
1388 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
1389 ls
= scm_cons (scm_sym_letrec
, z
);
1392 case SCM_BIT8(SCM_IM_LETSTAR
):
1400 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
1403 y
= z
= scm_acons (SCM_CAR (b
),
1405 scm_cons (unmemocopy (SCM_CADR (b
), env
), SCM_EOL
), env
),
1407 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1411 SCM_SETCDR (y
, SCM_EOL
);
1412 ls
= scm_cons (scm_sym_let
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1417 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
1419 scm_list_1 (unmemocopy (SCM_CADR (b
), env
)), env
),
1422 env
= EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
1425 while (SCM_NIMP (b
));
1426 SCM_SETCDR (z
, SCM_EOL
);
1428 ls
= scm_cons (scm_sym_letstar
, z
= scm_cons (y
, SCM_UNSPECIFIED
));
1431 case SCM_BIT8(SCM_IM_OR
):
1432 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
1434 case SCM_BIT8(SCM_IM_LAMBDA
):
1436 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
1437 ls
= scm_cons (scm_sym_lambda
, z
);
1438 env
= EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
1440 case SCM_BIT8(SCM_IM_QUOTE
):
1441 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
1443 case SCM_BIT8(SCM_IM_SET_X
):
1444 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
1446 case SCM_BIT8(SCM_IM_DEFINE
):
1451 z
= scm_cons (n
, SCM_UNSPECIFIED
);
1452 ls
= scm_cons (scm_sym_define
, z
);
1453 if (!SCM_NULLP (env
))
1454 env
= scm_cons (scm_cons (scm_cons (n
, SCM_CAAR (env
)),
1459 case SCM_BIT8(SCM_MAKISYM (0)):
1463 switch (SCM_ISYMNUM (z
))
1465 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
1466 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
1468 case (SCM_ISYMNUM (SCM_IM_CONT
)):
1469 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
1471 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
1472 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
1475 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
1476 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
1479 /* appease the Sun compiler god: */ ;
1483 ls
= z
= unmemocar (scm_cons (unmemocopy (SCM_CAR (x
), env
),
1489 while (SCM_CONSP (x
))
1491 SCM form
= SCM_CAR (x
);
1492 if (!SCM_ISYMP (form
))
1494 SCM copy
= scm_cons (unmemocopy (form
, env
), SCM_UNSPECIFIED
);
1495 SCM_SETCDR (z
, unmemocar (copy
, env
));
1501 #ifdef DEBUG_EXTENSIONS
1502 if (!SCM_FALSEP (p
))
1503 scm_whash_insert (scm_source_whash
, ls
, p
);
1510 scm_unmemocopy (SCM x
, SCM env
)
1512 if (!SCM_NULLP (env
))
1513 /* Make a copy of the lowest frame to protect it from
1514 modifications by SCM_IM_DEFINE */
1515 return unmemocopy (x
, scm_cons (SCM_CAR (env
), SCM_CDR (env
)));
1517 return unmemocopy (x
, env
);
1522 scm_badargsp (SCM formals
, SCM args
)
1524 while (!SCM_NULLP (formals
))
1526 if (!SCM_CONSP (formals
))
1528 if (SCM_NULLP (args
))
1530 formals
= SCM_CDR (formals
);
1531 args
= SCM_CDR (args
);
1533 return !SCM_NULLP (args
) ? 1 : 0;
1538 scm_badformalsp (SCM closure
, int n
)
1540 SCM formals
= SCM_CLOSURE_FORMALS (closure
);
1541 while (!SCM_NULLP (formals
))
1543 if (!SCM_CONSP (formals
))
1548 formals
= SCM_CDR (formals
);
1555 scm_eval_args (SCM l
, SCM env
, SCM proc
)
1557 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
1558 while (SCM_CONSP (l
))
1560 res
= EVALCAR (l
, env
);
1562 *lloc
= scm_list_1 (res
);
1563 lloc
= SCM_CDRLOC (*lloc
);
1567 scm_wrong_num_args (proc
);
1572 scm_eval_body (SCM code
, SCM env
)
1576 next
= SCM_CDR (code
);
1577 while (!SCM_NULLP (next
))
1579 if (SCM_IMP (SCM_CAR (code
)))
1581 if (SCM_ISYMP (SCM_CAR (code
)))
1583 code
= scm_m_expand_body (code
, env
);
1588 SCM_XEVAL (SCM_CAR (code
), env
);
1590 next
= SCM_CDR (code
);
1592 return SCM_XEVALCAR (code
, env
);
1599 /* SECTION: This code is specific for the debugging support. One
1600 * branch is read when DEVAL isn't defined, the other when DEVAL is
1606 #define SCM_APPLY scm_apply
1607 #define PREP_APPLY(proc, args)
1609 #define RETURN(x) do { return x; } while (0)
1610 #ifdef STACK_CHECKING
1611 #ifndef NO_CEVAL_STACK_CHECKING
1612 #define EVAL_STACK_CHECKING
1619 #define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
1621 #define SCM_APPLY scm_dapply
1623 #define PREP_APPLY(p, l) \
1624 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
1626 #define ENTER_APPLY \
1628 SCM_SET_ARGSREADY (debug);\
1629 if (scm_check_apply_p && SCM_TRAPS_P)\
1630 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
1632 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
1633 SCM_SET_TRACED_FRAME (debug); \
1635 if (SCM_CHEAPTRAPS_P)\
1637 tmp = scm_make_debugobj (&debug);\
1638 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1643 tmp = scm_make_continuation (&first);\
1645 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
1651 #define RETURN(e) do { proc = (e); goto exit; } while (0)
1652 #ifdef STACK_CHECKING
1653 #ifndef EVAL_STACK_CHECKING
1654 #define EVAL_STACK_CHECKING
1658 /* scm_ceval_ptr points to the currently selected evaluator.
1659 * *fixme*: Although efficiency is important here, this state variable
1660 * should probably not be a global. It should be related to the
1665 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
);
1667 /* scm_last_debug_frame contains a pointer to the last debugging
1668 * information stack frame. It is accessed very often from the
1669 * debugging evaluator, so it should probably not be indirectly
1670 * addressed. Better to save and restore it from the current root at
1674 /* scm_debug_eframe_size is the number of slots available for pseudo
1675 * stack frames at each real stack frame.
1678 long scm_debug_eframe_size
;
1680 int scm_debug_mode
, scm_check_entry_p
, scm_check_apply_p
, scm_check_exit_p
;
1682 long scm_eval_stack
;
1684 scm_t_option scm_eval_opts
[] = {
1685 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
1688 scm_t_option scm_debug_opts
[] = {
1689 { SCM_OPTION_BOOLEAN
, "cheap", 1,
1690 "*Flyweight representation of the stack at traps." },
1691 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
1692 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
1693 { SCM_OPTION_BOOLEAN
, "procnames", 1,
1694 "Record procedure names at definition." },
1695 { SCM_OPTION_BOOLEAN
, "backwards", 0,
1696 "Display backtrace in anti-chronological order." },
1697 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
1698 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
1699 { SCM_OPTION_INTEGER
, "frames", 3,
1700 "Maximum number of tail-recursive frames in backtrace." },
1701 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
1702 "Maximal number of stored backtrace frames." },
1703 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
1704 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
1705 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
1706 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
1707 { 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."}
1710 scm_t_option scm_evaluator_trap_table
[] = {
1711 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
1712 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
1713 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
1714 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
1715 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
1716 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
1717 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
1720 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
1722 "Option interface for the evaluation options. Instead of using\n"
1723 "this procedure directly, use the procedures @code{eval-enable},\n"
1724 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
1725 #define FUNC_NAME s_scm_eval_options_interface
1729 ans
= scm_options (setting
,
1733 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
1739 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
1741 "Option interface for the evaluator trap options.")
1742 #define FUNC_NAME s_scm_evaluator_traps
1746 ans
= scm_options (setting
,
1747 scm_evaluator_trap_table
,
1748 SCM_N_EVALUATOR_TRAPS
,
1750 SCM_RESET_DEBUG_MODE
;
1757 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
1759 SCM
*results
= lloc
, res
;
1760 while (SCM_CONSP (l
))
1762 res
= EVALCAR (l
, env
);
1764 *lloc
= scm_list_1 (res
);
1765 lloc
= SCM_CDRLOC (*lloc
);
1769 scm_wrong_num_args (proc
);
1776 /* SECTION: This code is compiled twice.
1780 /* Update the toplevel environment frame ENV so that it refers to the
1781 * current module. */
1782 #define UPDATE_TOPLEVEL_ENV(env) \
1784 SCM p = scm_current_module_lookup_closure (); \
1785 if (p != SCM_CAR(env)) \
1786 env = scm_top_level_env (p); \
1790 /* This is the evaluator. Like any real monster, it has three heads:
1792 * scm_ceval is the non-debugging evaluator, scm_deval is the debugging
1793 * version. Both are implemented using a common code base, using the
1794 * following mechanism: SCM_CEVAL is a macro, which is either defined to
1795 * scm_ceval or scm_deval. Thus, there is no function SCM_CEVAL, but the code
1796 * for SCM_CEVAL actually compiles to either scm_ceval or scm_deval. When
1797 * SCM_CEVAL is defined to scm_ceval, it is known that the macro DEVAL is not
1798 * defined. When SCM_CEVAL is defined to scm_deval, then the macro DEVAL is
1799 * known to be defined. Thus, in SCM_CEVAL parts for the debugging evaluator
1800 * are enclosed within #ifdef DEVAL ... #endif.
1802 * All three (scm_ceval, scm_deval and their common implementation SCM_CEVAL)
1803 * take two input parameters, x and env: x is a single expression to be
1804 * evalutated. env is the environment in which bindings are searched.
1806 * x is known to be a cell (i. e. a pair or any other non-immediate). Since x
1807 * is a single expression, it is necessarily in a tail position. If x is just
1808 * a call to another function like in the expression (foo exp1 exp2 ...), the
1809 * realization of that call therefore _must_not_ increase stack usage (the
1810 * evaluation of exp1, exp2 etc., however, may do so). This is realized by
1811 * making extensive use of 'goto' statements within the evaluator: The gotos
1812 * replace recursive calls to SCM_CEVAL, thus re-using the same stack frame
1813 * that SCM_CEVAL was already using. If, however, x represents some form that
1814 * requires to evaluate a sequence of expressions like (begin exp1 exp2 ...),
1815 * then recursive calls to SCM_CEVAL are performed for all but the last
1816 * expression of that sequence. */
1820 scm_ceval (SCM x
, SCM env
)
1826 scm_deval (SCM x
, SCM env
)
1831 SCM_CEVAL (SCM x
, SCM env
)
1835 scm_t_debug_frame debug
;
1836 scm_t_debug_info
*debug_info_end
;
1837 debug
.prev
= scm_last_debug_frame
;
1840 * The debug.vect contains twice as much scm_t_debug_info frames as the
1841 * user has specified with (debug-set! frames <n>).
1843 * Even frames are eval frames, odd frames are apply frames.
1845 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
1846 * sizeof (scm_t_debug_info
));
1847 debug
.info
= debug
.vect
;
1848 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
1849 scm_last_debug_frame
= &debug
;
1851 #ifdef EVAL_STACK_CHECKING
1852 if (scm_stack_checking_enabled_p
1853 && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM
*) &proc
))
1856 debug
.info
->e
.exp
= x
;
1857 debug
.info
->e
.env
= env
;
1859 scm_report_stack_overflow ();
1869 SCM_CLEAR_ARGSREADY (debug
);
1870 if (SCM_OVERFLOWP (debug
))
1873 * In theory, this should be the only place where it is necessary to
1874 * check for space in debug.vect since both eval frames and
1875 * available space are even.
1877 * For this to be the case, however, it is necessary that primitive
1878 * special forms which jump back to `loop', `begin' or some similar
1879 * label call PREP_APPLY.
1881 else if (++debug
.info
>= debug_info_end
)
1883 SCM_SET_OVERFLOW (debug
);
1888 debug
.info
->e
.exp
= x
;
1889 debug
.info
->e
.env
= env
;
1890 if (scm_check_entry_p
&& SCM_TRAPS_P
)
1892 if (SCM_ENTER_FRAME_P
1893 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
1896 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
1897 SCM_SET_TAILREC (debug
);
1898 if (SCM_CHEAPTRAPS_P
)
1899 stackrep
= scm_make_debugobj (&debug
);
1903 SCM val
= scm_make_continuation (&first
);
1913 /* This gives the possibility for the debugger to
1914 modify the source expression before evaluation. */
1919 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
1920 scm_sym_enter_frame
,
1923 scm_unmemocopy (x
, env
));
1930 switch (SCM_TYP7 (x
))
1932 case scm_tc7_symbol
:
1933 /* Only happens when called at top level. */
1934 x
= scm_cons (x
, SCM_UNDEFINED
);
1935 RETURN (*scm_lookupcar (x
, env
, 1));
1937 case SCM_BIT8 (SCM_IM_AND
):
1939 while (!SCM_NULLP (SCM_CDR (x
)))
1941 SCM test_result
= EVALCAR (x
, env
);
1942 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
1943 RETURN (SCM_BOOL_F
);
1947 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1950 case SCM_BIT8 (SCM_IM_BEGIN
):
1953 RETURN (SCM_UNSPECIFIED
);
1955 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
1958 /* If we are on toplevel with a lookup closure, we need to sync
1959 with the current module. */
1960 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
1962 UPDATE_TOPLEVEL_ENV (env
);
1963 while (!SCM_NULLP (SCM_CDR (x
)))
1966 UPDATE_TOPLEVEL_ENV (env
);
1972 goto nontoplevel_begin
;
1975 while (!SCM_NULLP (SCM_CDR (x
)))
1977 SCM form
= SCM_CAR (x
);
1980 if (SCM_ISYMP (form
))
1982 x
= scm_m_expand_body (x
, env
);
1983 goto nontoplevel_begin
;
1986 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
1989 SCM_CEVAL (form
, env
);
1995 /* scm_eval last form in list */
1996 SCM last_form
= SCM_CAR (x
);
1998 if (SCM_CONSP (last_form
))
2000 /* This is by far the most frequent case. */
2002 goto loop
; /* tail recurse */
2004 else if (SCM_IMP (last_form
))
2005 RETURN (SCM_EVALIM (last_form
, env
));
2006 else if (SCM_VARIABLEP (last_form
))
2007 RETURN (SCM_VARIABLE_REF (last_form
));
2008 else if (SCM_SYMBOLP (last_form
))
2009 RETURN (*scm_lookupcar (x
, env
, 1));
2015 case SCM_BIT8 (SCM_IM_CASE
):
2018 SCM key
= EVALCAR (x
, env
);
2020 while (!SCM_NULLP (x
))
2022 SCM clause
= SCM_CAR (x
);
2023 SCM labels
= SCM_CAR (clause
);
2024 if (SCM_EQ_P (labels
, scm_sym_else
))
2026 x
= SCM_CDR (clause
);
2027 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2030 while (!SCM_NULLP (labels
))
2032 SCM label
= SCM_CAR (labels
);
2033 if (SCM_EQ_P (label
, key
) || !SCM_FALSEP (scm_eqv_p (label
, key
)))
2035 x
= SCM_CDR (clause
);
2036 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2039 labels
= SCM_CDR (labels
);
2044 RETURN (SCM_UNSPECIFIED
);
2047 case SCM_BIT8 (SCM_IM_COND
):
2049 while (!SCM_NULLP (x
))
2051 SCM clause
= SCM_CAR (x
);
2052 if (SCM_EQ_P (SCM_CAR (clause
), scm_sym_else
))
2054 x
= SCM_CDR (clause
);
2055 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2060 arg1
= EVALCAR (clause
, env
);
2061 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
2063 x
= SCM_CDR (clause
);
2066 else if (!SCM_EQ_P (SCM_CAR (x
), scm_sym_arrow
))
2068 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2074 proc
= EVALCAR (proc
, env
);
2075 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2076 PREP_APPLY (proc
, scm_list_1 (arg1
));
2078 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2079 goto umwrongnumargs
;
2087 RETURN (SCM_UNSPECIFIED
);
2090 case SCM_BIT8 (SCM_IM_DO
):
2093 /* Compute the initialization values and the initial environment. */
2094 SCM init_forms
= SCM_CADR (x
);
2095 SCM init_values
= SCM_EOL
;
2096 while (!SCM_NULLP (init_forms
))
2098 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2099 init_forms
= SCM_CDR (init_forms
);
2101 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2105 SCM test_form
= SCM_CAR (x
);
2106 SCM body_forms
= SCM_CADR (x
);
2107 SCM step_forms
= SCM_CDDR (x
);
2109 SCM test_result
= EVALCAR (test_form
, env
);
2111 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
2114 /* Evaluate body forms. */
2116 for (temp_forms
= body_forms
;
2117 !SCM_NULLP (temp_forms
);
2118 temp_forms
= SCM_CDR (temp_forms
))
2120 SCM form
= SCM_CAR (temp_forms
);
2121 /* Dirk:FIXME: We only need to eval forms, that may have a
2122 * side effect here. This is only true for forms that start
2123 * with a pair. All others are just constants. However,
2124 * since in the common case there is no constant expression
2125 * in a body of a do form, we just check for immediates here
2126 * and have SCM_CEVAL take care of other cases. In the long
2127 * run it would make sense to get rid of this test and have
2128 * the macro transformer of 'do' eliminate all forms that
2129 * have no sideeffect. */
2130 if (!SCM_IMP (form
))
2131 SCM_CEVAL (form
, env
);
2136 /* Evaluate the step expressions. */
2138 SCM step_values
= SCM_EOL
;
2139 for (temp_forms
= step_forms
;
2140 !SCM_NULLP (temp_forms
);
2141 temp_forms
= SCM_CDR (temp_forms
))
2143 SCM value
= EVALCAR (temp_forms
, env
);
2144 step_values
= scm_cons (value
, step_values
);
2146 env
= EXTEND_ENV (SCM_CAAR (env
), step_values
, SCM_CDR (env
));
2149 test_result
= EVALCAR (test_form
, env
);
2154 RETURN (SCM_UNSPECIFIED
);
2155 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2156 goto nontoplevel_begin
;
2159 case SCM_BIT8 (SCM_IM_IF
):
2162 SCM test_result
= EVALCAR (x
, env
);
2163 if (!SCM_FALSEP (test_result
) && !SCM_NILP (test_result
))
2169 RETURN (SCM_UNSPECIFIED
);
2172 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2176 case SCM_BIT8 (SCM_IM_LET
):
2179 SCM init_forms
= SCM_CADR (x
);
2180 SCM init_values
= SCM_EOL
;
2183 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2184 init_forms
= SCM_CDR (init_forms
);
2186 while (!SCM_NULLP (init_forms
));
2187 env
= EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
2190 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2191 goto nontoplevel_begin
;
2194 case SCM_BIT8 (SCM_IM_LETREC
):
2196 env
= EXTEND_ENV (SCM_CAR (x
), scm_undefineds
, env
);
2199 SCM init_forms
= SCM_CAR (x
);
2200 SCM init_values
= SCM_EOL
;
2203 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
2204 init_forms
= SCM_CDR (init_forms
);
2206 while (!SCM_NULLP (init_forms
));
2207 SCM_SETCDR (SCM_CAR (env
), init_values
);
2210 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2211 goto nontoplevel_begin
;
2214 case SCM_BIT8 (SCM_IM_LETSTAR
):
2217 SCM bindings
= SCM_CAR (x
);
2218 if (SCM_NULLP (bindings
))
2219 env
= EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2224 SCM name
= SCM_CAR (bindings
);
2225 SCM init
= SCM_CDR (bindings
);
2226 env
= EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
2227 bindings
= SCM_CDR (init
);
2229 while (!SCM_NULLP (bindings
));
2233 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2234 goto nontoplevel_begin
;
2237 case SCM_BIT8 (SCM_IM_OR
):
2239 while (!SCM_NULLP (SCM_CDR (x
)))
2241 SCM val
= EVALCAR (x
, env
);
2242 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
2247 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2251 case SCM_BIT8 (SCM_IM_LAMBDA
):
2252 RETURN (scm_closure (SCM_CDR (x
), env
));
2255 case SCM_BIT8 (SCM_IM_QUOTE
):
2256 RETURN (SCM_CADR (x
));
2259 case SCM_BIT8 (SCM_IM_SET_X
):
2263 SCM variable
= SCM_CAR (x
);
2264 if (SCM_ILOCP (variable
))
2265 location
= scm_ilookup (variable
, env
);
2266 else if (SCM_VARIABLEP (variable
))
2267 location
= SCM_VARIABLE_LOC (variable
);
2268 else /* (SCM_SYMBOLP (variable)) is known to be true */
2269 location
= scm_lookupcar (x
, env
, 1);
2271 *location
= EVALCAR (x
, env
);
2273 RETURN (SCM_UNSPECIFIED
);
2276 case SCM_BIT8(SCM_IM_DEFINE
): /* only for internal defines */
2277 scm_misc_error (NULL
, "Bad define placement", SCM_EOL
);
2280 /* new syntactic forms go here. */
2281 case SCM_BIT8 (SCM_MAKISYM (0)):
2283 SCM_ASRTGO (SCM_ISYMP (proc
), badfun
);
2284 switch (SCM_ISYMNUM (proc
))
2288 case (SCM_ISYMNUM (SCM_IM_APPLY
)):
2290 proc
= EVALCAR (proc
, env
);
2291 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2292 if (SCM_CLOSUREP (proc
))
2294 PREP_APPLY (proc
, SCM_EOL
);
2295 arg1
= SCM_CDDR (x
);
2296 arg1
= EVALCAR (arg1
, env
);
2298 /* Go here to tail-call a closure. PROC is the closure
2299 and ARG1 is the list of arguments. Do not forget to
2302 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2304 debug
.info
->a
.args
= arg1
;
2306 if (scm_badargsp (formals
, arg1
))
2307 scm_wrong_num_args (proc
);
2309 /* Copy argument list */
2310 if (SCM_NULL_OR_NIL_P (arg1
))
2311 env
= EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
2314 SCM args
= scm_list_1 (SCM_CAR (arg1
));
2316 arg1
= SCM_CDR (arg1
);
2317 while (!SCM_NULL_OR_NIL_P (arg1
))
2319 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
2320 SCM_SETCDR (tail
, new_tail
);
2322 arg1
= SCM_CDR (arg1
);
2324 env
= EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
2327 x
= SCM_CLOSURE_BODY (proc
);
2328 goto nontoplevel_begin
;
2338 case (SCM_ISYMNUM (SCM_IM_CONT
)):
2341 SCM val
= scm_make_continuation (&first
);
2349 proc
= scm_eval_car (proc
, env
);
2350 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2351 PREP_APPLY (proc
, scm_list_1 (arg1
));
2353 if (SCM_CLOSUREP(proc
) && scm_badformalsp (proc
, 1))
2354 goto umwrongnumargs
;
2360 case (SCM_ISYMNUM (SCM_IM_DELAY
)):
2361 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
2364 case (SCM_ISYMNUM (SCM_IM_DISPATCH
)):
2366 /* If not done yet, evaluate the operand forms. The result is a
2367 * list of arguments stored in arg1, which is used to perform the
2368 * function dispatch. */
2369 SCM operand_forms
= SCM_CADR (x
);
2370 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2371 if (SCM_ILOCP (operand_forms
))
2372 arg1
= *scm_ilookup (operand_forms
, env
);
2373 else if (SCM_VARIABLEP (operand_forms
))
2374 arg1
= SCM_VARIABLE_REF (operand_forms
);
2375 else if (!SCM_CONSP (operand_forms
))
2376 arg1
= *scm_lookupcar (SCM_CDR (x
), env
, 1);
2379 SCM tail
= arg1
= scm_list_1 (EVALCAR (operand_forms
, env
));
2380 operand_forms
= SCM_CDR (operand_forms
);
2381 while (!SCM_NULLP (operand_forms
))
2383 SCM new_tail
= scm_list_1 (EVALCAR (operand_forms
, env
));
2384 SCM_SETCDR (tail
, new_tail
);
2386 operand_forms
= SCM_CDR (operand_forms
);
2391 /* The type dispatch code is duplicated below
2392 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
2393 * cuts down execution time for type dispatch to 50%. */
2394 type_dispatch
: /* inputs: x, arg1 */
2395 /* Type dispatch means to determine from the types of the function
2396 * arguments (i. e. the 'signature' of the call), which method from
2397 * a generic function is to be called. This process of selecting
2398 * the right method takes some time. To speed it up, guile uses
2399 * caching: Together with the macro call to dispatch the signatures
2400 * of some previous calls to that generic function from the same
2401 * place are stored (in the code!) in a cache that we call the
2402 * 'method cache'. This is done since it is likely, that
2403 * consecutive calls to dispatch from that position in the code will
2404 * have the same signature. Thus, the type dispatch works as
2405 * follows: First, determine a hash value from the signature of the
2406 * actual arguments. Second, use this hash value as an index to
2407 * find that same signature in the method cache stored at this
2408 * position in the code. If found, you have also found the
2409 * corresponding method that belongs to that signature. If the
2410 * signature is not found in the method cache, you have to perform a
2411 * full search over all signatures stored with the generic
2414 unsigned long int specializers
;
2415 unsigned long int hash_value
;
2416 unsigned long int cache_end_pos
;
2417 unsigned long int mask
;
2421 SCM z
= SCM_CDDR (x
);
2422 SCM tmp
= SCM_CADR (z
);
2423 specializers
= SCM_INUM (SCM_CAR (z
));
2425 /* Compute a hash value for searching the method cache. There
2426 * are two variants for computing the hash value, a (rather)
2427 * complicated one, and a simple one. For the complicated one
2428 * explained below, tmp holds a number that is used in the
2430 if (SCM_INUMP (tmp
))
2432 /* Use the signature of the actual arguments to determine
2433 * the hash value. This is done as follows: Each class has
2434 * an array of random numbers, that are determined when the
2435 * class is created. The integer 'hashset' is an index into
2436 * that array of random numbers. Now, from all classes that
2437 * are part of the signature of the actual arguments, the
2438 * random numbers at index 'hashset' are taken and summed
2439 * up, giving the hash value. The value of 'hashset' is
2440 * stored at the call to dispatch. This allows to have
2441 * different 'formulas' for calculating the hash value at
2442 * different places where dispatch is called. This allows
2443 * to optimize the hash formula at every individual place
2444 * where dispatch is called, such that hopefully the hash
2445 * value that is computed will directly point to the right
2446 * method in the method cache. */
2447 unsigned long int hashset
= SCM_INUM (tmp
);
2448 unsigned long int counter
= specializers
+ 1;
2451 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
2453 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
2454 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
2455 tmp_arg
= SCM_CDR (tmp_arg
);
2459 method_cache
= SCM_CADR (z
);
2460 mask
= SCM_INUM (SCM_CAR (z
));
2462 cache_end_pos
= hash_value
;
2466 /* This method of determining the hash value is much
2467 * simpler: Set the hash value to zero and just perform a
2468 * linear search through the method cache. */
2470 mask
= (unsigned long int) ((long) -1);
2472 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
2477 /* Search the method cache for a method with a matching
2478 * signature. Start the search at position 'hash_value'. The
2479 * hashing implementation uses linear probing for conflict
2480 * resolution, that is, if the signature in question is not
2481 * found at the starting index in the hash table, the next table
2482 * entry is tried, and so on, until in the worst case the whole
2483 * cache has been searched, but still the signature has not been
2488 SCM args
= arg1
; /* list of arguments */
2489 z
= SCM_VELTS (method_cache
)[hash_value
];
2490 while (!SCM_NULLP (args
))
2492 /* More arguments than specifiers => CLASS != ENV */
2493 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
2494 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
2496 args
= SCM_CDR (args
);
2499 /* Fewer arguments than specifiers => CAR != ENV */
2500 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
2503 hash_value
= (hash_value
+ 1) & mask
;
2504 } while (hash_value
!= cache_end_pos
);
2506 /* No appropriate method was found in the cache. */
2507 z
= scm_memoize_method (x
, arg1
);
2509 apply_cmethod
: /* inputs: z, arg1 */
2511 SCM formals
= SCM_CMETHOD_FORMALS (z
);
2512 env
= EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
2513 x
= SCM_CMETHOD_BODY (z
);
2514 goto nontoplevel_begin
;
2520 case (SCM_ISYMNUM (SCM_IM_SLOT_REF
)):
2523 SCM instance
= EVALCAR (x
, env
);
2524 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2525 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
2529 case (SCM_ISYMNUM (SCM_IM_SLOT_SET_X
)):
2532 SCM instance
= EVALCAR (x
, env
);
2533 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
2534 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
2535 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
2536 RETURN (SCM_UNSPECIFIED
);
2540 #ifdef SCM_ENABLE_ELISP
2542 case (SCM_ISYMNUM (SCM_IM_NIL_COND
)):
2544 SCM test_form
= SCM_CDR (x
);
2545 x
= SCM_CDR (test_form
);
2546 while (!SCM_NULL_OR_NIL_P (x
))
2548 SCM test_result
= EVALCAR (test_form
, env
);
2549 if (!(SCM_FALSEP (test_result
)
2550 || SCM_NULL_OR_NIL_P (test_result
)))
2552 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
2553 RETURN (test_result
);
2554 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2559 test_form
= SCM_CDR (x
);
2560 x
= SCM_CDR (test_form
);
2564 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2568 #endif /* SCM_ENABLE_ELISP */
2570 case (SCM_ISYMNUM (SCM_IM_BIND
)):
2572 SCM vars
, exps
, vals
;
2575 vars
= SCM_CAAR (x
);
2576 exps
= SCM_CDAR (x
);
2580 while (SCM_NIMP (exps
))
2582 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
2583 exps
= SCM_CDR (exps
);
2586 scm_swap_bindings (vars
, vals
);
2587 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
2589 /* Ignore all but the last evaluation result. */
2590 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
2592 if (SCM_CONSP (SCM_CAR (x
)))
2593 SCM_CEVAL (SCM_CAR (x
), env
);
2595 proc
= EVALCAR (x
, env
);
2597 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
2598 scm_swap_bindings (vars
, vals
);
2604 case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2607 x
= EVALCAR (proc
, env
);
2608 proc
= SCM_CDR (proc
);
2609 proc
= EVALCAR (proc
, env
);
2610 arg1
= SCM_APPLY (x
, SCM_EOL
, SCM_EOL
);
2611 if (SCM_VALUESP (arg1
))
2612 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
2614 arg1
= scm_list_1 (arg1
);
2615 if (SCM_CLOSUREP (proc
))
2617 PREP_APPLY (proc
, arg1
);
2620 return SCM_APPLY (proc
, arg1
, SCM_EOL
);
2631 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
2632 case scm_tc7_vector
:
2636 case scm_tc7_byvect
:
2643 #ifdef HAVE_LONG_LONGS
2644 case scm_tc7_llvect
:
2647 case scm_tc7_string
:
2649 case scm_tcs_closures
:
2653 case scm_tcs_struct
:
2656 case scm_tc7_variable
:
2657 RETURN (SCM_VARIABLE_REF(x
));
2659 case SCM_BIT8(SCM_ILOC00
):
2660 proc
= *scm_ilookup (SCM_CAR (x
), env
);
2661 SCM_ASRTGO (SCM_NIMP (proc
), badfun
);
2664 case scm_tcs_cons_nimcar
:
2665 if (SCM_SYMBOLP (SCM_CAR (x
)))
2667 SCM orig_sym
= SCM_CAR (x
);
2669 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
2670 if (location
== NULL
)
2672 /* we have lost the race, start again. */
2680 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2684 if (SCM_MACROP (proc
))
2686 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
2688 handle_a_macro
: /* inputs: x, env, proc */
2690 /* Set a flag during macro expansion so that macro
2691 application frames can be deleted from the backtrace. */
2692 SCM_SET_MACROEXP (debug
);
2694 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
2695 scm_cons (env
, scm_listofnull
));
2698 SCM_CLEAR_MACROEXP (debug
);
2700 switch (SCM_MACRO_TYPE (proc
))
2703 if (scm_ilength (arg1
) <= 0)
2704 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
2706 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
2709 SCM_SETCAR (x
, SCM_CAR (arg1
));
2710 SCM_SETCDR (x
, SCM_CDR (arg1
));
2714 /* Prevent memoizing of debug info expression. */
2715 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
2720 SCM_SETCAR (x
, SCM_CAR (arg1
));
2721 SCM_SETCDR (x
, SCM_CDR (arg1
));
2723 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2725 #if SCM_ENABLE_DEPRECATED == 1
2730 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
2742 proc
= SCM_CEVAL (SCM_CAR (x
), env
);
2743 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
2746 if (SCM_CLOSUREP (proc
))
2748 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
2749 SCM args
= SCM_CDR (x
);
2750 while (!SCM_NULLP (formals
))
2752 if (!SCM_CONSP (formals
))
2755 goto umwrongnumargs
;
2756 formals
= SCM_CDR (formals
);
2757 args
= SCM_CDR (args
);
2759 if (!SCM_NULLP (args
))
2760 goto umwrongnumargs
;
2762 else if (SCM_MACROP (proc
))
2763 goto handle_a_macro
;
2767 evapply
: /* inputs: x, proc */
2768 PREP_APPLY (proc
, SCM_EOL
);
2769 if (SCM_NULLP (SCM_CDR (x
))) {
2772 switch (SCM_TYP7 (proc
))
2773 { /* no arguments given */
2774 case scm_tc7_subr_0
:
2775 RETURN (SCM_SUBRF (proc
) ());
2776 case scm_tc7_subr_1o
:
2777 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
2779 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
2780 case scm_tc7_rpsubr
:
2781 RETURN (SCM_BOOL_T
);
2783 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
2785 if (!SCM_SMOB_APPLICABLE_P (proc
))
2787 RETURN (SCM_SMOB_APPLY_0 (proc
));
2790 proc
= SCM_CCLO_SUBR (proc
);
2792 debug
.info
->a
.proc
= proc
;
2793 debug
.info
->a
.args
= scm_list_1 (arg1
);
2797 proc
= SCM_PROCEDURE (proc
);
2799 debug
.info
->a
.proc
= proc
;
2801 if (!SCM_CLOSUREP (proc
))
2803 if (scm_badformalsp (proc
, 0))
2804 goto umwrongnumargs
;
2805 case scm_tcs_closures
:
2806 x
= SCM_CLOSURE_BODY (proc
);
2807 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), SCM_EOL
, SCM_ENV (proc
));
2808 goto nontoplevel_begin
;
2809 case scm_tcs_struct
:
2810 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2812 x
= SCM_ENTITY_PROCEDURE (proc
);
2816 else if (!SCM_I_OPERATORP (proc
))
2821 proc
= (SCM_I_ENTITYP (proc
)
2822 ? SCM_ENTITY_PROCEDURE (proc
)
2823 : SCM_OPERATOR_PROCEDURE (proc
));
2825 debug
.info
->a
.proc
= proc
;
2826 debug
.info
->a
.args
= scm_list_1 (arg1
);
2828 if (SCM_NIMP (proc
))
2833 case scm_tc7_subr_1
:
2834 case scm_tc7_subr_2
:
2835 case scm_tc7_subr_2o
:
2837 case scm_tc7_subr_3
:
2838 case scm_tc7_lsubr_2
:
2841 scm_wrong_num_args (proc
);
2843 /* handle macros here */
2848 /* must handle macros by here */
2851 arg1
= EVALCAR (x
, env
);
2853 scm_wrong_num_args (proc
);
2855 debug
.info
->a
.args
= scm_list_1 (arg1
);
2863 evap1
: /* inputs: proc, arg1 */
2864 switch (SCM_TYP7 (proc
))
2865 { /* have one argument in arg1 */
2866 case scm_tc7_subr_2o
:
2867 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2868 case scm_tc7_subr_1
:
2869 case scm_tc7_subr_1o
:
2870 RETURN (SCM_SUBRF (proc
) (arg1
));
2872 if (SCM_SUBRF (proc
))
2874 if (SCM_INUMP (arg1
))
2876 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
2878 else if (SCM_REALP (arg1
))
2880 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
2883 else if (SCM_BIGP (arg1
))
2885 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
2888 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
2889 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
2891 proc
= SCM_SNAME (proc
);
2893 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
2894 while ('c' != *--chrs
)
2896 SCM_ASSERT (SCM_CONSP (arg1
),
2897 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
2898 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
2902 case scm_tc7_rpsubr
:
2903 RETURN (SCM_BOOL_T
);
2905 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
2908 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
2910 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
2913 if (!SCM_SMOB_APPLICABLE_P (proc
))
2915 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
2919 proc
= SCM_CCLO_SUBR (proc
);
2921 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2922 debug
.info
->a
.proc
= proc
;
2926 proc
= SCM_PROCEDURE (proc
);
2928 debug
.info
->a
.proc
= proc
;
2930 if (!SCM_CLOSUREP (proc
))
2932 if (scm_badformalsp (proc
, 1))
2933 goto umwrongnumargs
;
2934 case scm_tcs_closures
:
2936 x
= SCM_CLOSURE_BODY (proc
);
2938 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
, SCM_ENV (proc
));
2940 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), scm_list_1 (arg1
), SCM_ENV (proc
));
2942 goto nontoplevel_begin
;
2943 case scm_tcs_struct
:
2944 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
2946 x
= SCM_ENTITY_PROCEDURE (proc
);
2948 arg1
= debug
.info
->a
.args
;
2950 arg1
= scm_list_1 (arg1
);
2954 else if (!SCM_I_OPERATORP (proc
))
2960 proc
= (SCM_I_ENTITYP (proc
)
2961 ? SCM_ENTITY_PROCEDURE (proc
)
2962 : SCM_OPERATOR_PROCEDURE (proc
));
2964 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
2965 debug
.info
->a
.proc
= proc
;
2967 if (SCM_NIMP (proc
))
2972 case scm_tc7_subr_2
:
2973 case scm_tc7_subr_0
:
2974 case scm_tc7_subr_3
:
2975 case scm_tc7_lsubr_2
:
2976 scm_wrong_num_args (proc
);
2982 arg2
= EVALCAR (x
, env
);
2984 scm_wrong_num_args (proc
);
2986 { /* have two or more arguments */
2988 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
2991 if (SCM_NULLP (x
)) {
2994 switch (SCM_TYP7 (proc
))
2995 { /* have two arguments */
2996 case scm_tc7_subr_2
:
2997 case scm_tc7_subr_2o
:
2998 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3001 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3003 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
3005 case scm_tc7_lsubr_2
:
3006 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
3007 case scm_tc7_rpsubr
:
3009 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
3011 if (!SCM_SMOB_APPLICABLE_P (proc
))
3013 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
3017 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3018 scm_cons (proc
, debug
.info
->a
.args
),
3021 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
3022 scm_cons2 (proc
, arg1
,
3029 case scm_tcs_struct
:
3030 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3032 x
= SCM_ENTITY_PROCEDURE (proc
);
3034 arg1
= debug
.info
->a
.args
;
3036 arg1
= scm_list_2 (arg1
, arg2
);
3040 else if (!SCM_I_OPERATORP (proc
))
3046 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3047 ? SCM_ENTITY_PROCEDURE (proc
)
3048 : SCM_OPERATOR_PROCEDURE (proc
),
3049 scm_cons (proc
, debug
.info
->a
.args
),
3052 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
3053 ? SCM_ENTITY_PROCEDURE (proc
)
3054 : SCM_OPERATOR_PROCEDURE (proc
),
3055 scm_cons2 (proc
, arg1
,
3063 case scm_tc7_subr_0
:
3065 case scm_tc7_subr_1o
:
3066 case scm_tc7_subr_1
:
3067 case scm_tc7_subr_3
:
3068 scm_wrong_num_args (proc
);
3072 proc
= SCM_PROCEDURE (proc
);
3074 debug
.info
->a
.proc
= proc
;
3076 if (!SCM_CLOSUREP (proc
))
3078 if (scm_badformalsp (proc
, 2))
3079 goto umwrongnumargs
;
3080 case scm_tcs_closures
:
3083 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3087 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3088 scm_list_2 (arg1
, arg2
), SCM_ENV (proc
));
3090 x
= SCM_CLOSURE_BODY (proc
);
3091 goto nontoplevel_begin
;
3095 scm_wrong_num_args (proc
);
3097 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
3098 deval_args (x
, env
, proc
,
3099 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
3103 switch (SCM_TYP7 (proc
))
3104 { /* have 3 or more arguments */
3106 case scm_tc7_subr_3
:
3107 if (!SCM_NULLP (SCM_CDR (x
)))
3108 scm_wrong_num_args (proc
);
3110 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3111 SCM_CADDR (debug
.info
->a
.args
)));
3113 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
3114 arg2
= SCM_CDDR (debug
.info
->a
.args
);
3117 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
3118 arg2
= SCM_CDR (arg2
);
3120 while (SCM_NIMP (arg2
));
3122 case scm_tc7_rpsubr
:
3123 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3124 RETURN (SCM_BOOL_F
);
3125 arg1
= SCM_CDDR (debug
.info
->a
.args
);
3128 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
3129 RETURN (SCM_BOOL_F
);
3130 arg2
= SCM_CAR (arg1
);
3131 arg1
= SCM_CDR (arg1
);
3133 while (SCM_NIMP (arg1
));
3134 RETURN (SCM_BOOL_T
);
3135 case scm_tc7_lsubr_2
:
3136 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
3137 SCM_CDDR (debug
.info
->a
.args
)));
3139 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3141 if (!SCM_SMOB_APPLICABLE_P (proc
))
3143 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3144 SCM_CDDR (debug
.info
->a
.args
)));
3148 proc
= SCM_PROCEDURE (proc
);
3149 debug
.info
->a
.proc
= proc
;
3150 if (!SCM_CLOSUREP (proc
))
3152 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), debug
.info
->a
.args
))
3153 goto umwrongnumargs
;
3154 case scm_tcs_closures
:
3155 SCM_SET_ARGSREADY (debug
);
3156 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3159 x
= SCM_CLOSURE_BODY (proc
);
3160 goto nontoplevel_begin
;
3162 case scm_tc7_subr_3
:
3163 if (!SCM_NULLP (SCM_CDR (x
)))
3164 scm_wrong_num_args (proc
);
3166 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
3168 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
3171 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
3174 while (SCM_NIMP (x
));
3176 case scm_tc7_rpsubr
:
3177 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
3178 RETURN (SCM_BOOL_F
);
3181 arg1
= EVALCAR (x
, env
);
3182 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
3183 RETURN (SCM_BOOL_F
);
3187 while (SCM_NIMP (x
));
3188 RETURN (SCM_BOOL_T
);
3189 case scm_tc7_lsubr_2
:
3190 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
3192 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
3194 scm_eval_args (x
, env
, proc
))));
3196 if (!SCM_SMOB_APPLICABLE_P (proc
))
3198 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
3199 scm_eval_args (x
, env
, proc
)));
3203 proc
= SCM_PROCEDURE (proc
);
3204 if (!SCM_CLOSUREP (proc
))
3207 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3208 if (SCM_NULLP (formals
)
3209 || (SCM_CONSP (formals
)
3210 && (SCM_NULLP (SCM_CDR (formals
))
3211 || (SCM_CONSP (SCM_CDR (formals
))
3212 && scm_badargsp (SCM_CDDR (formals
), x
)))))
3213 goto umwrongnumargs
;
3215 case scm_tcs_closures
:
3217 SCM_SET_ARGSREADY (debug
);
3219 env
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
3222 scm_eval_args (x
, env
, proc
)),
3224 x
= SCM_CLOSURE_BODY (proc
);
3225 goto nontoplevel_begin
;
3227 case scm_tcs_struct
:
3228 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3231 arg1
= debug
.info
->a
.args
;
3233 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
3235 x
= SCM_ENTITY_PROCEDURE (proc
);
3238 else if (!SCM_I_OPERATORP (proc
))
3242 case scm_tc7_subr_2
:
3243 case scm_tc7_subr_1o
:
3244 case scm_tc7_subr_2o
:
3245 case scm_tc7_subr_0
:
3247 case scm_tc7_subr_1
:
3248 scm_wrong_num_args (proc
);
3256 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3257 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3259 SCM_CLEAR_TRACED_FRAME (debug
);
3260 if (SCM_CHEAPTRAPS_P
)
3261 arg1
= scm_make_debugobj (&debug
);
3265 SCM val
= scm_make_continuation (&first
);
3276 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3280 scm_last_debug_frame
= debug
.prev
;
3286 /* SECTION: This code is compiled once.
3292 /* Simple procedure calls
3296 scm_call_0 (SCM proc
)
3298 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
3302 scm_call_1 (SCM proc
, SCM arg1
)
3304 return scm_apply (proc
, arg1
, scm_listofnull
);
3308 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
3310 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
3314 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
3316 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
3320 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
3322 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
3323 scm_cons (arg4
, scm_listofnull
)));
3326 /* Simple procedure applies
3330 scm_apply_0 (SCM proc
, SCM args
)
3332 return scm_apply (proc
, args
, SCM_EOL
);
3336 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
3338 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
3342 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
3344 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
3348 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
3350 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
3354 /* This code processes the arguments to apply:
3356 (apply PROC ARG1 ... ARGS)
3358 Given a list (ARG1 ... ARGS), this function conses the ARG1
3359 ... arguments onto the front of ARGS, and returns the resulting
3360 list. Note that ARGS is a list; thus, the argument to this
3361 function is a list whose last element is a list.
3363 Apply calls this function, and applies PROC to the elements of the
3364 result. apply:nconc2last takes care of building the list of
3365 arguments, given (ARG1 ... ARGS).
3367 Rather than do new consing, apply:nconc2last destroys its argument.
3368 On that topic, this code came into my care with the following
3369 beautifully cryptic comment on that topic: "This will only screw
3370 you if you do (scm_apply scm_apply '( ... ))" If you know what
3371 they're referring to, send me a patch to this comment. */
3373 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
3375 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
3376 "conses the @var{arg1} @dots{} arguments onto the front of\n"
3377 "@var{args}, and returns the resulting list. Note that\n"
3378 "@var{args} is a list; thus, the argument to this function is\n"
3379 "a list whose last element is a list.\n"
3380 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
3381 "destroys its argument, so use with care.")
3382 #define FUNC_NAME s_scm_nconc2last
3385 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
3387 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
3388 SCM_NULL_OR_NIL_P, but not
3389 needed in 99.99% of cases,
3390 and it could seriously hurt
3391 performance. - Neil */
3392 lloc
= SCM_CDRLOC (*lloc
);
3393 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
3394 *lloc
= SCM_CAR (*lloc
);
3402 /* SECTION: When DEVAL is defined this code yields scm_dapply.
3403 * It is compiled twice.
3408 scm_apply (SCM proc
, SCM arg1
, SCM args
)
3414 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
3419 /* Apply a function to a list of arguments.
3421 This function is exported to the Scheme level as taking two
3422 required arguments and a tail argument, as if it were:
3423 (lambda (proc arg1 . args) ...)
3424 Thus, if you just have a list of arguments to pass to a procedure,
3425 pass the list as ARG1, and '() for ARGS. If you have some fixed
3426 args, pass the first as ARG1, then cons any remaining fixed args
3427 onto the front of your argument list, and pass that as ARGS. */
3430 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
3432 #ifdef DEBUG_EXTENSIONS
3434 scm_t_debug_frame debug
;
3435 scm_t_debug_info debug_vect_body
;
3436 debug
.prev
= scm_last_debug_frame
;
3437 debug
.status
= SCM_APPLYFRAME
;
3438 debug
.vect
= &debug_vect_body
;
3439 debug
.vect
[0].a
.proc
= proc
;
3440 debug
.vect
[0].a
.args
= SCM_EOL
;
3441 scm_last_debug_frame
= &debug
;
3444 return scm_dapply (proc
, arg1
, args
);
3448 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
3450 /* If ARGS is the empty list, then we're calling apply with only two
3451 arguments --- ARG1 is the list of arguments for PROC. Whatever
3452 the case, futz with things so that ARG1 is the first argument to
3453 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
3456 Setting the debug apply frame args this way is pretty messy.
3457 Perhaps we should store arg1 and args directly in the frame as
3458 received, and let scm_frame_arguments unpack them, because that's
3459 a relatively rare operation. This works for now; if the Guile
3460 developer archives are still around, see Mikael's post of
3462 if (SCM_NULLP (args
))
3464 if (SCM_NULLP (arg1
))
3466 arg1
= SCM_UNDEFINED
;
3468 debug
.vect
[0].a
.args
= SCM_EOL
;
3474 debug
.vect
[0].a
.args
= arg1
;
3476 args
= SCM_CDR (arg1
);
3477 arg1
= SCM_CAR (arg1
);
3482 args
= scm_nconc2last (args
);
3484 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3488 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
3491 if (SCM_CHEAPTRAPS_P
)
3492 tmp
= scm_make_debugobj (&debug
);
3497 tmp
= scm_make_continuation (&first
);
3502 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
3509 switch (SCM_TYP7 (proc
))
3511 case scm_tc7_subr_2o
:
3512 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
3513 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3514 case scm_tc7_subr_2
:
3515 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
3516 scm_wrong_num_args (proc
);
3517 args
= SCM_CAR (args
);
3518 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
3519 case scm_tc7_subr_0
:
3520 if (!SCM_UNBNDP (arg1
))
3521 scm_wrong_num_args (proc
);
3523 RETURN (SCM_SUBRF (proc
) ());
3524 case scm_tc7_subr_1
:
3525 if (SCM_UNBNDP (arg1
))
3526 scm_wrong_num_args (proc
);
3527 case scm_tc7_subr_1o
:
3528 if (!SCM_NULLP (args
))
3529 scm_wrong_num_args (proc
);
3531 RETURN (SCM_SUBRF (proc
) (arg1
));
3533 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
3534 scm_wrong_num_args (proc
);
3535 if (SCM_SUBRF (proc
))
3537 if (SCM_INUMP (arg1
))
3539 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3541 else if (SCM_REALP (arg1
))
3543 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3546 else if (SCM_BIGP (arg1
))
3547 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3549 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3550 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3552 proc
= SCM_SNAME (proc
);
3554 char *chrs
= SCM_SYMBOL_CHARS (proc
) + SCM_SYMBOL_LENGTH (proc
) - 1;
3555 while ('c' != *--chrs
)
3557 SCM_ASSERT (SCM_CONSP (arg1
),
3558 arg1
, SCM_ARG1
, SCM_SYMBOL_CHARS (proc
));
3559 arg1
= ('a' == *chrs
) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3563 case scm_tc7_subr_3
:
3564 if (SCM_NULLP (args
)
3565 || SCM_NULLP (SCM_CDR (args
))
3566 || !SCM_NULLP (SCM_CDDR (args
)))
3567 scm_wrong_num_args (proc
);
3569 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
3572 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
3574 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
3576 case scm_tc7_lsubr_2
:
3577 if (!SCM_CONSP (args
))
3578 scm_wrong_num_args (proc
);
3580 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3582 if (SCM_NULLP (args
))
3583 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3584 while (SCM_NIMP (args
))
3586 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3587 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
3588 args
= SCM_CDR (args
);
3591 case scm_tc7_rpsubr
:
3592 if (SCM_NULLP (args
))
3593 RETURN (SCM_BOOL_T
);
3594 while (SCM_NIMP (args
))
3596 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
3597 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
3598 RETURN (SCM_BOOL_F
);
3599 arg1
= SCM_CAR (args
);
3600 args
= SCM_CDR (args
);
3602 RETURN (SCM_BOOL_T
);
3603 case scm_tcs_closures
:
3605 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3607 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3609 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
3610 scm_wrong_num_args (proc
);
3612 /* Copy argument list */
3617 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
3618 while (arg1
= SCM_CDR (arg1
), SCM_CONSP (arg1
))
3620 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
),
3624 SCM_SETCDR (tl
, arg1
);
3627 args
= EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
), args
, SCM_ENV (proc
));
3628 proc
= SCM_CLOSURE_BODY (proc
);
3631 while (!SCM_NULLP (arg1
= SCM_CDR (arg1
)))
3633 if (SCM_IMP (SCM_CAR (proc
)))
3635 if (SCM_ISYMP (SCM_CAR (proc
)))
3637 proc
= scm_m_expand_body (proc
, args
);
3641 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
3644 SCM_CEVAL (SCM_CAR (proc
), args
);
3647 RETURN (EVALCAR (proc
, args
));
3649 if (!SCM_SMOB_APPLICABLE_P (proc
))
3651 if (SCM_UNBNDP (arg1
))
3652 RETURN (SCM_SMOB_APPLY_0 (proc
));
3653 else if (SCM_NULLP (args
))
3654 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3655 else if (SCM_NULLP (SCM_CDR (args
)))
3656 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
3658 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
3661 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3663 proc
= SCM_CCLO_SUBR (proc
);
3664 debug
.vect
[0].a
.proc
= proc
;
3665 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3667 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3669 proc
= SCM_CCLO_SUBR (proc
);
3673 proc
= SCM_PROCEDURE (proc
);
3675 debug
.vect
[0].a
.proc
= proc
;
3678 case scm_tcs_struct
:
3679 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3682 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3684 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3686 RETURN (scm_apply_generic (proc
, args
));
3688 else if (!SCM_I_OPERATORP (proc
))
3693 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
3695 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
3698 proc
= (SCM_I_ENTITYP (proc
)
3699 ? SCM_ENTITY_PROCEDURE (proc
)
3700 : SCM_OPERATOR_PROCEDURE (proc
));
3702 debug
.vect
[0].a
.proc
= proc
;
3703 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
3705 if (SCM_NIMP (proc
))
3712 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
3716 if (scm_check_exit_p
&& SCM_TRAPS_P
)
3717 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
3719 SCM_CLEAR_TRACED_FRAME (debug
);
3720 if (SCM_CHEAPTRAPS_P
)
3721 arg1
= scm_make_debugobj (&debug
);
3725 SCM val
= scm_make_continuation (&first
);
3736 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
3740 scm_last_debug_frame
= debug
.prev
;
3746 /* SECTION: The rest of this file is only read once.
3751 /* Typechecking for multi-argument MAP and FOR-EACH.
3753 Verify that each element of the vector ARGV, except for the first,
3754 is a proper list whose length is LEN. Attribute errors to WHO,
3755 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
3757 check_map_args (SCM argv
,
3764 SCM
const *ve
= SCM_VELTS (argv
);
3767 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
3769 long elt_len
= scm_ilength (ve
[i
]);
3774 scm_apply_generic (gf
, scm_cons (proc
, args
));
3776 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
3780 scm_out_of_range (who
, ve
[i
]);
3783 scm_remember_upto_here_1 (argv
);
3787 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
3789 /* Note: Currently, scm_map applies PROC to the argument list(s)
3790 sequentially, starting with the first element(s). This is used in
3791 evalext.c where the Scheme procedure `map-in-order', which guarantees
3792 sequential behaviour, is implemented using scm_map. If the
3793 behaviour changes, we need to update `map-in-order'.
3797 scm_map (SCM proc
, SCM arg1
, SCM args
)
3798 #define FUNC_NAME s_map
3803 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
3805 len
= scm_ilength (arg1
);
3806 SCM_GASSERTn (len
>= 0,
3807 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
3808 SCM_VALIDATE_REST_ARGUMENT (args
);
3809 if (SCM_NULLP (args
))
3811 while (SCM_NIMP (arg1
))
3813 *pres
= scm_list_1 (scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
));
3814 pres
= SCM_CDRLOC (*pres
);
3815 arg1
= SCM_CDR (arg1
);
3819 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3820 ve
= SCM_VELTS (args
);
3821 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
3825 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3827 if (SCM_IMP (ve
[i
]))
3829 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3830 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
3832 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
3833 pres
= SCM_CDRLOC (*pres
);
3839 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
3842 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
3843 #define FUNC_NAME s_for_each
3845 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
3847 len
= scm_ilength (arg1
);
3848 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
3849 SCM_ARG2
, s_for_each
);
3850 SCM_VALIDATE_REST_ARGUMENT (args
);
3851 if (SCM_NULLP (args
))
3853 while (SCM_NIMP (arg1
))
3855 scm_apply (proc
, SCM_CAR (arg1
), scm_listofnull
);
3856 arg1
= SCM_CDR (arg1
);
3858 return SCM_UNSPECIFIED
;
3860 args
= scm_vector (arg1
= scm_cons (arg1
, args
));
3861 ve
= SCM_VELTS (args
);
3862 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
3866 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
3868 if (SCM_IMP (ve
[i
]))
3869 return SCM_UNSPECIFIED
;
3870 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
3871 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
3873 scm_apply (proc
, arg1
, SCM_EOL
);
3880 scm_closure (SCM code
, SCM env
)
3883 SCM closcar
= scm_cons (code
, SCM_EOL
);
3884 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
3885 scm_remember_upto_here (closcar
);
3890 scm_t_bits scm_tc16_promise
;
3893 scm_makprom (SCM code
)
3895 SCM_RETURN_NEWSMOB (scm_tc16_promise
, SCM_UNPACK (code
));
3901 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
3903 int writingp
= SCM_WRITINGP (pstate
);
3904 scm_puts ("#<promise ", port
);
3905 SCM_SET_WRITINGP (pstate
, 1);
3906 scm_iprin1 (SCM_CELL_OBJECT_1 (exp
), port
, pstate
);
3907 SCM_SET_WRITINGP (pstate
, writingp
);
3908 scm_putc ('>', port
);
3913 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
3915 "If the promise @var{x} has not been computed yet, compute and\n"
3916 "return @var{x}, otherwise just return the previously computed\n"
3918 #define FUNC_NAME s_scm_force
3920 SCM_VALIDATE_SMOB (1, x
, promise
);
3921 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3923 SCM ans
= scm_call_0 (SCM_CELL_OBJECT_1 (x
));
3924 if (!((1L << 16) & SCM_CELL_WORD_0 (x
)))
3927 SCM_SET_CELL_OBJECT_1 (x
, ans
);
3928 SCM_SET_CELL_WORD_0 (x
, SCM_CELL_WORD_0 (x
) | (1L << 16));
3932 return SCM_CELL_OBJECT_1 (x
);
3937 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
3939 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
3940 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
3941 #define FUNC_NAME s_scm_promise_p
3943 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
3948 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
3949 (SCM xorig
, SCM x
, SCM y
),
3950 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
3951 "Any source properties associated with @var{xorig} are also associated\n"
3952 "with the new pair.")
3953 #define FUNC_NAME s_scm_cons_source
3956 z
= scm_cons (x
, y
);
3957 /* Copy source properties possibly associated with xorig. */
3958 p
= scm_whash_lookup (scm_source_whash
, xorig
);
3960 scm_whash_insert (scm_source_whash
, z
, p
);
3966 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
3968 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
3969 "pointer to the new data structure. @code{copy-tree} recurses down the\n"
3970 "contents of both pairs and vectors (since both cons cells and vector\n"
3971 "cells may point to arbitrary objects), and stops recursing when it hits\n"
3972 "any other object.")
3973 #define FUNC_NAME s_scm_copy_tree
3978 if (SCM_VECTORP (obj
))
3980 unsigned long i
= SCM_VECTOR_LENGTH (obj
);
3981 ans
= scm_c_make_vector (i
, SCM_UNSPECIFIED
);
3983 SCM_VECTOR_SET (ans
, i
, scm_copy_tree (SCM_VELTS (obj
)[i
]));
3986 if (!SCM_CONSP (obj
))
3988 ans
= tl
= scm_cons_source (obj
,
3989 scm_copy_tree (SCM_CAR (obj
)),
3991 while (obj
= SCM_CDR (obj
), SCM_CONSP (obj
))
3993 SCM_SETCDR (tl
, scm_cons (scm_copy_tree (SCM_CAR (obj
)),
3997 SCM_SETCDR (tl
, obj
);
4003 /* We have three levels of EVAL here:
4005 - scm_i_eval (exp, env)
4007 evaluates EXP in environment ENV. ENV is a lexical environment
4008 structure as used by the actual tree code evaluator. When ENV is
4009 a top-level environment, then changes to the current module are
4010 tracked by updating ENV so that it continues to be in sync with
4013 - scm_primitive_eval (exp)
4015 evaluates EXP in the top-level environment as determined by the
4016 current module. This is done by constructing a suitable
4017 environment and calling scm_i_eval. Thus, changes to the
4018 top-level module are tracked normally.
4020 - scm_eval (exp, mod)
4022 evaluates EXP while MOD is the current module. This is done by
4023 setting the current module to MOD, invoking scm_primitive_eval on
4024 EXP, and then restoring the current module to the value it had
4025 previously. That is, while EXP is evaluated, changes to the
4026 current module are tracked, but these changes do not persist when
4029 For each level of evals, there are two variants, distinguished by a
4030 _x suffix: the ordinary variant does not modify EXP while the _x
4031 variant can destructively modify EXP into something completely
4032 unintelligible. A Scheme data structure passed as EXP to one of the
4033 _x variants should not ever be used again for anything. So when in
4034 doubt, use the ordinary variant.
4039 scm_i_eval_x (SCM exp
, SCM env
)
4041 return SCM_XEVAL (exp
, env
);
4045 scm_i_eval (SCM exp
, SCM env
)
4047 exp
= scm_copy_tree (exp
);
4048 return SCM_XEVAL (exp
, env
);
4052 scm_primitive_eval_x (SCM exp
)
4055 SCM transformer
= scm_current_module_transformer ();
4056 if (SCM_NIMP (transformer
))
4057 exp
= scm_call_1 (transformer
, exp
);
4058 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4059 return scm_i_eval_x (exp
, env
);
4062 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
4064 "Evaluate @var{exp} in the top-level environment specified by\n"
4065 "the current module.")
4066 #define FUNC_NAME s_scm_primitive_eval
4069 SCM transformer
= scm_current_module_transformer ();
4070 if (SCM_NIMP (transformer
))
4071 exp
= scm_call_1 (transformer
, exp
);
4072 env
= scm_top_level_env (scm_current_module_lookup_closure ());
4073 return scm_i_eval (exp
, env
);
4077 /* Eval does not take the second arg optionally. This is intentional
4078 * in order to be R5RS compatible, and to prepare for the new module
4079 * system, where we would like to make the choice of evaluation
4080 * environment explicit. */
4083 change_environment (void *data
)
4085 SCM pair
= SCM_PACK (data
);
4086 SCM new_module
= SCM_CAR (pair
);
4087 SCM old_module
= scm_current_module ();
4088 SCM_SETCDR (pair
, old_module
);
4089 scm_set_current_module (new_module
);
4094 restore_environment (void *data
)
4096 SCM pair
= SCM_PACK (data
);
4097 SCM old_module
= SCM_CDR (pair
);
4098 SCM new_module
= scm_current_module ();
4099 SCM_SETCAR (pair
, new_module
);
4100 scm_set_current_module (old_module
);
4104 inner_eval_x (void *data
)
4106 return scm_primitive_eval_x (SCM_PACK(data
));
4110 scm_eval_x (SCM exp
, SCM module
)
4111 #define FUNC_NAME "eval!"
4113 SCM_VALIDATE_MODULE (2, module
);
4115 return scm_internal_dynamic_wind
4116 (change_environment
, inner_eval_x
, restore_environment
,
4117 (void *) SCM_UNPACK (exp
),
4118 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4123 inner_eval (void *data
)
4125 return scm_primitive_eval (SCM_PACK(data
));
4128 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
4129 (SCM exp
, SCM module
),
4130 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
4131 "in the top-level environment specified by @var{module}.\n"
4132 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
4133 "@var{module} is made the current module. The current module\n"
4134 "is reset to its previous value when @var{eval} returns.")
4135 #define FUNC_NAME s_scm_eval
4137 SCM_VALIDATE_MODULE (2, module
);
4139 return scm_internal_dynamic_wind
4140 (change_environment
, inner_eval
, restore_environment
,
4141 (void *) SCM_UNPACK (exp
),
4142 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
4147 /* At this point, scm_deval and scm_dapply are generated.
4150 #ifdef DEBUG_EXTENSIONS
4160 scm_init_opts (scm_evaluator_traps
,
4161 scm_evaluator_trap_table
,
4162 SCM_N_EVALUATOR_TRAPS
);
4163 scm_init_opts (scm_eval_options_interface
,
4165 SCM_N_EVAL_OPTIONS
);
4167 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
4168 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
4169 scm_set_smob_print (scm_tc16_promise
, promise_print
);
4171 /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */
4172 scm_undefineds
= scm_list_1 (SCM_UNDEFINED
);
4173 SCM_SETCDR (scm_undefineds
, scm_undefineds
);
4174 scm_listofnull
= scm_list_1 (SCM_EOL
);
4176 scm_f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
4181 #include "libguile/eval.x"
4183 scm_add_feature ("delay");