1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004
2 * Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2.1 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 /* This file is read twice in order to produce debugging versions of ceval and
22 * scm_apply. These functions, deval and scm_dapply, are produced when we
23 * define the preprocessor macro DEVAL. The file is divided into sections
24 * which are treated differently with respect to DEVAL. The heads of these
25 * sections are marked with the string "SECTION:". */
27 /* SECTION: This code is compiled once.
34 #include "libguile/__scm.h"
38 /* AIX requires this to be the first thing in the file. The #pragma
39 directive is indented so pre-ANSI compilers will ignore it, rather
48 # ifndef alloca /* predefined by HP cc +Olibcalls */
55 #include "libguile/_scm.h"
56 #include "libguile/alist.h"
57 #include "libguile/async.h"
58 #include "libguile/continuations.h"
59 #include "libguile/debug.h"
60 #include "libguile/deprecation.h"
61 #include "libguile/dynwind.h"
62 #include "libguile/eq.h"
63 #include "libguile/feature.h"
64 #include "libguile/fluids.h"
65 #include "libguile/futures.h"
66 #include "libguile/goops.h"
67 #include "libguile/hash.h"
68 #include "libguile/hashtab.h"
69 #include "libguile/lang.h"
70 #include "libguile/list.h"
71 #include "libguile/macros.h"
72 #include "libguile/modules.h"
73 #include "libguile/objects.h"
74 #include "libguile/ports.h"
75 #include "libguile/print.h"
76 #include "libguile/procprop.h"
77 #include "libguile/root.h"
78 #include "libguile/smob.h"
79 #include "libguile/srcprop.h"
80 #include "libguile/stackchk.h"
81 #include "libguile/strings.h"
82 #include "libguile/throw.h"
83 #include "libguile/validate.h"
84 #include "libguile/values.h"
85 #include "libguile/vectors.h"
87 #include "libguile/eval.h"
91 static SCM
canonicalize_define (SCM expr
);
97 * This section defines the message strings for the syntax errors that can be
98 * detected during memoization and the functions and macros that shall be
99 * called by the memoizer code to signal syntax errors. */
102 /* Syntax errors that can be detected during memoization: */
104 /* Circular or improper lists do not form valid scheme expressions. If a
105 * circular list or an improper list is detected in a place where a scheme
106 * expression is expected, a 'Bad expression' error is signalled. */
107 static const char s_bad_expression
[] = "Bad expression";
109 /* If a form is detected that holds a different number of expressions than are
110 * required in that context, a 'Missing or extra expression' error is
112 static const char s_expression
[] = "Missing or extra expression in";
114 /* If a form is detected that holds less expressions than are required in that
115 * context, a 'Missing expression' error is signalled. */
116 static const char s_missing_expression
[] = "Missing expression in";
118 /* If a form is detected that holds more expressions than are allowed in that
119 * context, an 'Extra expression' error is signalled. */
120 static const char s_extra_expression
[] = "Extra expression in";
122 /* The empty combination '()' is not allowed as an expression in scheme. If
123 * it is detected in a place where an expression is expected, an 'Illegal
124 * empty combination' error is signalled. Note: If you encounter this error
125 * message, it is very likely that you intended to denote the empty list. To
126 * do so, you need to quote the empty list like (quote ()) or '(). */
127 static const char s_empty_combination
[] = "Illegal empty combination";
129 /* A body may hold an arbitrary number of internal defines, followed by a
130 * non-empty sequence of expressions. If a body with an empty sequence of
131 * expressions is detected, a 'Missing body expression' error is signalled.
133 static const char s_missing_body_expression
[] = "Missing body expression in";
135 /* A body may hold an arbitrary number of internal defines, followed by a
136 * non-empty sequence of expressions. Each the definitions and the
137 * expressions may be grouped arbitraryly with begin, but it is not allowed to
138 * mix definitions and expressions. If a define form in a body mixes
139 * definitions and expressions, a 'Mixed definitions and expressions' error is
141 static const char s_mixed_body_forms
[] = "Mixed definitions and expressions in";
142 /* Definitions are only allowed on the top level and at the start of a body.
143 * If a definition is detected anywhere else, a 'Bad define placement' error
145 static const char s_bad_define
[] = "Bad define placement";
147 /* Case or cond expressions must have at least one clause. If a case or cond
148 * expression without any clauses is detected, a 'Missing clauses' error is
150 static const char s_missing_clauses
[] = "Missing clauses";
152 /* If there is an 'else' clause in a case or a cond statement, it must be the
153 * last clause. If after the 'else' case clause further clauses are detected,
154 * a 'Misplaced else clause' error is signalled. */
155 static const char s_misplaced_else_clause
[] = "Misplaced else clause";
157 /* If a case clause is detected that is not in the format
158 * (<label(s)> <expression1> <expression2> ...)
159 * a 'Bad case clause' error is signalled. */
160 static const char s_bad_case_clause
[] = "Bad case clause";
162 /* If a case clause is detected where the <label(s)> element is neither a
163 * proper list nor (in case of the last clause) the syntactic keyword 'else',
164 * a 'Bad case labels' error is signalled. Note: If you encounter this error
165 * for an else-clause which seems to be syntactically correct, check if 'else'
166 * is really a syntactic keyword in that context. If 'else' is bound in the
167 * local or global environment, it is not considered a syntactic keyword, but
168 * will be treated as any other variable. */
169 static const char s_bad_case_labels
[] = "Bad case labels";
171 /* In a case statement all labels have to be distinct. If in a case statement
172 * a label occurs more than once, a 'Duplicate case label' error is
174 static const char s_duplicate_case_label
[] = "Duplicate case label";
176 /* If a cond clause is detected that is not in one of the formats
177 * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
178 * a 'Bad cond clause' error is signalled. */
179 static const char s_bad_cond_clause
[] = "Bad cond clause";
181 /* If a cond clause is detected that uses the alternate '=>' form, but does
182 * not hold a recipient element for the test result, a 'Missing recipient'
183 * error is signalled. */
184 static const char s_missing_recipient
[] = "Missing recipient in";
186 /* If in a position where a variable name is required some other object is
187 * detected, a 'Bad variable' error is signalled. */
188 static const char s_bad_variable
[] = "Bad variable";
190 /* Bindings for forms like 'let' and 'do' have to be given in a proper,
191 * possibly empty list. If any other object is detected in a place where a
192 * list of bindings was required, a 'Bad bindings' error is signalled. */
193 static const char s_bad_bindings
[] = "Bad bindings";
195 /* Depending on the syntactic context, a binding has to be in the format
196 * (<variable> <expression>) or (<variable> <expression1> <expression2>).
197 * If anything else is detected in a place where a binding was expected, a
198 * 'Bad binding' error is signalled. */
199 static const char s_bad_binding
[] = "Bad binding";
201 /* Some syntactic forms don't allow variable names to appear more than once in
202 * a list of bindings. If such a situation is nevertheless detected, a
203 * 'Duplicate binding' error is signalled. */
204 static const char s_duplicate_binding
[] = "Duplicate binding";
206 /* If the exit form of a 'do' expression is not in the format
207 * (<test> <expression> ...)
208 * a 'Bad exit clause' error is signalled. */
209 static const char s_bad_exit_clause
[] = "Bad exit clause";
211 /* The formal function arguments of a lambda expression have to be either a
212 * single symbol or a non-cyclic list. For anything else a 'Bad formals'
213 * error is signalled. */
214 static const char s_bad_formals
[] = "Bad formals";
216 /* If in a lambda expression something else than a symbol is detected at a
217 * place where a formal function argument is required, a 'Bad formal' error is
219 static const char s_bad_formal
[] = "Bad formal";
221 /* If in the arguments list of a lambda expression an argument name occurs
222 * more than once, a 'Duplicate formal' error is signalled. */
223 static const char s_duplicate_formal
[] = "Duplicate formal";
225 /* If the evaluation of an unquote-splicing expression gives something else
226 * than a proper list, a 'Non-list result for unquote-splicing' error is
228 static const char s_splicing
[] = "Non-list result for unquote-splicing";
230 /* If something else than an exact integer is detected as the argument for
231 * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
232 static const char s_bad_slot_number
[] = "Bad slot number";
235 /* Signal a syntax error. We distinguish between the form that caused the
236 * error and the enclosing expression. The error message will print out as
237 * shown in the following pattern. The file name and line number are only
238 * given when they can be determined from the erroneous form or from the
239 * enclosing expression.
241 * <filename>: In procedure memoization:
242 * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
244 SCM_SYMBOL (syntax_error_key
, "syntax-error");
246 /* The prototype is needed to indicate that the function does not return. */
248 syntax_error (const char* const, const SCM
, const SCM
) SCM_NORETURN
;
251 syntax_error (const char* const msg
, const SCM form
, const SCM expr
)
253 const SCM msg_string
= scm_makfrom0str (msg
);
254 SCM filename
= SCM_BOOL_F
;
255 SCM linenr
= SCM_BOOL_F
;
259 if (SCM_CONSP (form
))
261 filename
= scm_source_property (form
, scm_sym_filename
);
262 linenr
= scm_source_property (form
, scm_sym_line
);
265 if (SCM_FALSEP (filename
) && SCM_FALSEP (linenr
) && SCM_CONSP (expr
))
267 filename
= scm_source_property (expr
, scm_sym_filename
);
268 linenr
= scm_source_property (expr
, scm_sym_line
);
271 if (!SCM_UNBNDP (expr
))
273 if (!SCM_FALSEP (filename
))
275 format
= "In file ~S, line ~S: ~A ~S in expression ~S.";
276 args
= scm_list_5 (filename
, linenr
, msg_string
, form
, expr
);
278 else if (!SCM_FALSEP (linenr
))
280 format
= "In line ~S: ~A ~S in expression ~S.";
281 args
= scm_list_4 (linenr
, msg_string
, form
, expr
);
285 format
= "~A ~S in expression ~S.";
286 args
= scm_list_3 (msg_string
, form
, expr
);
291 if (!SCM_FALSEP (filename
))
293 format
= "In file ~S, line ~S: ~A ~S.";
294 args
= scm_list_4 (filename
, linenr
, msg_string
, form
);
296 else if (!SCM_FALSEP (linenr
))
298 format
= "In line ~S: ~A ~S.";
299 args
= scm_list_3 (linenr
, msg_string
, form
);
304 args
= scm_list_2 (msg_string
, form
);
308 scm_error (syntax_error_key
, "memoization", format
, args
, SCM_BOOL_F
);
312 /* Shortcut macros to simplify syntax error handling. */
313 #define ASSERT_SYNTAX(cond, message, form) \
314 { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); }
315 #define ASSERT_SYNTAX_2(cond, message, form, expr) \
316 { if (!(cond)) syntax_error (message, form, expr); }
322 * Ilocs are memoized references to variables in local environment frames.
323 * They are represented as three values: The relative offset of the
324 * environment frame, the number of the binding within that frame, and a
325 * boolean value indicating whether the binding is the last binding in the
329 #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
330 #define SCM_IFRINC (0x00000100L)
331 #define SCM_ICDR (0x00080000L)
332 #define SCM_IDINC (0x00100000L)
333 #define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
334 & (SCM_UNPACK (n) >> 8))
335 #define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
336 #define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
337 #define SCM_IDSTMSK (-SCM_IDINC)
338 #define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
341 + ((binding_nr) << 20) \
342 + ((last_p) ? SCM_ICDR : 0) \
346 scm_i_print_iloc (SCM iloc
, SCM port
)
348 scm_puts ("#@", port
);
349 scm_intprint ((long) SCM_IFRAME (iloc
), 10, port
);
350 scm_putc (SCM_ICDRP (iloc
) ? '-' : '+', port
);
351 scm_intprint ((long) SCM_IDIST (iloc
), 10, port
);
354 #if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
356 SCM
scm_dbg_make_iloc (SCM frame
, SCM binding
, SCM cdrp
);
357 SCM_DEFINE (scm_dbg_make_iloc
, "dbg-make-iloc", 3, 0, 0,
358 (SCM frame
, SCM binding
, SCM cdrp
),
359 "Return a new iloc with frame offset @var{frame}, binding\n"
360 "offset @var{binding} and the cdr flag @var{cdrp}.")
361 #define FUNC_NAME s_scm_dbg_make_iloc
363 SCM_VALIDATE_INUM (1, frame
);
364 SCM_VALIDATE_INUM (2, binding
);
365 return SCM_MAKE_ILOC (SCM_INUM (frame
),
371 SCM
scm_dbg_iloc_p (SCM obj
);
372 SCM_DEFINE (scm_dbg_iloc_p
, "dbg-iloc?", 1, 0, 0,
374 "Return @code{#t} if @var{obj} is an iloc.")
375 #define FUNC_NAME s_scm_dbg_iloc_p
377 return SCM_BOOL (SCM_ILOCP (obj
));
385 /* {Evaluator byte codes (isyms)}
388 #define ISYMNUM(n) (SCM_ITAG8_DATA (n))
390 /* This table must agree with the list of SCM_IM_ constants in tags.h */
391 static const char *const isymnames
[] =
408 "#@call-with-current-continuation",
414 "#@call-with-values",
422 scm_i_print_isym (SCM isym
, SCM port
)
424 const size_t isymnum
= ISYMNUM (isym
);
425 if (isymnum
< (sizeof isymnames
/ sizeof (char *)))
426 scm_puts (isymnames
[isymnum
], port
);
428 scm_ipruk ("isym", isym
, port
);
433 /* The function lookup_symbol is used during memoization: Lookup the symbol
434 * in the environment. If there is no binding for the symbol, SCM_UNDEFINED
435 * is returned. If the symbol is a syntactic keyword, the macro object to
436 * which the symbol is bound is returned. If the symbol is a global variable,
437 * the variable object to which the symbol is bound is returned. Finally, if
438 * the symbol is a local variable the corresponding iloc object is returned.
441 /* A helper function for lookup_symbol: Try to find the symbol in the top
442 * level environment frame. The function returns SCM_UNDEFINED if the symbol
443 * is unbound, it returns a macro object if the symbol is a syntactic keyword
444 * and it returns a variable object if the symbol is a global variable. */
446 lookup_global_symbol (const SCM symbol
, const SCM top_level
)
448 const SCM variable
= scm_sym2var (symbol
, top_level
, SCM_BOOL_F
);
449 if (SCM_FALSEP (variable
))
451 return SCM_UNDEFINED
;
455 const SCM value
= SCM_VARIABLE_REF (variable
);
456 if (SCM_MACROP (value
))
464 lookup_symbol (const SCM symbol
, const SCM env
)
467 unsigned int frame_nr
;
469 for (frame_idx
= env
, frame_nr
= 0;
470 !SCM_NULLP (frame_idx
);
471 frame_idx
= SCM_CDR (frame_idx
), ++frame_nr
)
473 const SCM frame
= SCM_CAR (frame_idx
);
474 if (SCM_CONSP (frame
))
476 /* frame holds a local environment frame */
478 unsigned int symbol_nr
;
480 for (symbol_idx
= SCM_CAR (frame
), symbol_nr
= 0;
481 SCM_CONSP (symbol_idx
);
482 symbol_idx
= SCM_CDR (symbol_idx
), ++symbol_nr
)
484 if (SCM_EQ_P (SCM_CAR (symbol_idx
), symbol
))
485 /* found the symbol, therefore return the iloc */
486 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 0);
488 if (SCM_EQ_P (symbol_idx
, symbol
))
489 /* found the symbol as the last element of the current frame */
490 return SCM_MAKE_ILOC (frame_nr
, symbol_nr
, 1);
494 /* no more local environment frames */
495 return lookup_global_symbol (symbol
, frame
);
499 return lookup_global_symbol (symbol
, SCM_BOOL_F
);
503 /* Return true if the symbol is - from the point of view of a macro
504 * transformer - a literal in the sense specified in chapter "pattern
505 * language" of R5RS. In the code below, however, we don't match the
506 * definition of R5RS exactly: It returns true if the identifier has no
507 * binding or if it is a syntactic keyword. */
509 literal_p (const SCM symbol
, const SCM env
)
511 const SCM value
= lookup_symbol (symbol
, env
);
512 if (SCM_UNBNDP (value
) || SCM_MACROP (value
))
519 /* Return true if the expression is self-quoting in the memoized code. Thus,
520 * some other objects (like e. g. vectors) are reported as self-quoting, which
521 * according to R5RS would need to be quoted. */
523 is_self_quoting_p (const SCM expr
)
525 if (SCM_CONSP (expr
))
527 else if (SCM_SYMBOLP (expr
))
529 else if (SCM_NULLP (expr
))
536 /* Lookup a given local variable in an environment. The local variable is
537 * given as an iloc, that is a triple <frame, binding, last?>, where frame
538 * indicates the relative number of the environment frame (counting upwards
539 * from the innermost environment frame), binding indicates the number of the
540 * binding within the frame, and last? (which is extracted from the iloc using
541 * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
542 * very end of the improper list of bindings. */
544 scm_ilookup (SCM iloc
, SCM env
)
546 unsigned int frame_nr
= SCM_IFRAME (iloc
);
547 unsigned int binding_nr
= SCM_IDIST (iloc
);
551 for (; 0 != frame_nr
; --frame_nr
)
552 frames
= SCM_CDR (frames
);
554 bindings
= SCM_CAR (frames
);
555 for (; 0 != binding_nr
; --binding_nr
)
556 bindings
= SCM_CDR (bindings
);
558 if (SCM_ICDRP (iloc
))
559 return SCM_CDRLOC (bindings
);
560 return SCM_CARLOC (SCM_CDR (bindings
));
564 SCM_SYMBOL (scm_unbound_variable_key
, "unbound-variable");
566 static void error_unbound_variable (SCM symbol
) SCM_NORETURN
;
568 error_unbound_variable (SCM symbol
)
570 scm_error (scm_unbound_variable_key
, NULL
,
571 "Unbound variable: ~S",
572 scm_list_1 (symbol
), SCM_BOOL_F
);
576 /* The Lookup Car Race
579 Memoization of variables and special forms is done while executing
580 the code for the first time. As long as there is only one thread
581 everything is fine, but as soon as two threads execute the same
582 code concurrently `for the first time' they can come into conflict.
584 This memoization includes rewriting variable references into more
585 efficient forms and expanding macros. Furthermore, macro expansion
586 includes `compiling' special forms like `let', `cond', etc. into
587 tree-code instructions.
589 There shouldn't normally be a problem with memoizing local and
590 global variable references (into ilocs and variables), because all
591 threads will mutate the code in *exactly* the same way and (if I
592 read the C code correctly) it is not possible to observe a half-way
593 mutated cons cell. The lookup procedure can handle this
594 transparently without any critical sections.
596 It is different with macro expansion, because macro expansion
597 happens outside of the lookup procedure and can't be
598 undone. Therefore the lookup procedure can't cope with it. It has
599 to indicate failure when it detects a lost race and hope that the
600 caller can handle it. Luckily, it turns out that this is the case.
602 An example to illustrate this: Suppose that the following form will
603 be memoized concurrently by two threads
607 Let's first examine the lookup of X in the body. The first thread
608 decides that it has to find the symbol "x" in the environment and
609 starts to scan it. Then the other thread takes over and actually
610 overtakes the first. It looks up "x" and substitutes an
611 appropriate iloc for it. Now the first thread continues and
612 completes its lookup. It comes to exactly the same conclusions as
613 the second one and could - without much ado - just overwrite the
614 iloc with the same iloc.
616 But let's see what will happen when the race occurs while looking
617 up the symbol "let" at the start of the form. It could happen that
618 the second thread interrupts the lookup of the first thread and not
619 only substitutes a variable for it but goes right ahead and
620 replaces it with the compiled form (#@let* (x 12) x). Now, when
621 the first thread completes its lookup, it would replace the #@let*
622 with a variable containing the "let" binding, effectively reverting
623 the form to (let (x 12) x). This is wrong. It has to detect that
624 it has lost the race and the evaluator has to reconsider the
625 changed form completely.
627 This race condition could be resolved with some kind of traffic
628 light (like mutexes) around scm_lookupcar, but I think that it is
629 best to avoid them in this case. They would serialize memoization
630 completely and because lookup involves calling arbitrary Scheme
631 code (via the lookup-thunk), threads could be blocked for an
632 arbitrary amount of time or even deadlock. But with the current
633 solution a lot of unnecessary work is potentially done. */
635 /* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
636 return NULL to indicate a failed lookup due to some race conditions
637 between threads. This only happens when VLOC is the first cell of
638 a special form that will eventually be memoized (like `let', etc.)
639 In that case the whole lookup is bogus and the caller has to
640 reconsider the complete special form.
642 SCM_LOOKUPCAR is still there, of course. It just calls
643 SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
644 should only be called when it is known that VLOC is not the first
645 pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
646 for NULL. I think I've found the only places where this
650 scm_lookupcar1 (SCM vloc
, SCM genv
, int check
)
653 register SCM
*al
, fl
, var
= SCM_CAR (vloc
);
654 register SCM iloc
= SCM_ILOC00
;
655 for (; SCM_NIMP (env
); env
= SCM_CDR (env
))
657 if (!SCM_CONSP (SCM_CAR (env
)))
659 al
= SCM_CARLOC (env
);
660 for (fl
= SCM_CAR (*al
); SCM_NIMP (fl
); fl
= SCM_CDR (fl
))
664 if (SCM_EQ_P (fl
, var
))
666 if (! SCM_EQ_P (SCM_CAR (vloc
), var
))
668 SCM_SET_CELL_WORD_0 (vloc
, SCM_UNPACK (iloc
) + SCM_ICDR
);
669 return SCM_CDRLOC (*al
);
674 al
= SCM_CDRLOC (*al
);
675 if (SCM_EQ_P (SCM_CAR (fl
), var
))
677 if (SCM_UNBNDP (SCM_CAR (*al
)))
682 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
684 SCM_SETCAR (vloc
, iloc
);
685 return SCM_CARLOC (*al
);
687 iloc
= SCM_PACK (SCM_UNPACK (iloc
) + SCM_IDINC
);
689 iloc
= SCM_PACK ((~SCM_IDSTMSK
) & (SCM_UNPACK(iloc
) + SCM_IFRINC
));
692 SCM top_thunk
, real_var
;
695 top_thunk
= SCM_CAR (env
); /* env now refers to a
696 top level env thunk */
700 top_thunk
= SCM_BOOL_F
;
701 real_var
= scm_sym2var (var
, top_thunk
, SCM_BOOL_F
);
702 if (SCM_FALSEP (real_var
))
705 if (!SCM_NULLP (env
) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var
)))
711 error_unbound_variable (var
);
713 scm_misc_error (NULL
, "Damaged environment: ~S",
718 /* A variable could not be found, but we shall
719 not throw an error. */
720 static SCM undef_object
= SCM_UNDEFINED
;
721 return &undef_object
;
725 if (!SCM_EQ_P (SCM_CAR (vloc
), var
))
727 /* Some other thread has changed the very cell we are working
728 on. In effect, it must have done our job or messed it up
731 var
= SCM_CAR (vloc
);
732 if (SCM_VARIABLEP (var
))
733 return SCM_VARIABLE_LOC (var
);
735 return scm_ilookup (var
, genv
);
736 /* We can't cope with anything else than variables and ilocs. When
737 a special form has been memoized (i.e. `let' into `#@let') we
738 return NULL and expect the calling function to do the right
739 thing. For the evaluator, this means going back and redoing
740 the dispatch on the car of the form. */
744 SCM_SETCAR (vloc
, real_var
);
745 return SCM_VARIABLE_LOC (real_var
);
750 scm_lookupcar (SCM vloc
, SCM genv
, int check
)
752 SCM
*loc
= scm_lookupcar1 (vloc
, genv
, check
);
760 /* Rewrite the body (which is given as the list of expressions forming the
761 * body) into its internal form. The internal form of a body (<expr> ...) is
762 * just the body itself, but prefixed with an ISYM that denotes to what kind
763 * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
764 * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
767 * It is assumed that the calling expression has already made sure that the
768 * body is a proper list. */
770 m_body (SCM op
, SCM exprs
)
772 /* Don't add another ISYM if one is present already. */
773 if (SCM_ISYMP (SCM_CAR (exprs
)))
776 return scm_cons (op
, exprs
);
780 /* The function m_expand_body memoizes a proper list of expressions
781 * forming a body. This function takes care of dealing with internal
782 * defines and transforming them into an equivalent letrec expression.
783 * The list of expressions is rewritten in place. */
785 /* This is a helper function for m_expand_body. It helps to figure out whether
786 * an expression denotes a syntactic keyword. */
788 try_macro_lookup (const SCM expr
, const SCM env
)
790 if (SCM_SYMBOLP (expr
))
792 const SCM value
= lookup_symbol (expr
, env
);
797 return SCM_UNDEFINED
;
801 /* This is a helper function for m_expand_body. It expands user macros,
802 * because for the correct translation of a body we need to know whether they
803 * expand to a definition. */
805 expand_user_macros (SCM expr
, const SCM env
)
807 while (SCM_CONSP (expr
))
809 const SCM car_expr
= SCM_CAR (expr
);
810 const SCM new_car
= expand_user_macros (car_expr
, env
);
811 const SCM value
= try_macro_lookup (new_car
, env
);
813 if (SCM_MACROP (value
) && SCM_MACRO_TYPE (value
) == 2)
815 /* User macros transform code into code. */
816 expr
= scm_call_2 (SCM_MACRO_CODE (value
), expr
, env
);
817 /* We need to reiterate on the transformed code. */
821 /* No user macro: return. */
822 SCM_SETCAR (expr
, new_car
);
830 /* This is a helper function for m_expand_body. It determines if a given form
831 * represents an application of a given built-in macro. The built-in macro to
832 * check for is identified by its syntactic keyword. The form is an
833 * application of the given macro if looking up the car of the form in the
834 * given environment actually returns the built-in macro. */
836 is_system_macro_p (const SCM syntactic_keyword
, const SCM form
, const SCM env
)
838 if (SCM_CONSP (form
))
840 const SCM car_form
= SCM_CAR (form
);
841 const SCM value
= try_macro_lookup (car_form
, env
);
842 if (SCM_BUILTIN_MACRO_P (value
))
844 const SCM macro_name
= scm_macro_name (value
);
845 return SCM_EQ_P (macro_name
, syntactic_keyword
);
853 m_expand_body (const SCM forms
, const SCM env
)
855 /* The first body form can be skipped since it is known to be the ISYM that
856 * was prepended to the body by m_body. */
857 SCM cdr_forms
= SCM_CDR (forms
);
858 SCM form_idx
= cdr_forms
;
859 SCM definitions
= SCM_EOL
;
860 SCM sequence
= SCM_EOL
;
862 /* According to R5RS, the list of body forms consists of two parts: a number
863 * (maybe zero) of definitions, followed by a non-empty sequence of
864 * expressions. Each the definitions and the expressions may be grouped
865 * arbitrarily with begin, but it is not allowed to mix definitions and
866 * expressions. The task of the following loop therefore is to split the
867 * list of body forms into the list of definitions and the sequence of
869 while (!SCM_NULLP (form_idx
))
871 const SCM form
= SCM_CAR (form_idx
);
872 const SCM new_form
= expand_user_macros (form
, env
);
873 if (is_system_macro_p (scm_sym_define
, new_form
, env
))
875 definitions
= scm_cons (new_form
, definitions
);
876 form_idx
= SCM_CDR (form_idx
);
878 else if (is_system_macro_p (scm_sym_begin
, new_form
, env
))
880 /* We have encountered a group of forms. This has to be either a
881 * (possibly empty) group of (possibly further grouped) definitions,
882 * or a non-empty group of (possibly further grouped)
884 const SCM grouped_forms
= SCM_CDR (new_form
);
885 unsigned int found_definition
= 0;
886 unsigned int found_expression
= 0;
887 SCM grouped_form_idx
= grouped_forms
;
888 while (!found_expression
&& !SCM_NULLP (grouped_form_idx
))
890 const SCM inner_form
= SCM_CAR (grouped_form_idx
);
891 const SCM new_inner_form
= expand_user_macros (inner_form
, env
);
892 if (is_system_macro_p (scm_sym_define
, new_inner_form
, env
))
894 found_definition
= 1;
895 definitions
= scm_cons (new_inner_form
, definitions
);
896 grouped_form_idx
= SCM_CDR (grouped_form_idx
);
898 else if (is_system_macro_p (scm_sym_begin
, new_inner_form
, env
))
900 const SCM inner_group
= SCM_CDR (new_inner_form
);
902 = scm_append (scm_list_2 (inner_group
,
903 SCM_CDR (grouped_form_idx
)));
907 /* The group marks the start of the expressions of the body.
908 * We have to make sure that within the same group we have
909 * not encountered a definition before. */
910 ASSERT_SYNTAX (!found_definition
, s_mixed_body_forms
, form
);
911 found_expression
= 1;
912 grouped_form_idx
= SCM_EOL
;
916 /* We have finished processing the group. If we have not yet
917 * encountered an expression we continue processing the forms of the
918 * body to collect further definition forms. Otherwise, the group
919 * marks the start of the sequence of expressions of the body. */
920 if (!found_expression
)
922 form_idx
= SCM_CDR (form_idx
);
932 /* We have detected a form which is no definition. This marks the
933 * start of the sequence of expressions of the body. */
939 /* FIXME: forms does not hold information about the file location. */
940 ASSERT_SYNTAX (SCM_CONSP (sequence
), s_missing_body_expression
, cdr_forms
);
942 if (!SCM_NULLP (definitions
))
946 SCM letrec_expression
;
947 SCM new_letrec_expression
;
949 SCM bindings
= SCM_EOL
;
950 for (definition_idx
= definitions
;
951 !SCM_NULLP (definition_idx
);
952 definition_idx
= SCM_CDR (definition_idx
))
954 const SCM definition
= SCM_CAR (definition_idx
);
955 const SCM canonical_definition
= canonicalize_define (definition
);
956 const SCM binding
= SCM_CDR (canonical_definition
);
957 bindings
= scm_cons (binding
, bindings
);
960 letrec_tail
= scm_cons (bindings
, sequence
);
961 /* FIXME: forms does not hold information about the file location. */
962 letrec_expression
= scm_cons_source (forms
, scm_sym_letrec
, letrec_tail
);
963 new_letrec_expression
= scm_m_letrec (letrec_expression
, env
);
964 SCM_SETCAR (forms
, new_letrec_expression
);
965 SCM_SETCDR (forms
, SCM_EOL
);
969 SCM_SETCAR (forms
, SCM_CAR (sequence
));
970 SCM_SETCDR (forms
, SCM_CDR (sequence
));
975 /* Start of the memoizers for the standard R5RS builtin macros. */
978 SCM_SYNTAX (s_and
, "and", scm_i_makbimacro
, scm_m_and
);
979 SCM_GLOBAL_SYMBOL (scm_sym_and
, s_and
);
982 scm_m_and (SCM expr
, SCM env SCM_UNUSED
)
984 const SCM cdr_expr
= SCM_CDR (expr
);
985 const long length
= scm_ilength (cdr_expr
);
987 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
991 /* Special case: (and) is replaced by #t. */
996 SCM_SETCAR (expr
, SCM_IM_AND
);
1002 SCM_SYNTAX (s_begin
, "begin", scm_i_makbimacro
, scm_m_begin
);
1003 SCM_GLOBAL_SYMBOL (scm_sym_begin
, s_begin
);
1006 scm_m_begin (SCM expr
, SCM env SCM_UNUSED
)
1008 const SCM cdr_expr
= SCM_CDR (expr
);
1009 /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
1010 * That means, there should be a distinction between uses of begin where an
1011 * empty clause is OK and where it is not. */
1012 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1014 SCM_SETCAR (expr
, SCM_IM_BEGIN
);
1019 SCM_SYNTAX (s_case
, "case", scm_i_makbimacro
, scm_m_case
);
1020 SCM_GLOBAL_SYMBOL (scm_sym_case
, s_case
);
1021 SCM_GLOBAL_SYMBOL (scm_sym_else
, "else");
1024 scm_m_case (SCM expr
, SCM env
)
1027 SCM all_labels
= SCM_EOL
;
1029 /* Check, whether 'else is a literal, i. e. not bound to a value. */
1030 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1032 const SCM cdr_expr
= SCM_CDR (expr
);
1033 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1034 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_clauses
, expr
);
1036 clauses
= SCM_CDR (cdr_expr
);
1037 while (!SCM_NULLP (clauses
))
1041 const SCM clause
= SCM_CAR (clauses
);
1042 ASSERT_SYNTAX_2 (scm_ilength (clause
) >= 2,
1043 s_bad_case_clause
, clause
, expr
);
1045 labels
= SCM_CAR (clause
);
1046 if (SCM_CONSP (labels
))
1048 ASSERT_SYNTAX_2 (scm_ilength (labels
) >= 0,
1049 s_bad_case_labels
, labels
, expr
);
1050 all_labels
= scm_append_x (scm_list_2 (labels
, all_labels
));
1052 else if (SCM_NULLP (labels
))
1054 /* The list of labels is empty. According to R5RS this is allowed.
1055 * It means that the sequence of expressions will never be executed.
1056 * Therefore, as an optimization, we could remove the whole
1061 ASSERT_SYNTAX_2 (SCM_EQ_P (labels
, scm_sym_else
) && else_literal_p
,
1062 s_bad_case_labels
, labels
, expr
);
1063 ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses
)),
1064 s_misplaced_else_clause
, clause
, expr
);
1067 /* build the new clause */
1068 if (SCM_EQ_P (labels
, scm_sym_else
))
1069 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1071 clauses
= SCM_CDR (clauses
);
1074 /* Check whether all case labels are distinct. */
1075 for (; !SCM_NULLP (all_labels
); all_labels
= SCM_CDR (all_labels
))
1077 const SCM label
= SCM_CAR (all_labels
);
1078 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label
, SCM_CDR (all_labels
))),
1079 s_duplicate_case_label
, label
, expr
);
1082 SCM_SETCAR (expr
, SCM_IM_CASE
);
1087 SCM_SYNTAX (s_cond
, "cond", scm_i_makbimacro
, scm_m_cond
);
1088 SCM_GLOBAL_SYMBOL (scm_sym_cond
, s_cond
);
1089 SCM_GLOBAL_SYMBOL (scm_sym_arrow
, "=>");
1092 scm_m_cond (SCM expr
, SCM env
)
1094 /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
1095 const int else_literal_p
= literal_p (scm_sym_else
, env
);
1096 const int arrow_literal_p
= literal_p (scm_sym_arrow
, env
);
1098 const SCM clauses
= SCM_CDR (expr
);
1101 ASSERT_SYNTAX (scm_ilength (clauses
) >= 0, s_bad_expression
, expr
);
1102 ASSERT_SYNTAX (scm_ilength (clauses
) >= 1, s_missing_clauses
, expr
);
1104 for (clause_idx
= clauses
;
1105 !SCM_NULLP (clause_idx
);
1106 clause_idx
= SCM_CDR (clause_idx
))
1110 const SCM clause
= SCM_CAR (clause_idx
);
1111 const long length
= scm_ilength (clause
);
1112 ASSERT_SYNTAX_2 (length
>= 1, s_bad_cond_clause
, clause
, expr
);
1114 test
= SCM_CAR (clause
);
1115 if (SCM_EQ_P (test
, scm_sym_else
) && else_literal_p
)
1117 const int last_clause_p
= SCM_NULLP (SCM_CDR (clause_idx
));
1118 ASSERT_SYNTAX_2 (length
>= 2,
1119 s_bad_cond_clause
, clause
, expr
);
1120 ASSERT_SYNTAX_2 (last_clause_p
,
1121 s_misplaced_else_clause
, clause
, expr
);
1122 SCM_SETCAR (clause
, SCM_IM_ELSE
);
1124 else if (length
>= 2
1125 && SCM_EQ_P (SCM_CADR (clause
), scm_sym_arrow
)
1128 ASSERT_SYNTAX_2 (length
> 2, s_missing_recipient
, clause
, expr
);
1129 ASSERT_SYNTAX_2 (length
== 3, s_extra_expression
, clause
, expr
);
1130 SCM_SETCAR (SCM_CDR (clause
), SCM_IM_ARROW
);
1134 SCM_SETCAR (expr
, SCM_IM_COND
);
1139 SCM_SYNTAX (s_define
, "define", scm_i_makbimacro
, scm_m_define
);
1140 SCM_GLOBAL_SYMBOL (scm_sym_define
, s_define
);
1142 /* Guile provides an extension to R5RS' define syntax to represent function
1143 * currying in a compact way. With this extension, it is allowed to write
1144 * (define <nested-variable> <body>), where <nested-variable> has of one of
1145 * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
1146 * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
1147 * should be either a sequence of zero or more variables, or a sequence of one
1148 * or more variables followed by a space-delimited period and another
1149 * variable. Each level of argument nesting wraps the <body> within another
1150 * lambda expression. For example, the following forms are allowed, each one
1151 * followed by an equivalent, more explicit implementation.
1153 * (define ((a b . c) . d) <body>) is equivalent to
1154 * (define a (lambda (b . c) (lambda d <body>)))
1156 * (define (((a) b) c . d) <body>) is equivalent to
1157 * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
1159 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
1160 * module that does not implement this extension. */
1162 canonicalize_define (const SCM expr
)
1167 const SCM cdr_expr
= SCM_CDR (expr
);
1168 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1169 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1171 body
= SCM_CDR (cdr_expr
);
1172 variable
= SCM_CAR (cdr_expr
);
1173 while (SCM_CONSP (variable
))
1175 /* This while loop realizes function currying by variable nesting.
1176 * Variable is known to be a nested-variable. In every iteration of the
1177 * loop another level of lambda expression is created, starting with the
1178 * innermost one. Note that we don't check for duplicate formals here:
1179 * This will be done by the memoizer of the lambda expression. */
1180 const SCM formals
= SCM_CDR (variable
);
1181 const SCM tail
= scm_cons (formals
, body
);
1183 /* Add source properties to each new lambda expression: */
1184 const SCM lambda
= scm_cons_source (variable
, scm_sym_lambda
, tail
);
1186 body
= scm_list_1 (lambda
);
1187 variable
= SCM_CAR (variable
);
1189 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
1190 ASSERT_SYNTAX (scm_ilength (body
) == 1, s_expression
, expr
);
1192 SCM_SETCAR (cdr_expr
, variable
);
1193 SCM_SETCDR (cdr_expr
, body
);
1198 scm_m_define (SCM expr
, SCM env
)
1200 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), s_bad_define
, expr
);
1203 const SCM canonical_definition
= canonicalize_define (expr
);
1204 const SCM cdr_canonical_definition
= SCM_CDR (canonical_definition
);
1205 const SCM variable
= SCM_CAR (cdr_canonical_definition
);
1206 const SCM body
= SCM_CDR (cdr_canonical_definition
);
1207 const SCM value
= scm_eval_car (body
, env
);
1210 if (SCM_REC_PROCNAMES_P
)
1213 while (SCM_MACROP (tmp
))
1214 tmp
= SCM_MACRO_CODE (tmp
);
1215 if (SCM_CLOSUREP (tmp
)
1216 /* Only the first definition determines the name. */
1217 && SCM_FALSEP (scm_procedure_property (tmp
, scm_sym_name
)))
1218 scm_set_procedure_property_x (tmp
, scm_sym_name
, variable
);
1221 var
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_T
);
1222 SCM_VARIABLE_SET (var
, value
);
1224 return SCM_UNSPECIFIED
;
1229 /* This is a helper function for forms (<keyword> <expression>) that are
1230 * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
1231 * for easy creation of a thunk (i. e. a closure without arguments) using the
1232 * ('() <memoized_expression>) tail of the memoized form. */
1234 memoize_as_thunk_prototype (const SCM expr
, const SCM env SCM_UNUSED
)
1236 const SCM cdr_expr
= SCM_CDR (expr
);
1237 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1238 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1240 SCM_SETCDR (expr
, scm_cons (SCM_EOL
, cdr_expr
));
1246 SCM_SYNTAX (s_delay
, "delay", scm_i_makbimacro
, scm_m_delay
);
1247 SCM_GLOBAL_SYMBOL (scm_sym_delay
, s_delay
);
1249 /* Promises are implemented as closures with an empty parameter list. Thus,
1250 * (delay <expression>) is transformed into (#@delay '() <expression>), where
1251 * the empty list represents the empty parameter list. This representation
1252 * allows for easy creation of the closure during evaluation. */
1254 scm_m_delay (SCM expr
, SCM env
)
1256 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1257 SCM_SETCAR (new_expr
, SCM_IM_DELAY
);
1262 SCM_SYNTAX(s_do
, "do", scm_i_makbimacro
, scm_m_do
);
1263 SCM_GLOBAL_SYMBOL(scm_sym_do
, s_do
);
1265 /* DO gets the most radically altered syntax. The order of the vars is
1266 * reversed here. During the evaluation this allows for simple consing of the
1267 * results of the inits and steps:
1269 (do ((<var1> <init1> <step1>)
1277 (#@do (<init1> <init2> ... <initn>)
1278 (varn ... var2 var1)
1281 <step1> <step2> ... <stepn>) ;; missing steps replaced by var
1284 scm_m_do (SCM expr
, SCM env SCM_UNUSED
)
1286 SCM variables
= SCM_EOL
;
1287 SCM init_forms
= SCM_EOL
;
1288 SCM step_forms
= SCM_EOL
;
1295 const SCM cdr_expr
= SCM_CDR (expr
);
1296 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1297 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1299 /* Collect variables, init and step forms. */
1300 binding_idx
= SCM_CAR (cdr_expr
);
1301 ASSERT_SYNTAX_2 (scm_ilength (binding_idx
) >= 0,
1302 s_bad_bindings
, binding_idx
, expr
);
1303 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1305 const SCM binding
= SCM_CAR (binding_idx
);
1306 const long length
= scm_ilength (binding
);
1307 ASSERT_SYNTAX_2 (length
== 2 || length
== 3,
1308 s_bad_binding
, binding
, expr
);
1311 const SCM name
= SCM_CAR (binding
);
1312 const SCM init
= SCM_CADR (binding
);
1313 const SCM step
= (length
== 2) ? name
: SCM_CADDR (binding
);
1314 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1315 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, variables
)),
1316 s_duplicate_binding
, name
, expr
);
1318 variables
= scm_cons (name
, variables
);
1319 init_forms
= scm_cons (init
, init_forms
);
1320 step_forms
= scm_cons (step
, step_forms
);
1323 init_forms
= scm_reverse_x (init_forms
, SCM_UNDEFINED
);
1324 step_forms
= scm_reverse_x (step_forms
, SCM_UNDEFINED
);
1326 /* Memoize the test form and the exit sequence. */
1327 cddr_expr
= SCM_CDR (cdr_expr
);
1328 exit_clause
= SCM_CAR (cddr_expr
);
1329 ASSERT_SYNTAX_2 (scm_ilength (exit_clause
) >= 1,
1330 s_bad_exit_clause
, exit_clause
, expr
);
1332 commands
= SCM_CDR (cddr_expr
);
1333 tail
= scm_cons2 (exit_clause
, commands
, step_forms
);
1334 tail
= scm_cons2 (init_forms
, variables
, tail
);
1335 SCM_SETCAR (expr
, SCM_IM_DO
);
1336 SCM_SETCDR (expr
, tail
);
1341 SCM_SYNTAX (s_if
, "if", scm_i_makbimacro
, scm_m_if
);
1342 SCM_GLOBAL_SYMBOL (scm_sym_if
, s_if
);
1345 scm_m_if (SCM expr
, SCM env SCM_UNUSED
)
1347 const SCM cdr_expr
= SCM_CDR (expr
);
1348 const long length
= scm_ilength (cdr_expr
);
1349 ASSERT_SYNTAX (length
== 2 || length
== 3, s_expression
, expr
);
1350 SCM_SETCAR (expr
, SCM_IM_IF
);
1355 SCM_SYNTAX (s_lambda
, "lambda", scm_i_makbimacro
, scm_m_lambda
);
1356 SCM_GLOBAL_SYMBOL (scm_sym_lambda
, s_lambda
);
1358 /* A helper function for memoize_lambda to support checking for duplicate
1359 * formal arguments: Return true if OBJ is `eq?' to one of the elements of
1360 * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
1361 * forms that a formal argument can have:
1362 * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
1364 c_improper_memq (SCM obj
, SCM list
)
1366 for (; SCM_CONSP (list
); list
= SCM_CDR (list
))
1368 if (SCM_EQ_P (SCM_CAR (list
), obj
))
1371 return SCM_EQ_P (list
, obj
);
1375 scm_m_lambda (SCM expr
, SCM env SCM_UNUSED
)
1384 const SCM cdr_expr
= SCM_CDR (expr
);
1385 const long length
= scm_ilength (cdr_expr
);
1386 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1387 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1389 /* Before iterating the list of formal arguments, make sure the formals
1390 * actually are given as either a symbol or a non-cyclic list. */
1391 formals
= SCM_CAR (cdr_expr
);
1392 if (SCM_CONSP (formals
))
1394 /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
1395 * detected, report a 'Bad formals' error. */
1399 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals
) || SCM_NULLP (formals
),
1400 s_bad_formals
, formals
, expr
);
1403 /* Now iterate the list of formal arguments to check if all formals are
1404 * symbols, and that there are no duplicates. */
1405 formals_idx
= formals
;
1406 while (SCM_CONSP (formals_idx
))
1408 const SCM formal
= SCM_CAR (formals_idx
);
1409 const SCM next_idx
= SCM_CDR (formals_idx
);
1410 ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal
), s_bad_formal
, formal
, expr
);
1411 ASSERT_SYNTAX_2 (!c_improper_memq (formal
, next_idx
),
1412 s_duplicate_formal
, formal
, expr
);
1413 formals_idx
= next_idx
;
1415 ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx
) || SCM_SYMBOLP (formals_idx
),
1416 s_bad_formal
, formals_idx
, expr
);
1418 /* Memoize the body. Keep a potential documentation string. */
1419 /* Dirk:FIXME:: We should probably extract the documentation string to
1420 * some external database. Otherwise it will slow down execution, since
1421 * the documentation string will have to be skipped with every execution
1422 * of the closure. */
1423 cddr_expr
= SCM_CDR (cdr_expr
);
1424 documentation
= (length
>= 3 && SCM_STRINGP (SCM_CAR (cddr_expr
)));
1425 body
= documentation
? SCM_CDR (cddr_expr
) : cddr_expr
;
1426 new_body
= m_body (SCM_IM_LAMBDA
, body
);
1428 SCM_SETCAR (expr
, SCM_IM_LAMBDA
);
1430 SCM_SETCDR (cddr_expr
, new_body
);
1432 SCM_SETCDR (cdr_expr
, new_body
);
1437 /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
1439 check_bindings (const SCM bindings
, const SCM expr
)
1443 ASSERT_SYNTAX_2 (scm_ilength (bindings
) >= 0,
1444 s_bad_bindings
, bindings
, expr
);
1446 binding_idx
= bindings
;
1447 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1449 SCM name
; /* const */
1451 const SCM binding
= SCM_CAR (binding_idx
);
1452 ASSERT_SYNTAX_2 (scm_ilength (binding
) == 2,
1453 s_bad_binding
, binding
, expr
);
1455 name
= SCM_CAR (binding
);
1456 ASSERT_SYNTAX_2 (SCM_SYMBOLP (name
), s_bad_variable
, name
, expr
);
1461 /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
1462 * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
1463 * variables are returned in a list with their order reversed, and the init
1464 * forms are returned in a list in the same order as they are given in the
1465 * bindings. If a duplicate variable name is detected, an error is
1468 transform_bindings (
1469 const SCM bindings
, const SCM expr
,
1470 SCM
*const rvarptr
, SCM
*const initptr
)
1472 SCM rvariables
= SCM_EOL
;
1473 SCM rinits
= SCM_EOL
;
1474 SCM binding_idx
= bindings
;
1475 for (; !SCM_NULLP (binding_idx
); binding_idx
= SCM_CDR (binding_idx
))
1477 const SCM binding
= SCM_CAR (binding_idx
);
1478 const SCM cdr_binding
= SCM_CDR (binding
);
1479 const SCM name
= SCM_CAR (binding
);
1480 ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name
, rvariables
)),
1481 s_duplicate_binding
, name
, expr
);
1482 rvariables
= scm_cons (name
, rvariables
);
1483 rinits
= scm_cons (SCM_CAR (cdr_binding
), rinits
);
1485 *rvarptr
= rvariables
;
1486 *initptr
= scm_reverse_x (rinits
, SCM_UNDEFINED
);
1490 SCM_SYNTAX(s_let
, "let", scm_i_makbimacro
, scm_m_let
);
1491 SCM_GLOBAL_SYMBOL(scm_sym_let
, s_let
);
1493 /* This function is a helper function for memoize_let. It transforms
1494 * (let name ((var init) ...) body ...) into
1495 * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
1496 * and memoizes the expression. It is assumed that the caller has checked
1497 * that name is a symbol and that there are bindings and a body. */
1499 memoize_named_let (const SCM expr
, const SCM env SCM_UNUSED
)
1505 const SCM cdr_expr
= SCM_CDR (expr
);
1506 const SCM name
= SCM_CAR (cdr_expr
);
1507 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1508 const SCM bindings
= SCM_CAR (cddr_expr
);
1509 check_bindings (bindings
, expr
);
1511 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1512 variables
= scm_reverse_x (rvariables
, SCM_UNDEFINED
);
1515 const SCM let_body
= SCM_CDR (cddr_expr
);
1516 const SCM lambda_body
= m_body (SCM_IM_LET
, let_body
);
1517 const SCM lambda_tail
= scm_cons (variables
, lambda_body
);
1518 const SCM lambda_form
= scm_cons_source (expr
, scm_sym_lambda
, lambda_tail
);
1520 const SCM rvar
= scm_list_1 (name
);
1521 const SCM init
= scm_list_1 (lambda_form
);
1522 const SCM body
= m_body (SCM_IM_LET
, scm_list_1 (name
));
1523 const SCM letrec_tail
= scm_cons (rvar
, scm_cons (init
, body
));
1524 const SCM letrec_form
= scm_cons_source (expr
, SCM_IM_LETREC
, letrec_tail
);
1525 return scm_cons_source (expr
, letrec_form
, inits
);
1529 /* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1530 * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
1532 scm_m_let (SCM expr
, SCM env
)
1536 const SCM cdr_expr
= SCM_CDR (expr
);
1537 const long length
= scm_ilength (cdr_expr
);
1538 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1539 ASSERT_SYNTAX (length
>= 2, s_missing_expression
, expr
);
1541 bindings
= SCM_CAR (cdr_expr
);
1542 if (SCM_SYMBOLP (bindings
))
1544 ASSERT_SYNTAX (length
>= 3, s_missing_expression
, expr
);
1545 return memoize_named_let (expr
, env
);
1548 check_bindings (bindings
, expr
);
1549 if (SCM_NULLP (bindings
) || SCM_NULLP (SCM_CDR (bindings
)))
1551 /* Special case: no bindings or single binding => let* is faster. */
1552 const SCM body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1553 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), bindings
, body
), env
);
1560 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1563 const SCM new_body
= m_body (SCM_IM_LET
, SCM_CDR (cdr_expr
));
1564 const SCM new_tail
= scm_cons2 (rvariables
, inits
, new_body
);
1565 SCM_SETCAR (expr
, SCM_IM_LET
);
1566 SCM_SETCDR (expr
, new_tail
);
1573 SCM_SYNTAX (s_letstar
, "let*", scm_i_makbimacro
, scm_m_letstar
);
1574 SCM_GLOBAL_SYMBOL (scm_sym_letstar
, s_letstar
);
1576 /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
1577 * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
1579 scm_m_letstar (SCM expr
, SCM env SCM_UNUSED
)
1584 const SCM cdr_expr
= SCM_CDR (expr
);
1585 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1586 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1588 binding_idx
= SCM_CAR (cdr_expr
);
1589 check_bindings (binding_idx
, expr
);
1591 /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
1592 * transformation is done in place. At the beginning of one iteration of
1593 * the loop the variable binding_idx holds the form
1594 * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
1595 * where P1, P2 and P3 indicate the pairs, that are relevant for the
1596 * transformation. P1 and P2 are modified in the loop, P3 remains
1597 * untouched. After the execution of the loop, P1 will hold
1598 * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
1599 * and binding_idx will hold P3. */
1600 while (!SCM_NULLP (binding_idx
))
1602 const SCM cdr_binding_idx
= SCM_CDR (binding_idx
); /* remember P3 */
1603 const SCM binding
= SCM_CAR (binding_idx
);
1604 const SCM name
= SCM_CAR (binding
);
1605 const SCM cdr_binding
= SCM_CDR (binding
);
1607 SCM_SETCDR (cdr_binding
, cdr_binding_idx
); /* update P2 */
1608 SCM_SETCAR (binding_idx
, name
); /* update P1 */
1609 SCM_SETCDR (binding_idx
, cdr_binding
); /* update P1 */
1611 binding_idx
= cdr_binding_idx
; /* continue with P3 */
1614 new_body
= m_body (SCM_IM_LETSTAR
, SCM_CDR (cdr_expr
));
1615 SCM_SETCAR (expr
, SCM_IM_LETSTAR
);
1616 /* the bindings have been changed in place */
1617 SCM_SETCDR (cdr_expr
, new_body
);
1622 SCM_SYNTAX(s_letrec
, "letrec", scm_i_makbimacro
, scm_m_letrec
);
1623 SCM_GLOBAL_SYMBOL(scm_sym_letrec
, s_letrec
);
1626 scm_m_letrec (SCM expr
, SCM env
)
1630 const SCM cdr_expr
= SCM_CDR (expr
);
1631 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1632 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1634 bindings
= SCM_CAR (cdr_expr
);
1635 if (SCM_NULLP (bindings
))
1637 /* no bindings, let* is executed faster */
1638 SCM body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1639 return scm_m_letstar (scm_cons2 (SCM_CAR (expr
), SCM_EOL
, body
), env
);
1647 check_bindings (bindings
, expr
);
1648 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1649 new_body
= m_body (SCM_IM_LETREC
, SCM_CDR (cdr_expr
));
1650 return scm_cons2 (SCM_IM_LETREC
, rvariables
, scm_cons (inits
, new_body
));
1655 SCM_SYNTAX (s_or
, "or", scm_i_makbimacro
, scm_m_or
);
1656 SCM_GLOBAL_SYMBOL (scm_sym_or
, s_or
);
1659 scm_m_or (SCM expr
, SCM env SCM_UNUSED
)
1661 const SCM cdr_expr
= SCM_CDR (expr
);
1662 const long length
= scm_ilength (cdr_expr
);
1664 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
1668 /* Special case: (or) is replaced by #f. */
1673 SCM_SETCAR (expr
, SCM_IM_OR
);
1679 SCM_SYNTAX (s_quasiquote
, "quasiquote", scm_makacro
, scm_m_quasiquote
);
1680 SCM_GLOBAL_SYMBOL (scm_sym_quasiquote
, s_quasiquote
);
1681 SCM_GLOBAL_SYMBOL (scm_sym_unquote
, "unquote");
1682 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing
, "unquote-splicing");
1684 /* Internal function to handle a quasiquotation: 'form' is the parameter in
1685 * the call (quasiquotation form), 'env' is the environment where unquoted
1686 * expressions will be evaluated, and 'depth' is the current quasiquotation
1687 * nesting level and is known to be greater than zero. */
1689 iqq (SCM form
, SCM env
, unsigned long int depth
)
1691 if (SCM_CONSP (form
))
1693 const SCM tmp
= SCM_CAR (form
);
1694 if (SCM_EQ_P (tmp
, scm_sym_quasiquote
))
1696 const SCM args
= SCM_CDR (form
);
1697 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1698 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
+ 1));
1700 else if (SCM_EQ_P (tmp
, scm_sym_unquote
))
1702 const SCM args
= SCM_CDR (form
);
1703 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1705 return scm_eval_car (args
, env
);
1707 return scm_list_2 (tmp
, iqq (SCM_CAR (args
), env
, depth
- 1));
1709 else if (SCM_CONSP (tmp
)
1710 && SCM_EQ_P (SCM_CAR (tmp
), scm_sym_uq_splicing
))
1712 const SCM args
= SCM_CDR (tmp
);
1713 ASSERT_SYNTAX (scm_ilength (args
) == 1, s_expression
, form
);
1716 const SCM list
= scm_eval_car (args
, env
);
1717 const SCM rest
= SCM_CDR (form
);
1718 ASSERT_SYNTAX_2 (scm_ilength (list
) >= 0,
1719 s_splicing
, list
, form
);
1720 return scm_append (scm_list_2 (list
, iqq (rest
, env
, depth
)));
1723 return scm_cons (iqq (SCM_CAR (form
), env
, depth
- 1),
1724 iqq (SCM_CDR (form
), env
, depth
));
1727 return scm_cons (iqq (SCM_CAR (form
), env
, depth
),
1728 iqq (SCM_CDR (form
), env
, depth
));
1730 else if (SCM_VECTORP (form
))
1732 size_t i
= SCM_VECTOR_LENGTH (form
);
1733 SCM
const *const data
= SCM_VELTS (form
);
1736 tmp
= scm_cons (data
[--i
], tmp
);
1737 scm_remember_upto_here_1 (form
);
1738 return scm_vector (iqq (tmp
, env
, depth
));
1745 scm_m_quasiquote (SCM expr
, SCM env
)
1747 const SCM cdr_expr
= SCM_CDR (expr
);
1748 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1749 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1750 return iqq (SCM_CAR (cdr_expr
), env
, 1);
1754 SCM_SYNTAX (s_quote
, "quote", scm_i_makbimacro
, scm_m_quote
);
1755 SCM_GLOBAL_SYMBOL (scm_sym_quote
, s_quote
);
1758 scm_m_quote (SCM expr
, SCM env SCM_UNUSED
)
1762 const SCM cdr_expr
= SCM_CDR (expr
);
1763 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1764 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1765 quotee
= SCM_CAR (cdr_expr
);
1766 if (is_self_quoting_p (quotee
))
1768 SCM_SETCAR (expr
, SCM_IM_QUOTE
);
1773 /* Will go into the RnRS module when Guile is factorized.
1774 SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
1775 static const char s_set_x
[] = "set!";
1776 SCM_GLOBAL_SYMBOL (scm_sym_set_x
, s_set_x
);
1779 scm_m_set_x (SCM expr
, SCM env SCM_UNUSED
)
1783 const SCM cdr_expr
= SCM_CDR (expr
);
1784 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1785 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1786 variable
= SCM_CAR (cdr_expr
);
1787 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
) || SCM_VARIABLEP (variable
),
1788 s_bad_variable
, variable
, expr
);
1790 SCM_SETCAR (expr
, SCM_IM_SET_X
);
1795 /* Start of the memoizers for non-R5RS builtin macros. */
1798 SCM_SYNTAX (s_atapply
, "@apply", scm_i_makbimacro
, scm_m_apply
);
1799 SCM_GLOBAL_SYMBOL (scm_sym_atapply
, s_atapply
);
1800 SCM_GLOBAL_SYMBOL (scm_sym_apply
, s_atapply
+ 1);
1803 scm_m_apply (SCM expr
, SCM env SCM_UNUSED
)
1805 const SCM cdr_expr
= SCM_CDR (expr
);
1806 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1807 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_missing_expression
, expr
);
1809 SCM_SETCAR (expr
, SCM_IM_APPLY
);
1814 SCM_SYNTAX (s_atbind
, "@bind", scm_i_makbimacro
, scm_m_atbind
);
1816 /* FIXME: The following explanation should go into the documentation: */
1817 /* (@bind ((var init) ...) body ...) will assign the values of the `init's to
1818 * the global variables named by `var's (symbols, not evaluated), creating
1819 * them if they don't exist, executes body, and then restores the previous
1820 * values of the `var's. Additionally, whenever control leaves body, the
1821 * values of the `var's are saved and restored when control returns. It is an
1822 * error when a symbol appears more than once among the `var's. All `init's
1823 * are evaluated before any `var' is set.
1825 * Think of this as `let' for dynamic scope.
1828 /* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
1829 * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
1831 * FIXME - also implement `@bind*'.
1834 scm_m_atbind (SCM expr
, SCM env
)
1841 const SCM top_level
= scm_env_top_level (env
);
1843 const SCM cdr_expr
= SCM_CDR (expr
);
1844 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1845 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 2, s_missing_expression
, expr
);
1846 bindings
= SCM_CAR (cdr_expr
);
1847 check_bindings (bindings
, expr
);
1848 transform_bindings (bindings
, expr
, &rvariables
, &inits
);
1850 for (variable_idx
= rvariables
;
1851 !SCM_NULLP (variable_idx
);
1852 variable_idx
= SCM_CDR (variable_idx
))
1854 /* The first call to scm_sym2var will look beyond the current module,
1855 * while the second call wont. */
1856 const SCM variable
= SCM_CAR (variable_idx
);
1857 SCM new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_F
);
1858 if (SCM_FALSEP (new_variable
))
1859 new_variable
= scm_sym2var (variable
, top_level
, SCM_BOOL_T
);
1860 SCM_SETCAR (variable_idx
, new_variable
);
1863 SCM_SETCAR (expr
, SCM_IM_BIND
);
1864 SCM_SETCAR (cdr_expr
, scm_cons (rvariables
, inits
));
1869 SCM_SYNTAX(s_atcall_cc
, "@call-with-current-continuation", scm_i_makbimacro
, scm_m_cont
);
1870 SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc
, s_atcall_cc
);
1873 scm_m_cont (SCM expr
, SCM env SCM_UNUSED
)
1875 const SCM cdr_expr
= SCM_CDR (expr
);
1876 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1877 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
1879 SCM_SETCAR (expr
, SCM_IM_CONT
);
1884 SCM_SYNTAX (s_at_call_with_values
, "@call-with-values", scm_i_makbimacro
, scm_m_at_call_with_values
);
1885 SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values
, s_at_call_with_values
);
1888 scm_m_at_call_with_values (SCM expr
, SCM env SCM_UNUSED
)
1890 const SCM cdr_expr
= SCM_CDR (expr
);
1891 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1892 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1894 SCM_SETCAR (expr
, SCM_IM_CALL_WITH_VALUES
);
1899 SCM_SYNTAX (s_future
, "future", scm_i_makbimacro
, scm_m_future
);
1900 SCM_GLOBAL_SYMBOL (scm_sym_future
, s_future
);
1902 /* Like promises, futures are implemented as closures with an empty
1903 * parameter list. Thus, (future <expression>) is transformed into
1904 * (#@future '() <expression>), where the empty list represents the
1905 * empty parameter list. This representation allows for easy creation
1906 * of the closure during evaluation. */
1908 scm_m_future (SCM expr
, SCM env
)
1910 const SCM new_expr
= memoize_as_thunk_prototype (expr
, env
);
1911 SCM_SETCAR (new_expr
, SCM_IM_FUTURE
);
1916 SCM_SYNTAX (s_gset_x
, "set!", scm_i_makbimacro
, scm_m_generalized_set_x
);
1917 SCM_SYMBOL (scm_sym_setter
, "setter");
1920 scm_m_generalized_set_x (SCM expr
, SCM env
)
1922 SCM target
, exp_target
;
1924 const SCM cdr_expr
= SCM_CDR (expr
);
1925 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1926 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1928 target
= SCM_CAR (cdr_expr
);
1929 if (!SCM_CONSP (target
))
1932 return scm_m_set_x (expr
, env
);
1936 /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
1937 /* Macroexpanding the target might return things of the form
1938 (begin <atom>). In that case, <atom> must be a symbol or a
1939 variable and we memoize to (set! <atom> ...).
1941 exp_target
= scm_macroexp (target
, env
);
1942 if (SCM_EQ_P (SCM_CAR (exp_target
), SCM_IM_BEGIN
)
1943 && !SCM_NULLP (SCM_CDR (exp_target
))
1944 && SCM_NULLP (SCM_CDDR (exp_target
)))
1946 exp_target
= SCM_CADR (exp_target
);
1947 ASSERT_SYNTAX_2 (SCM_SYMBOLP (exp_target
)
1948 || SCM_VARIABLEP (exp_target
),
1949 s_bad_variable
, exp_target
, expr
);
1950 return scm_cons (SCM_IM_SET_X
, scm_cons (exp_target
,
1951 SCM_CDR (cdr_expr
)));
1955 const SCM setter_proc_tail
= scm_list_1 (SCM_CAR (target
));
1956 const SCM setter_proc
= scm_cons_source (expr
, scm_sym_setter
,
1959 const SCM cddr_expr
= SCM_CDR (cdr_expr
);
1960 const SCM setter_args
= scm_append_x (scm_list_2 (SCM_CDR (target
),
1963 SCM_SETCAR (expr
, setter_proc
);
1964 SCM_SETCDR (expr
, setter_args
);
1971 /* @slot-ref is bound privately in the (oop goops) module from goops.c. As
1972 * soon as the module system allows us to more freely create bindings in
1973 * arbitrary modules during the startup phase, the code from goops.c should be
1976 scm_m_atslot_ref (SCM expr
, SCM env SCM_UNUSED
)
1980 const SCM cdr_expr
= SCM_CDR (expr
);
1981 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
1982 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 2, s_expression
, expr
);
1983 slot_nr
= SCM_CADR (cdr_expr
);
1984 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
1986 SCM_SETCAR (expr
, SCM_IM_SLOT_REF
);
1991 /* @slot-set! is bound privately in the (oop goops) module from goops.c. As
1992 * soon as the module system allows us to more freely create bindings in
1993 * arbitrary modules during the startup phase, the code from goops.c should be
1996 scm_m_atslot_set_x (SCM expr
, SCM env SCM_UNUSED
)
2000 const SCM cdr_expr
= SCM_CDR (expr
);
2001 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2002 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 3, s_expression
, expr
);
2003 slot_nr
= SCM_CADR (cdr_expr
);
2004 ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr
), s_bad_slot_number
, slot_nr
, expr
);
2006 SCM_SETCAR (expr
, SCM_IM_SLOT_SET_X
);
2011 #if SCM_ENABLE_ELISP
2013 static const char s_defun
[] = "Symbol's function definition is void";
2015 SCM_SYNTAX (s_nil_cond
, "nil-cond", scm_i_makbimacro
, scm_m_nil_cond
);
2017 /* nil-cond expressions have the form
2018 * (nil-cond COND VAL COND VAL ... ELSEVAL) */
2020 scm_m_nil_cond (SCM expr
, SCM env SCM_UNUSED
)
2022 const long length
= scm_ilength (SCM_CDR (expr
));
2023 ASSERT_SYNTAX (length
>= 0, s_bad_expression
, expr
);
2024 ASSERT_SYNTAX (length
>= 1 && (length
% 2) == 1, s_expression
, expr
);
2026 SCM_SETCAR (expr
, SCM_IM_NIL_COND
);
2031 SCM_SYNTAX (s_atfop
, "@fop", scm_i_makbimacro
, scm_m_atfop
);
2033 /* The @fop-macro handles procedure and macro applications for elisp. The
2034 * input expression must have the form
2035 * (@fop <var> (transformer-macro <expr> ...))
2036 * where <var> must be a symbol. The expression is transformed into the
2037 * memoized form of either
2038 * (apply <un-aliased var> (transformer-macro <expr> ...))
2039 * if the value of var (across all aliasing) is not a macro, or
2040 * (<un-aliased var> <expr> ...)
2041 * if var is a macro. */
2043 scm_m_atfop (SCM expr
, SCM env SCM_UNUSED
)
2048 const SCM cdr_expr
= SCM_CDR (expr
);
2049 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2050 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 1, s_missing_expression
, expr
);
2052 symbol
= SCM_CAR (cdr_expr
);
2053 ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol
), s_bad_variable
, symbol
, expr
);
2055 location
= scm_symbol_fref (symbol
);
2056 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2058 /* The elisp function `defalias' allows to define aliases for symbols. To
2059 * look up such definitions, the chain of symbol definitions has to be
2060 * followed up to the terminal symbol. */
2061 while (SCM_SYMBOLP (SCM_VARIABLE_REF (location
)))
2063 const SCM alias
= SCM_VARIABLE_REF (location
);
2064 location
= scm_symbol_fref (alias
);
2065 ASSERT_SYNTAX_2 (SCM_VARIABLEP (location
), s_defun
, symbol
, expr
);
2068 /* Memoize the value location belonging to the terminal symbol. */
2069 SCM_SETCAR (cdr_expr
, location
);
2071 if (!SCM_MACROP (SCM_VARIABLE_REF (location
)))
2073 /* Since the location does not contain a macro, the form is a procedure
2074 * application. Replace `@fop' by `@apply' and transform the expression
2075 * including the `transformer-macro'. */
2076 SCM_SETCAR (expr
, SCM_IM_APPLY
);
2081 /* Since the location contains a macro, the arguments should not be
2082 * transformed, so the `transformer-macro' is cut out. The resulting
2083 * expression starts with the memoized variable, that is at the cdr of
2084 * the input expression. */
2085 SCM_SETCDR (cdr_expr
, SCM_CDADR (cdr_expr
));
2090 #endif /* SCM_ENABLE_ELISP */
2093 #if (SCM_ENABLE_DEPRECATED == 1)
2095 /* Deprecated in guile 1.7.0 on 2003-11-09. */
2097 scm_m_expand_body (SCM exprs
, SCM env
)
2099 scm_c_issue_deprecation_warning
2100 ("`scm_m_expand_body' is deprecated.");
2101 m_expand_body (exprs
, env
);
2106 SCM_SYNTAX (s_undefine
, "undefine", scm_makacro
, scm_m_undefine
);
2109 scm_m_undefine (SCM expr
, SCM env
)
2114 const SCM cdr_expr
= SCM_CDR (expr
);
2115 ASSERT_SYNTAX (SCM_TOP_LEVEL (env
), "Bad undefine placement in", expr
);
2116 ASSERT_SYNTAX (scm_ilength (cdr_expr
) >= 0, s_bad_expression
, expr
);
2117 ASSERT_SYNTAX (scm_ilength (cdr_expr
) == 1, s_expression
, expr
);
2119 variable
= SCM_CAR (cdr_expr
);
2120 ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable
), s_bad_variable
, variable
, expr
);
2121 location
= scm_sym2var (variable
, scm_env_top_level (env
), SCM_BOOL_F
);
2122 ASSERT_SYNTAX_2 (!SCM_FALSEP (location
)
2123 && !SCM_UNBNDP (SCM_VARIABLE_REF (location
)),
2124 "variable already unbound ", variable
, expr
);
2125 SCM_VARIABLE_SET (location
, SCM_UNDEFINED
);
2126 return SCM_UNSPECIFIED
;
2131 scm_macroexp (SCM x
, SCM env
)
2133 SCM res
, proc
, orig_sym
;
2135 /* Don't bother to produce error messages here. We get them when we
2136 eventually execute the code for real. */
2139 orig_sym
= SCM_CAR (x
);
2140 if (!SCM_SYMBOLP (orig_sym
))
2144 SCM
*proc_ptr
= scm_lookupcar1 (x
, env
, 0);
2145 if (proc_ptr
== NULL
)
2147 /* We have lost the race. */
2153 /* Only handle memoizing macros. `Acros' and `macros' are really
2154 special forms and should not be evaluated here. */
2156 if (!SCM_MACROP (proc
)
2157 || (SCM_MACRO_TYPE (proc
) != 2 && !SCM_BUILTIN_MACRO_P (proc
)))
2160 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of lookupcar */
2161 res
= scm_call_2 (SCM_MACRO_CODE (proc
), x
, env
);
2163 if (scm_ilength (res
) <= 0)
2164 res
= scm_list_2 (SCM_IM_BEGIN
, res
);
2167 SCM_SETCAR (x
, SCM_CAR (res
));
2168 SCM_SETCDR (x
, SCM_CDR (res
));
2176 /*****************************************************************************/
2177 /*****************************************************************************/
2178 /* The definitions for unmemoization start here. */
2179 /*****************************************************************************/
2180 /*****************************************************************************/
2182 #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2184 SCM_SYMBOL (sym_three_question_marks
, "???");
2187 /* scm_unmemocopy takes a memoized expression together with its
2188 * environment and rewrites it to its original form. Thus, it is the
2189 * inversion of the rewrite rules above. The procedure is not
2190 * optimized for speed. It's used in scm_iprin1 when printing the
2191 * code of a closure, in scm_procedure_source, in display_frame when
2192 * generating the source for a stackframe in a backtrace, and in
2193 * display_expression.
2195 * Unmemoizing is not a reliable process. You cannot in general
2196 * expect to get the original source back.
2198 * However, GOOPS currently relies on this for method compilation.
2199 * This ought to change.
2203 build_binding_list (SCM rnames
, SCM rinits
)
2205 SCM bindings
= SCM_EOL
;
2206 while (!SCM_NULLP (rnames
))
2208 SCM binding
= scm_list_2 (SCM_CAR (rnames
), SCM_CAR (rinits
));
2209 bindings
= scm_cons (binding
, bindings
);
2210 rnames
= SCM_CDR (rnames
);
2211 rinits
= SCM_CDR (rinits
);
2218 unmemocar (SCM form
, SCM env
)
2220 if (!SCM_CONSP (form
))
2224 SCM c
= SCM_CAR (form
);
2225 if (SCM_VARIABLEP (c
))
2227 SCM sym
= scm_module_reverse_lookup (scm_env_module (env
), c
);
2228 if (SCM_FALSEP (sym
))
2229 sym
= sym_three_question_marks
;
2230 SCM_SETCAR (form
, sym
);
2232 else if (SCM_ILOCP (c
))
2234 unsigned long int ir
;
2236 for (ir
= SCM_IFRAME (c
); ir
!= 0; --ir
)
2237 env
= SCM_CDR (env
);
2238 env
= SCM_CAAR (env
);
2239 for (ir
= SCM_IDIST (c
); ir
!= 0; --ir
)
2240 env
= SCM_CDR (env
);
2242 SCM_SETCAR (form
, SCM_ICDRP (c
) ? env
: SCM_CAR (env
));
2250 scm_unmemocopy (SCM x
, SCM env
)
2255 if (SCM_VECTORP (x
))
2257 return scm_list_2 (scm_sym_quote
, x
);
2259 else if (!SCM_CONSP (x
))
2262 p
= scm_whash_lookup (scm_source_whash
, x
);
2263 if (SCM_ISYMP (SCM_CAR (x
)))
2265 switch (ISYMNUM (SCM_CAR (x
)))
2267 case (ISYMNUM (SCM_IM_AND
)):
2268 ls
= z
= scm_cons (scm_sym_and
, SCM_UNSPECIFIED
);
2270 case (ISYMNUM (SCM_IM_BEGIN
)):
2271 ls
= z
= scm_cons (scm_sym_begin
, SCM_UNSPECIFIED
);
2273 case (ISYMNUM (SCM_IM_CASE
)):
2274 ls
= z
= scm_cons (scm_sym_case
, SCM_UNSPECIFIED
);
2276 case (ISYMNUM (SCM_IM_COND
)):
2277 ls
= z
= scm_cons (scm_sym_cond
, SCM_UNSPECIFIED
);
2279 case (ISYMNUM (SCM_IM_DO
)):
2281 /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
2282 * where ix is an initializer for a local variable, nx is the name
2283 * of the local variable, test is the test clause of the do loop,
2284 * body is the body of the do loop and sx are the step clauses for
2285 * the local variables. */
2286 SCM names
, inits
, test
, memoized_body
, steps
, bindings
;
2289 inits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2291 names
= SCM_CAR (x
);
2292 env
= SCM_EXTEND_ENV (names
, SCM_EOL
, env
);
2294 test
= scm_unmemocopy (SCM_CAR (x
), env
);
2296 memoized_body
= SCM_CAR (x
);
2298 steps
= scm_reverse (scm_unmemocopy (x
, env
));
2300 /* build transformed binding list */
2302 while (!SCM_NULLP (names
))
2304 SCM name
= SCM_CAR (names
);
2305 SCM init
= SCM_CAR (inits
);
2306 SCM step
= SCM_CAR (steps
);
2307 step
= SCM_EQ_P (step
, name
) ? SCM_EOL
: scm_list_1 (step
);
2309 bindings
= scm_cons (scm_cons2 (name
, init
, step
), bindings
);
2311 names
= SCM_CDR (names
);
2312 inits
= SCM_CDR (inits
);
2313 steps
= SCM_CDR (steps
);
2315 z
= scm_cons (test
, SCM_UNSPECIFIED
);
2316 ls
= scm_cons2 (scm_sym_do
, bindings
, z
);
2318 x
= scm_cons (SCM_BOOL_F
, memoized_body
);
2321 case (ISYMNUM (SCM_IM_IF
)):
2322 ls
= z
= scm_cons (scm_sym_if
, SCM_UNSPECIFIED
);
2324 case (ISYMNUM (SCM_IM_LET
)):
2326 /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2327 * where nx is the name of a local variable, ix is an initializer
2328 * for the local variable and by are the body clauses. */
2329 SCM rnames
, rinits
, bindings
;
2332 rnames
= SCM_CAR (x
);
2334 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2335 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2337 bindings
= build_binding_list (rnames
, rinits
);
2338 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2339 ls
= scm_cons (scm_sym_let
, z
);
2342 case (ISYMNUM (SCM_IM_LETREC
)):
2344 /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2345 * where vx is the name of a local variable, ix is an initializer
2346 * for the local variable and by are the body clauses. */
2347 SCM rnames
, rinits
, bindings
;
2350 rnames
= SCM_CAR (x
);
2351 env
= SCM_EXTEND_ENV (rnames
, SCM_EOL
, env
);
2353 rinits
= scm_reverse (scm_unmemocopy (SCM_CAR (x
), env
));
2355 bindings
= build_binding_list (rnames
, rinits
);
2356 z
= scm_cons (bindings
, SCM_UNSPECIFIED
);
2357 ls
= scm_cons (scm_sym_letrec
, z
);
2360 case (ISYMNUM (SCM_IM_LETSTAR
)):
2368 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
2372 SCM copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2373 SCM initializer
= unmemocar (scm_list_1 (copy
), env
);
2374 y
= z
= scm_acons (SCM_CAR (b
), initializer
, SCM_UNSPECIFIED
);
2375 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2379 SCM_SETCDR (y
, SCM_EOL
);
2380 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2381 ls
= scm_cons (scm_sym_let
, z
);
2386 copy
= scm_unmemocopy (SCM_CADR (b
), env
);
2387 initializer
= unmemocar (scm_list_1 (copy
), env
);
2388 SCM_SETCDR (z
, scm_acons (SCM_CAR (b
),
2392 env
= SCM_EXTEND_ENV (SCM_CAR (b
), SCM_BOOL_F
, env
);
2395 while (!SCM_NULLP (b
));
2396 SCM_SETCDR (z
, SCM_EOL
);
2398 z
= scm_cons (y
, SCM_UNSPECIFIED
);
2399 ls
= scm_cons (scm_sym_letstar
, z
);
2402 case (ISYMNUM (SCM_IM_OR
)):
2403 ls
= z
= scm_cons (scm_sym_or
, SCM_UNSPECIFIED
);
2405 case (ISYMNUM (SCM_IM_LAMBDA
)):
2407 z
= scm_cons (SCM_CAR (x
), SCM_UNSPECIFIED
);
2408 ls
= scm_cons (scm_sym_lambda
, z
);
2409 env
= SCM_EXTEND_ENV (SCM_CAR (x
), SCM_EOL
, env
);
2411 case (ISYMNUM (SCM_IM_QUOTE
)):
2412 ls
= z
= scm_cons (scm_sym_quote
, SCM_UNSPECIFIED
);
2414 case (ISYMNUM (SCM_IM_SET_X
)):
2415 ls
= z
= scm_cons (scm_sym_set_x
, SCM_UNSPECIFIED
);
2417 case (ISYMNUM (SCM_IM_APPLY
)):
2418 ls
= z
= scm_cons (scm_sym_atapply
, SCM_UNSPECIFIED
);
2420 case (ISYMNUM (SCM_IM_CONT
)):
2421 ls
= z
= scm_cons (scm_sym_atcall_cc
, SCM_UNSPECIFIED
);
2423 case (ISYMNUM (SCM_IM_DELAY
)):
2424 ls
= z
= scm_cons (scm_sym_delay
, SCM_UNSPECIFIED
);
2427 case (ISYMNUM (SCM_IM_FUTURE
)):
2428 ls
= z
= scm_cons (scm_sym_future
, SCM_UNSPECIFIED
);
2431 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
2432 ls
= z
= scm_cons (scm_sym_at_call_with_values
, SCM_UNSPECIFIED
);
2434 case (ISYMNUM (SCM_IM_ELSE
)):
2435 ls
= z
= scm_cons (scm_sym_else
, SCM_UNSPECIFIED
);
2438 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2445 ls
= z
= unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x
), env
),
2451 while (SCM_CONSP (x
))
2453 SCM form
= SCM_CAR (x
);
2454 if (!SCM_ISYMP (form
))
2456 SCM copy
= scm_cons (scm_unmemocopy (form
, env
), SCM_UNSPECIFIED
);
2457 SCM_SETCDR (z
, unmemocar (copy
, env
));
2460 else if (SCM_EQ_P (form
, SCM_IM_ARROW
))
2462 SCM_SETCDR (z
, scm_cons (scm_sym_arrow
, SCM_UNSPECIFIED
));
2468 if (!SCM_FALSEP (p
))
2469 scm_whash_insert (scm_source_whash
, ls
, p
);
2474 #if (SCM_ENABLE_DEPRECATED == 1)
2477 scm_unmemocar (SCM form
, SCM env
)
2479 return unmemocar (form
, env
);
2484 /*****************************************************************************/
2485 /*****************************************************************************/
2486 /* The definitions for execution start here. */
2487 /*****************************************************************************/
2488 /*****************************************************************************/
2490 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame
, "enter-frame");
2491 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame
, "apply-frame");
2492 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame
, "exit-frame");
2493 SCM_GLOBAL_SYMBOL (scm_sym_trace
, "trace");
2495 /* A function object to implement "apply" for non-closure functions. */
2497 /* An endless list consisting of #<undefined> objects: */
2498 static SCM undefineds
;
2502 scm_badargsp (SCM formals
, SCM args
)
2504 while (!SCM_NULLP (formals
))
2506 if (!SCM_CONSP (formals
))
2508 if (SCM_NULLP (args
))
2510 formals
= SCM_CDR (formals
);
2511 args
= SCM_CDR (args
);
2513 return !SCM_NULLP (args
) ? 1 : 0;
2518 /* The evaluator contains a plethora of EVAL symbols. This is an attempt at
2521 * The following macros should be used in code which is read twice (where the
2522 * choice of evaluator is hard soldered):
2524 * CEVAL is the symbol used within one evaluator to call itself.
2525 * Originally, it is defined to ceval, but is redefined to deval during the
2528 * SCM_EVALIM is used when it is known that the expression is an
2529 * immediate. (This macro never calls an evaluator.)
2531 * EVAL evaluates an expression that is expected to have its symbols already
2532 * memoized. Expressions that are not of the form '(<form> <form> ...)' are
2533 * evaluated inline without calling an evaluator.
2535 * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
2536 * potentially replacing a symbol at the position Y:<form> by its memoized
2537 * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
2538 * evaluation is performed inline without calling an evaluator.
2540 * The following macros should be used in code which is read once
2541 * (where the choice of evaluator is dynamic):
2543 * SCM_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
2546 * SCM_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
2547 * on the debugging mode.
2549 * The main motivation for keeping this plethora is efficiency
2550 * together with maintainability (=> locality of code).
2553 static SCM
ceval (SCM x
, SCM env
);
2554 static SCM
deval (SCM x
, SCM env
);
2558 #define SCM_EVALIM2(x) \
2559 ((SCM_EQ_P ((x), SCM_EOL) \
2560 ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
2564 #define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
2565 ? *scm_ilookup ((x), (env)) \
2568 #define SCM_XEVAL(x, env) \
2571 : (SCM_VARIABLEP (x) \
2572 ? SCM_VARIABLE_REF (x) \
2574 ? (scm_debug_mode_p \
2575 ? deval ((x), (env)) \
2576 : ceval ((x), (env))) \
2579 #define SCM_XEVALCAR(x, env) \
2580 (SCM_IMP (SCM_CAR (x)) \
2581 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2582 : (SCM_VARIABLEP (SCM_CAR (x)) \
2583 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2584 : (SCM_CONSP (SCM_CAR (x)) \
2585 ? (scm_debug_mode_p \
2586 ? deval (SCM_CAR (x), (env)) \
2587 : ceval (SCM_CAR (x), (env))) \
2588 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2590 : *scm_lookupcar ((x), (env), 1)))))
2592 #define EVAL(x, env) \
2594 ? SCM_EVALIM ((x), (env)) \
2595 : (SCM_VARIABLEP (x) \
2596 ? SCM_VARIABLE_REF (x) \
2598 ? CEVAL ((x), (env)) \
2601 #define EVALCAR(x, env) \
2602 (SCM_IMP (SCM_CAR (x)) \
2603 ? SCM_EVALIM (SCM_CAR (x), (env)) \
2604 : (SCM_VARIABLEP (SCM_CAR (x)) \
2605 ? SCM_VARIABLE_REF (SCM_CAR (x)) \
2606 : (SCM_CONSP (SCM_CAR (x)) \
2607 ? CEVAL (SCM_CAR (x), (env)) \
2608 : (!SCM_SYMBOLP (SCM_CAR (x)) \
2610 : *scm_lookupcar ((x), (env), 1)))))
2612 SCM_REC_MUTEX (source_mutex
);
2616 scm_eval_car (SCM pair
, SCM env
)
2618 return SCM_XEVALCAR (pair
, env
);
2623 scm_eval_args (SCM l
, SCM env
, SCM proc
)
2625 SCM results
= SCM_EOL
, *lloc
= &results
, res
;
2626 while (SCM_CONSP (l
))
2628 res
= EVALCAR (l
, env
);
2630 *lloc
= scm_list_1 (res
);
2631 lloc
= SCM_CDRLOC (*lloc
);
2635 scm_wrong_num_args (proc
);
2641 scm_eval_body (SCM code
, SCM env
)
2646 next
= SCM_CDR (code
);
2647 while (!SCM_NULLP (next
))
2649 if (SCM_IMP (SCM_CAR (code
)))
2651 if (SCM_ISYMP (SCM_CAR (code
)))
2653 scm_rec_mutex_lock (&source_mutex
);
2654 /* check for race condition */
2655 if (SCM_ISYMP (SCM_CAR (code
)))
2656 m_expand_body (code
, env
);
2657 scm_rec_mutex_unlock (&source_mutex
);
2662 SCM_XEVAL (SCM_CAR (code
), env
);
2664 next
= SCM_CDR (code
);
2666 return SCM_XEVALCAR (code
, env
);
2672 /* SECTION: This code is specific for the debugging support. One
2673 * branch is read when DEVAL isn't defined, the other when DEVAL is
2679 #define SCM_APPLY scm_apply
2680 #define PREP_APPLY(proc, args)
2682 #define RETURN(x) do { return x; } while (0)
2683 #ifdef STACK_CHECKING
2684 #ifndef NO_CEVAL_STACK_CHECKING
2685 #define EVAL_STACK_CHECKING
2692 #define CEVAL deval /* Substitute all uses of ceval */
2695 #define SCM_APPLY scm_dapply
2698 #define PREP_APPLY(p, l) \
2699 { ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
2702 #define ENTER_APPLY \
2704 SCM_SET_ARGSREADY (debug);\
2705 if (scm_check_apply_p && SCM_TRAPS_P)\
2706 if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
2708 SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \
2709 SCM_SET_TRACED_FRAME (debug); \
2711 if (SCM_CHEAPTRAPS_P)\
2713 tmp = scm_make_debugobj (&debug);\
2714 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2719 tmp = scm_make_continuation (&first);\
2721 scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
2728 #define RETURN(e) do { proc = (e); goto exit; } while (0)
2730 #ifdef STACK_CHECKING
2731 #ifndef EVAL_STACK_CHECKING
2732 #define EVAL_STACK_CHECKING
2737 /* scm_last_debug_frame contains a pointer to the last debugging information
2738 * stack frame. It is accessed very often from the debugging evaluator, so it
2739 * should probably not be indirectly addressed. Better to save and restore it
2740 * from the current root at any stack swaps.
2743 /* scm_debug_eframe_size is the number of slots available for pseudo
2744 * stack frames at each real stack frame.
2747 long scm_debug_eframe_size
;
2749 int scm_debug_mode_p
;
2750 int scm_check_entry_p
;
2751 int scm_check_apply_p
;
2752 int scm_check_exit_p
;
2754 long scm_eval_stack
;
2756 scm_t_option scm_eval_opts
[] = {
2757 { SCM_OPTION_INTEGER
, "stack", 22000, "Size of thread stacks (in machine words)." }
2760 scm_t_option scm_debug_opts
[] = {
2761 { SCM_OPTION_BOOLEAN
, "cheap", 1,
2762 "*Flyweight representation of the stack at traps." },
2763 { SCM_OPTION_BOOLEAN
, "breakpoints", 0, "*Check for breakpoints." },
2764 { SCM_OPTION_BOOLEAN
, "trace", 0, "*Trace mode." },
2765 { SCM_OPTION_BOOLEAN
, "procnames", 1,
2766 "Record procedure names at definition." },
2767 { SCM_OPTION_BOOLEAN
, "backwards", 0,
2768 "Display backtrace in anti-chronological order." },
2769 { SCM_OPTION_INTEGER
, "width", 79, "Maximal width of backtrace." },
2770 { SCM_OPTION_INTEGER
, "indent", 10, "Maximal indentation in backtrace." },
2771 { SCM_OPTION_INTEGER
, "frames", 3,
2772 "Maximum number of tail-recursive frames in backtrace." },
2773 { SCM_OPTION_INTEGER
, "maxdepth", 1000,
2774 "Maximal number of stored backtrace frames." },
2775 { SCM_OPTION_INTEGER
, "depth", 20, "Maximal length of printed backtrace." },
2776 { SCM_OPTION_BOOLEAN
, "backtrace", 0, "Show backtrace on error." },
2777 { SCM_OPTION_BOOLEAN
, "debug", 0, "Use the debugging evaluator." },
2778 { SCM_OPTION_INTEGER
, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
2779 { 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."}
2782 scm_t_option scm_evaluator_trap_table
[] = {
2783 { SCM_OPTION_BOOLEAN
, "traps", 0, "Enable evaluator traps." },
2784 { SCM_OPTION_BOOLEAN
, "enter-frame", 0, "Trap when eval enters new frame." },
2785 { SCM_OPTION_BOOLEAN
, "apply-frame", 0, "Trap when entering apply." },
2786 { SCM_OPTION_BOOLEAN
, "exit-frame", 0, "Trap when exiting eval or apply." },
2787 { SCM_OPTION_SCM
, "enter-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for enter-frame traps." },
2788 { SCM_OPTION_SCM
, "apply-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for apply-frame traps." },
2789 { SCM_OPTION_SCM
, "exit-frame-handler", (unsigned long)SCM_BOOL_F
, "Handler for exit-frame traps." }
2792 SCM_DEFINE (scm_eval_options_interface
, "eval-options-interface", 0, 1, 0,
2794 "Option interface for the evaluation options. Instead of using\n"
2795 "this procedure directly, use the procedures @code{eval-enable},\n"
2796 "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
2797 #define FUNC_NAME s_scm_eval_options_interface
2801 ans
= scm_options (setting
,
2805 scm_eval_stack
= SCM_EVAL_STACK
* sizeof (void *);
2812 SCM_DEFINE (scm_evaluator_traps
, "evaluator-traps-interface", 0, 1, 0,
2814 "Option interface for the evaluator trap options.")
2815 #define FUNC_NAME s_scm_evaluator_traps
2819 ans
= scm_options (setting
,
2820 scm_evaluator_trap_table
,
2821 SCM_N_EVALUATOR_TRAPS
,
2823 SCM_RESET_DEBUG_MODE
;
2831 deval_args (SCM l
, SCM env
, SCM proc
, SCM
*lloc
)
2833 SCM
*results
= lloc
;
2834 while (SCM_CONSP (l
))
2836 const SCM res
= EVALCAR (l
, env
);
2838 *lloc
= scm_list_1 (res
);
2839 lloc
= SCM_CDRLOC (*lloc
);
2843 scm_wrong_num_args (proc
);
2850 /* SECTION: This code is compiled twice.
2854 /* Update the toplevel environment frame ENV so that it refers to the
2855 * current module. */
2856 #define UPDATE_TOPLEVEL_ENV(env) \
2858 SCM p = scm_current_module_lookup_closure (); \
2859 if (p != SCM_CAR (env)) \
2860 env = scm_top_level_env (p); \
2864 #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2865 ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2868 /* This is the evaluator. Like any real monster, it has three heads:
2870 * ceval is the non-debugging evaluator, deval is the debugging version. Both
2871 * are implemented using a common code base, using the following mechanism:
2872 * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
2873 * is no function CEVAL, but the code for CEVAL actually compiles to either
2874 * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
2875 * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
2876 * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
2877 * are enclosed within #ifdef DEVAL ... #endif.
2879 * All three (ceval, deval and their common implementation CEVAL) take two
2880 * input parameters, x and env: x is a single expression to be evalutated.
2881 * env is the environment in which bindings are searched.
2883 * x is known to be a pair. Since x is a single expression, it is necessarily
2884 * in a tail position. If x is just a call to another function like in the
2885 * expression (foo exp1 exp2 ...), the realization of that call therefore
2886 * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
2887 * however, may do so). This is realized by making extensive use of 'goto'
2888 * statements within the evaluator: The gotos replace recursive calls to
2889 * CEVAL, thus re-using the same stack frame that CEVAL was already using.
2890 * If, however, x represents some form that requires to evaluate a sequence of
2891 * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
2892 * performed for all but the last expression of that sequence. */
2895 CEVAL (SCM x
, SCM env
)
2899 scm_t_debug_frame debug
;
2900 scm_t_debug_info
*debug_info_end
;
2901 debug
.prev
= scm_last_debug_frame
;
2904 * The debug.vect contains twice as much scm_t_debug_info frames as the
2905 * user has specified with (debug-set! frames <n>).
2907 * Even frames are eval frames, odd frames are apply frames.
2909 debug
.vect
= (scm_t_debug_info
*) alloca (scm_debug_eframe_size
2910 * sizeof (scm_t_debug_info
));
2911 debug
.info
= debug
.vect
;
2912 debug_info_end
= debug
.vect
+ scm_debug_eframe_size
;
2913 scm_last_debug_frame
= &debug
;
2915 #ifdef EVAL_STACK_CHECKING
2916 if (scm_stack_checking_enabled_p
&& SCM_STACK_OVERFLOW_P (&proc
))
2919 debug
.info
->e
.exp
= x
;
2920 debug
.info
->e
.env
= env
;
2922 scm_report_stack_overflow ();
2932 SCM_CLEAR_ARGSREADY (debug
);
2933 if (SCM_OVERFLOWP (debug
))
2936 * In theory, this should be the only place where it is necessary to
2937 * check for space in debug.vect since both eval frames and
2938 * available space are even.
2940 * For this to be the case, however, it is necessary that primitive
2941 * special forms which jump back to `loop', `begin' or some similar
2942 * label call PREP_APPLY.
2944 else if (++debug
.info
>= debug_info_end
)
2946 SCM_SET_OVERFLOW (debug
);
2951 debug
.info
->e
.exp
= x
;
2952 debug
.info
->e
.env
= env
;
2953 if (scm_check_entry_p
&& SCM_TRAPS_P
)
2955 if (SCM_ENTER_FRAME_P
2956 || (SCM_BREAKPOINTS_P
&& scm_c_source_property_breakpoint_p (x
)))
2959 SCM tail
= SCM_BOOL (SCM_TAILRECP (debug
));
2960 SCM_SET_TAILREC (debug
);
2961 if (SCM_CHEAPTRAPS_P
)
2962 stackrep
= scm_make_debugobj (&debug
);
2966 SCM val
= scm_make_continuation (&first
);
2976 /* This gives the possibility for the debugger to
2977 modify the source expression before evaluation. */
2982 scm_call_4 (SCM_ENTER_FRAME_HDLR
,
2983 scm_sym_enter_frame
,
2986 scm_unmemocopy (x
, env
));
2993 if (SCM_ISYMP (SCM_CAR (x
)))
2995 switch (ISYMNUM (SCM_CAR (x
)))
2997 case (ISYMNUM (SCM_IM_AND
)):
2999 while (!SCM_NULLP (SCM_CDR (x
)))
3001 SCM test_result
= EVALCAR (x
, env
);
3002 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3003 RETURN (SCM_BOOL_F
);
3007 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3010 case (ISYMNUM (SCM_IM_BEGIN
)):
3013 RETURN (SCM_UNSPECIFIED
);
3015 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3018 /* If we are on toplevel with a lookup closure, we need to sync
3019 with the current module. */
3020 if (SCM_CONSP (env
) && !SCM_CONSP (SCM_CAR (env
)))
3022 UPDATE_TOPLEVEL_ENV (env
);
3023 while (!SCM_NULLP (SCM_CDR (x
)))
3026 UPDATE_TOPLEVEL_ENV (env
);
3032 goto nontoplevel_begin
;
3035 while (!SCM_NULLP (SCM_CDR (x
)))
3037 const SCM form
= SCM_CAR (x
);
3040 if (SCM_ISYMP (form
))
3042 scm_rec_mutex_lock (&source_mutex
);
3043 /* check for race condition */
3044 if (SCM_ISYMP (SCM_CAR (x
)))
3045 m_expand_body (x
, env
);
3046 scm_rec_mutex_unlock (&source_mutex
);
3047 goto nontoplevel_begin
;
3050 SCM_VALIDATE_NON_EMPTY_COMBINATION (form
);
3053 (void) EVAL (form
, env
);
3059 /* scm_eval last form in list */
3060 const SCM last_form
= SCM_CAR (x
);
3062 if (SCM_CONSP (last_form
))
3064 /* This is by far the most frequent case. */
3066 goto loop
; /* tail recurse */
3068 else if (SCM_IMP (last_form
))
3069 RETURN (SCM_EVALIM (last_form
, env
));
3070 else if (SCM_VARIABLEP (last_form
))
3071 RETURN (SCM_VARIABLE_REF (last_form
));
3072 else if (SCM_SYMBOLP (last_form
))
3073 RETURN (*scm_lookupcar (x
, env
, 1));
3079 case (ISYMNUM (SCM_IM_CASE
)):
3082 const SCM key
= EVALCAR (x
, env
);
3084 while (!SCM_NULLP (x
))
3086 const SCM clause
= SCM_CAR (x
);
3087 SCM labels
= SCM_CAR (clause
);
3088 if (SCM_EQ_P (labels
, SCM_IM_ELSE
))
3090 x
= SCM_CDR (clause
);
3091 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3094 while (!SCM_NULLP (labels
))
3096 const SCM label
= SCM_CAR (labels
);
3097 if (SCM_EQ_P (label
, key
)
3098 || !SCM_FALSEP (scm_eqv_p (label
, key
)))
3100 x
= SCM_CDR (clause
);
3101 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3104 labels
= SCM_CDR (labels
);
3109 RETURN (SCM_UNSPECIFIED
);
3112 case (ISYMNUM (SCM_IM_COND
)):
3114 while (!SCM_NULLP (x
))
3116 const SCM clause
= SCM_CAR (x
);
3117 if (SCM_EQ_P (SCM_CAR (clause
), SCM_IM_ELSE
))
3119 x
= SCM_CDR (clause
);
3120 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3125 arg1
= EVALCAR (clause
, env
);
3126 if (!SCM_FALSEP (arg1
) && !SCM_NILP (arg1
))
3128 x
= SCM_CDR (clause
);
3131 else if (!SCM_EQ_P (SCM_CAR (x
), SCM_IM_ARROW
))
3133 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3139 proc
= EVALCAR (proc
, env
);
3140 PREP_APPLY (proc
, scm_list_1 (arg1
));
3148 RETURN (SCM_UNSPECIFIED
);
3151 case (ISYMNUM (SCM_IM_DO
)):
3154 /* Compute the initialization values and the initial environment. */
3155 SCM init_forms
= SCM_CAR (x
);
3156 SCM init_values
= SCM_EOL
;
3157 while (!SCM_NULLP (init_forms
))
3159 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3160 init_forms
= SCM_CDR (init_forms
);
3163 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3167 SCM test_form
= SCM_CAR (x
);
3168 SCM body_forms
= SCM_CADR (x
);
3169 SCM step_forms
= SCM_CDDR (x
);
3171 SCM test_result
= EVALCAR (test_form
, env
);
3173 while (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3176 /* Evaluate body forms. */
3178 for (temp_forms
= body_forms
;
3179 !SCM_NULLP (temp_forms
);
3180 temp_forms
= SCM_CDR (temp_forms
))
3182 SCM form
= SCM_CAR (temp_forms
);
3183 /* Dirk:FIXME: We only need to eval forms that may have
3184 * a side effect here. This is only true for forms that
3185 * start with a pair. All others are just constants.
3186 * Since with the current memoizer 'form' may hold a
3187 * constant, we call EVAL here to handle the constant
3188 * cases. In the long run it would make sense to have
3189 * the macro transformer of 'do' eliminate all forms
3190 * that have no sideeffect. Then instead of EVAL we
3191 * could call CEVAL directly here. */
3192 (void) EVAL (form
, env
);
3197 /* Evaluate the step expressions. */
3199 SCM step_values
= SCM_EOL
;
3200 for (temp_forms
= step_forms
;
3201 !SCM_NULLP (temp_forms
);
3202 temp_forms
= SCM_CDR (temp_forms
))
3204 const SCM value
= EVALCAR (temp_forms
, env
);
3205 step_values
= scm_cons (value
, step_values
);
3207 env
= SCM_EXTEND_ENV (SCM_CAAR (env
),
3212 test_result
= EVALCAR (test_form
, env
);
3217 RETURN (SCM_UNSPECIFIED
);
3218 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3219 goto nontoplevel_begin
;
3222 case (ISYMNUM (SCM_IM_IF
)):
3225 SCM test_result
= EVALCAR (x
, env
);
3226 x
= SCM_CDR (x
); /* then expression */
3227 if (SCM_FALSEP (test_result
) || SCM_NILP (test_result
))
3229 x
= SCM_CDR (x
); /* else expression */
3231 RETURN (SCM_UNSPECIFIED
);
3234 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3238 case (ISYMNUM (SCM_IM_LET
)):
3241 SCM init_forms
= SCM_CADR (x
);
3242 SCM init_values
= SCM_EOL
;
3245 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3246 init_forms
= SCM_CDR (init_forms
);
3248 while (!SCM_NULLP (init_forms
));
3249 env
= SCM_EXTEND_ENV (SCM_CAR (x
), init_values
, env
);
3252 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3253 goto nontoplevel_begin
;
3256 case (ISYMNUM (SCM_IM_LETREC
)):
3258 env
= SCM_EXTEND_ENV (SCM_CAR (x
), undefineds
, env
);
3261 SCM init_forms
= SCM_CAR (x
);
3262 SCM init_values
= SCM_EOL
;
3265 init_values
= scm_cons (EVALCAR (init_forms
, env
), init_values
);
3266 init_forms
= SCM_CDR (init_forms
);
3268 while (!SCM_NULLP (init_forms
));
3269 SCM_SETCDR (SCM_CAR (env
), init_values
);
3272 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3273 goto nontoplevel_begin
;
3276 case (ISYMNUM (SCM_IM_LETSTAR
)):
3279 SCM bindings
= SCM_CAR (x
);
3280 if (SCM_NULLP (bindings
))
3281 env
= SCM_EXTEND_ENV (SCM_EOL
, SCM_EOL
, env
);
3286 SCM name
= SCM_CAR (bindings
);
3287 SCM init
= SCM_CDR (bindings
);
3288 env
= SCM_EXTEND_ENV (name
, EVALCAR (init
, env
), env
);
3289 bindings
= SCM_CDR (init
);
3291 while (!SCM_NULLP (bindings
));
3295 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3296 goto nontoplevel_begin
;
3299 case (ISYMNUM (SCM_IM_OR
)):
3301 while (!SCM_NULLP (SCM_CDR (x
)))
3303 SCM val
= EVALCAR (x
, env
);
3304 if (!SCM_FALSEP (val
) && !SCM_NILP (val
))
3309 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3313 case (ISYMNUM (SCM_IM_LAMBDA
)):
3314 RETURN (scm_closure (SCM_CDR (x
), env
));
3317 case (ISYMNUM (SCM_IM_QUOTE
)):
3318 RETURN (SCM_CADR (x
));
3321 case (ISYMNUM (SCM_IM_SET_X
)):
3325 SCM variable
= SCM_CAR (x
);
3326 if (SCM_ILOCP (variable
))
3327 location
= scm_ilookup (variable
, env
);
3328 else if (SCM_VARIABLEP (variable
))
3329 location
= SCM_VARIABLE_LOC (variable
);
3330 else /* (SCM_SYMBOLP (variable)) is known to be true */
3331 location
= scm_lookupcar (x
, env
, 1);
3333 *location
= EVALCAR (x
, env
);
3335 RETURN (SCM_UNSPECIFIED
);
3338 case (ISYMNUM (SCM_IM_APPLY
)):
3339 /* Evaluate the procedure to be applied. */
3341 proc
= EVALCAR (x
, env
);
3342 PREP_APPLY (proc
, SCM_EOL
);
3344 /* Evaluate the argument holding the list of arguments */
3346 arg1
= EVALCAR (x
, env
);
3349 /* Go here to tail-apply a procedure. PROC is the procedure and
3350 * ARG1 is the list of arguments. PREP_APPLY must have been called
3351 * before jumping to apply_proc. */
3352 if (SCM_CLOSUREP (proc
))
3354 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3356 debug
.info
->a
.args
= arg1
;
3358 if (scm_badargsp (formals
, arg1
))
3359 scm_wrong_num_args (proc
);
3361 /* Copy argument list */
3362 if (SCM_NULL_OR_NIL_P (arg1
))
3363 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3366 SCM args
= scm_list_1 (SCM_CAR (arg1
));
3368 arg1
= SCM_CDR (arg1
);
3369 while (!SCM_NULL_OR_NIL_P (arg1
))
3371 SCM new_tail
= scm_list_1 (SCM_CAR (arg1
));
3372 SCM_SETCDR (tail
, new_tail
);
3374 arg1
= SCM_CDR (arg1
);
3376 env
= SCM_EXTEND_ENV (formals
, args
, SCM_ENV (proc
));
3379 x
= SCM_CLOSURE_BODY (proc
);
3380 goto nontoplevel_begin
;
3385 RETURN (SCM_APPLY (proc
, arg1
, SCM_EOL
));
3389 case (ISYMNUM (SCM_IM_CONT
)):
3392 SCM val
= scm_make_continuation (&first
);
3400 proc
= EVALCAR (proc
, env
);
3401 PREP_APPLY (proc
, scm_list_1 (arg1
));
3408 case (ISYMNUM (SCM_IM_DELAY
)):
3409 RETURN (scm_makprom (scm_closure (SCM_CDR (x
), env
)));
3412 case (ISYMNUM (SCM_IM_FUTURE
)):
3413 RETURN (scm_i_make_future (scm_closure (SCM_CDR (x
), env
)));
3416 /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
3417 code (type_dispatch) is intended to be the tail of the case
3418 clause for the internal macro SCM_IM_DISPATCH. Please don't
3419 remove it from this location without discussing it with Mikael
3420 <djurfeldt@nada.kth.se> */
3422 /* The type dispatch code is duplicated below
3423 * (c.f. objects.c:scm_mcache_compute_cmethod) since that
3424 * cuts down execution time for type dispatch to 50%. */
3425 type_dispatch
: /* inputs: x, arg1 */
3426 /* Type dispatch means to determine from the types of the function
3427 * arguments (i. e. the 'signature' of the call), which method from
3428 * a generic function is to be called. This process of selecting
3429 * the right method takes some time. To speed it up, guile uses
3430 * caching: Together with the macro call to dispatch the signatures
3431 * of some previous calls to that generic function from the same
3432 * place are stored (in the code!) in a cache that we call the
3433 * 'method cache'. This is done since it is likely, that
3434 * consecutive calls to dispatch from that position in the code will
3435 * have the same signature. Thus, the type dispatch works as
3436 * follows: First, determine a hash value from the signature of the
3437 * actual arguments. Second, use this hash value as an index to
3438 * find that same signature in the method cache stored at this
3439 * position in the code. If found, you have also found the
3440 * corresponding method that belongs to that signature. If the
3441 * signature is not found in the method cache, you have to perform a
3442 * full search over all signatures stored with the generic
3445 unsigned long int specializers
;
3446 unsigned long int hash_value
;
3447 unsigned long int cache_end_pos
;
3448 unsigned long int mask
;
3452 SCM z
= SCM_CDDR (x
);
3453 SCM tmp
= SCM_CADR (z
);
3454 specializers
= SCM_INUM (SCM_CAR (z
));
3456 /* Compute a hash value for searching the method cache. There
3457 * are two variants for computing the hash value, a (rather)
3458 * complicated one, and a simple one. For the complicated one
3459 * explained below, tmp holds a number that is used in the
3461 if (SCM_INUMP (tmp
))
3463 /* Use the signature of the actual arguments to determine
3464 * the hash value. This is done as follows: Each class has
3465 * an array of random numbers, that are determined when the
3466 * class is created. The integer 'hashset' is an index into
3467 * that array of random numbers. Now, from all classes that
3468 * are part of the signature of the actual arguments, the
3469 * random numbers at index 'hashset' are taken and summed
3470 * up, giving the hash value. The value of 'hashset' is
3471 * stored at the call to dispatch. This allows to have
3472 * different 'formulas' for calculating the hash value at
3473 * different places where dispatch is called. This allows
3474 * to optimize the hash formula at every individual place
3475 * where dispatch is called, such that hopefully the hash
3476 * value that is computed will directly point to the right
3477 * method in the method cache. */
3478 unsigned long int hashset
= SCM_INUM (tmp
);
3479 unsigned long int counter
= specializers
+ 1;
3482 while (!SCM_NULLP (tmp_arg
) && counter
!= 0)
3484 SCM
class = scm_class_of (SCM_CAR (tmp_arg
));
3485 hash_value
+= SCM_INSTANCE_HASH (class, hashset
);
3486 tmp_arg
= SCM_CDR (tmp_arg
);
3490 method_cache
= SCM_CADR (z
);
3491 mask
= SCM_INUM (SCM_CAR (z
));
3493 cache_end_pos
= hash_value
;
3497 /* This method of determining the hash value is much
3498 * simpler: Set the hash value to zero and just perform a
3499 * linear search through the method cache. */
3501 mask
= (unsigned long int) ((long) -1);
3503 cache_end_pos
= SCM_VECTOR_LENGTH (method_cache
);
3508 /* Search the method cache for a method with a matching
3509 * signature. Start the search at position 'hash_value'. The
3510 * hashing implementation uses linear probing for conflict
3511 * resolution, that is, if the signature in question is not
3512 * found at the starting index in the hash table, the next table
3513 * entry is tried, and so on, until in the worst case the whole
3514 * cache has been searched, but still the signature has not been
3519 SCM args
= arg1
; /* list of arguments */
3520 z
= SCM_VELTS (method_cache
)[hash_value
];
3521 while (!SCM_NULLP (args
))
3523 /* More arguments than specifiers => CLASS != ENV */
3524 SCM class_of_arg
= scm_class_of (SCM_CAR (args
));
3525 if (!SCM_EQ_P (class_of_arg
, SCM_CAR (z
)))
3527 args
= SCM_CDR (args
);
3530 /* Fewer arguments than specifiers => CAR != ENV */
3531 if (SCM_NULLP (SCM_CAR (z
)) || SCM_CONSP (SCM_CAR (z
)))
3534 hash_value
= (hash_value
+ 1) & mask
;
3535 } while (hash_value
!= cache_end_pos
);
3537 /* No appropriate method was found in the cache. */
3538 z
= scm_memoize_method (x
, arg1
);
3540 apply_cmethod
: /* inputs: z, arg1 */
3542 SCM formals
= SCM_CMETHOD_FORMALS (z
);
3543 env
= SCM_EXTEND_ENV (formals
, arg1
, SCM_CMETHOD_ENV (z
));
3544 x
= SCM_CMETHOD_BODY (z
);
3545 goto nontoplevel_begin
;
3551 case (ISYMNUM (SCM_IM_SLOT_REF
)):
3554 SCM instance
= EVALCAR (x
, env
);
3555 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3556 RETURN (SCM_PACK (SCM_STRUCT_DATA (instance
) [slot
]));
3560 case (ISYMNUM (SCM_IM_SLOT_SET_X
)):
3563 SCM instance
= EVALCAR (x
, env
);
3564 unsigned long int slot
= SCM_INUM (SCM_CADR (x
));
3565 SCM value
= EVALCAR (SCM_CDDR (x
), env
);
3566 SCM_STRUCT_DATA (instance
) [slot
] = SCM_UNPACK (value
);
3567 RETURN (SCM_UNSPECIFIED
);
3571 #if SCM_ENABLE_ELISP
3573 case (ISYMNUM (SCM_IM_NIL_COND
)):
3575 SCM test_form
= SCM_CDR (x
);
3576 x
= SCM_CDR (test_form
);
3577 while (!SCM_NULL_OR_NIL_P (x
))
3579 SCM test_result
= EVALCAR (test_form
, env
);
3580 if (!(SCM_FALSEP (test_result
)
3581 || SCM_NULL_OR_NIL_P (test_result
)))
3583 if (SCM_EQ_P (SCM_CAR (x
), SCM_UNSPECIFIED
))
3584 RETURN (test_result
);
3585 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3590 test_form
= SCM_CDR (x
);
3591 x
= SCM_CDR (test_form
);
3595 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3599 #endif /* SCM_ENABLE_ELISP */
3601 case (ISYMNUM (SCM_IM_BIND
)):
3603 SCM vars
, exps
, vals
;
3606 vars
= SCM_CAAR (x
);
3607 exps
= SCM_CDAR (x
);
3609 while (!SCM_NULLP (exps
))
3611 vals
= scm_cons (EVALCAR (exps
, env
), vals
);
3612 exps
= SCM_CDR (exps
);
3615 scm_swap_bindings (vars
, vals
);
3616 scm_dynwinds
= scm_acons (vars
, vals
, scm_dynwinds
);
3618 /* Ignore all but the last evaluation result. */
3619 for (x
= SCM_CDR (x
); !SCM_NULLP (SCM_CDR (x
)); x
= SCM_CDR (x
))
3621 if (SCM_CONSP (SCM_CAR (x
)))
3622 CEVAL (SCM_CAR (x
), env
);
3624 proc
= EVALCAR (x
, env
);
3626 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
3627 scm_swap_bindings (vars
, vals
);
3633 case (ISYMNUM (SCM_IM_CALL_WITH_VALUES
)):
3638 producer
= EVALCAR (x
, env
);
3640 proc
= EVALCAR (x
, env
); /* proc is the consumer. */
3641 arg1
= SCM_APPLY (producer
, SCM_EOL
, SCM_EOL
);
3642 if (SCM_VALUESP (arg1
))
3644 /* The list of arguments is not copied. Rather, it is assumed
3645 * that this has been done by the 'values' procedure. */
3646 arg1
= scm_struct_ref (arg1
, SCM_INUM0
);
3650 arg1
= scm_list_1 (arg1
);
3652 PREP_APPLY (proc
, arg1
);
3663 if (SCM_VARIABLEP (SCM_CAR (x
)))
3664 proc
= SCM_VARIABLE_REF (SCM_CAR (x
));
3665 else if (SCM_ILOCP (SCM_CAR (x
)))
3666 proc
= *scm_ilookup (SCM_CAR (x
), env
);
3667 else if (SCM_CONSP (SCM_CAR (x
)))
3668 proc
= CEVAL (SCM_CAR (x
), env
);
3669 else if (SCM_SYMBOLP (SCM_CAR (x
)))
3671 SCM orig_sym
= SCM_CAR (x
);
3673 SCM
*location
= scm_lookupcar1 (x
, env
, 1);
3674 if (location
== NULL
)
3676 /* we have lost the race, start again. */
3682 if (SCM_MACROP (proc
))
3684 SCM_SETCAR (x
, orig_sym
); /* Undo memoizing effect of
3686 handle_a_macro
: /* inputs: x, env, proc */
3688 /* Set a flag during macro expansion so that macro
3689 application frames can be deleted from the backtrace. */
3690 SCM_SET_MACROEXP (debug
);
3692 arg1
= SCM_APPLY (SCM_MACRO_CODE (proc
), x
,
3693 scm_cons (env
, scm_listofnull
));
3695 SCM_CLEAR_MACROEXP (debug
);
3697 switch (SCM_MACRO_TYPE (proc
))
3701 if (scm_ilength (arg1
) <= 0)
3702 arg1
= scm_list_2 (SCM_IM_BEGIN
, arg1
);
3704 if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc
)))
3707 SCM_SETCAR (x
, SCM_CAR (arg1
));
3708 SCM_SETCDR (x
, SCM_CDR (arg1
));
3712 /* Prevent memoizing of debug info expression. */
3713 debug
.info
->e
.exp
= scm_cons_source (debug
.info
->e
.exp
,
3718 SCM_SETCAR (x
, SCM_CAR (arg1
));
3719 SCM_SETCDR (x
, SCM_CDR (arg1
));
3721 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3723 #if SCM_ENABLE_DEPRECATED == 1
3728 PREP_APPLY (SCM_UNDEFINED
, SCM_EOL
);
3742 if (SCM_MACROP (proc
))
3743 goto handle_a_macro
;
3747 /* When reaching this part of the code, the following is granted: Variable x
3748 * holds the first pair of an expression of the form (<function> arg ...).
3749 * Variable proc holds the object that resulted from the evaluation of
3750 * <function>. In the following, the arguments (if any) will be evaluated,
3751 * and proc will be applied to them. If proc does not really hold a
3752 * function object, this will be signalled as an error on the scheme
3753 * level. If the number of arguments does not match the number of arguments
3754 * that are allowed to be passed to proc, also an error on the scheme level
3755 * will be signalled. */
3756 PREP_APPLY (proc
, SCM_EOL
);
3757 if (SCM_NULLP (SCM_CDR (x
))) {
3760 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3761 switch (SCM_TYP7 (proc
))
3762 { /* no arguments given */
3763 case scm_tc7_subr_0
:
3764 RETURN (SCM_SUBRF (proc
) ());
3765 case scm_tc7_subr_1o
:
3766 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
));
3768 RETURN (SCM_SUBRF (proc
) (SCM_EOL
));
3769 case scm_tc7_rpsubr
:
3770 RETURN (SCM_BOOL_T
);
3772 RETURN (SCM_SUBRF (proc
) (SCM_UNDEFINED
, SCM_UNDEFINED
));
3774 if (!SCM_SMOB_APPLICABLE_P (proc
))
3776 RETURN (SCM_SMOB_APPLY_0 (proc
));
3779 proc
= SCM_CCLO_SUBR (proc
);
3781 debug
.info
->a
.proc
= proc
;
3782 debug
.info
->a
.args
= scm_list_1 (arg1
);
3786 proc
= SCM_PROCEDURE (proc
);
3788 debug
.info
->a
.proc
= proc
;
3790 if (!SCM_CLOSUREP (proc
))
3793 case scm_tcs_closures
:
3795 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3796 if (SCM_CONSP (formals
))
3797 goto umwrongnumargs
;
3798 x
= SCM_CLOSURE_BODY (proc
);
3799 env
= SCM_EXTEND_ENV (formals
, SCM_EOL
, SCM_ENV (proc
));
3800 goto nontoplevel_begin
;
3802 case scm_tcs_struct
:
3803 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3805 x
= SCM_ENTITY_PROCEDURE (proc
);
3809 else if (SCM_I_OPERATORP (proc
))
3812 proc
= (SCM_I_ENTITYP (proc
)
3813 ? SCM_ENTITY_PROCEDURE (proc
)
3814 : SCM_OPERATOR_PROCEDURE (proc
));
3816 debug
.info
->a
.proc
= proc
;
3817 debug
.info
->a
.args
= scm_list_1 (arg1
);
3823 case scm_tc7_subr_1
:
3824 case scm_tc7_subr_2
:
3825 case scm_tc7_subr_2o
:
3828 case scm_tc7_subr_3
:
3829 case scm_tc7_lsubr_2
:
3832 scm_wrong_num_args (proc
);
3835 scm_misc_error (NULL
, "Wrong type to apply: ~S", scm_list_1 (proc
));
3839 /* must handle macros by here */
3842 arg1
= EVALCAR (x
, env
);
3844 scm_wrong_num_args (proc
);
3846 debug
.info
->a
.args
= scm_list_1 (arg1
);
3854 evap1
: /* inputs: proc, arg1 */
3855 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3856 switch (SCM_TYP7 (proc
))
3857 { /* have one argument in arg1 */
3858 case scm_tc7_subr_2o
:
3859 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3860 case scm_tc7_subr_1
:
3861 case scm_tc7_subr_1o
:
3862 RETURN (SCM_SUBRF (proc
) (arg1
));
3864 if (SCM_INUMP (arg1
))
3866 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
3868 else if (SCM_REALP (arg1
))
3870 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
3872 else if (SCM_BIGP (arg1
))
3874 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
3876 else if (SCM_FRACTIONP (arg1
))
3878 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
3880 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
3881 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3884 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
3887 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
3888 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
3889 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
3894 case scm_tc7_rpsubr
:
3895 RETURN (SCM_BOOL_T
);
3897 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
3900 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
3902 RETURN (SCM_SUBRF (proc
) (scm_list_1 (arg1
)));
3905 if (!SCM_SMOB_APPLICABLE_P (proc
))
3907 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
3911 proc
= SCM_CCLO_SUBR (proc
);
3913 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3914 debug
.info
->a
.proc
= proc
;
3918 proc
= SCM_PROCEDURE (proc
);
3920 debug
.info
->a
.proc
= proc
;
3922 if (!SCM_CLOSUREP (proc
))
3925 case scm_tcs_closures
:
3928 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
3929 if (SCM_NULLP (formals
)
3930 || (SCM_CONSP (formals
) && SCM_CONSP (SCM_CDR (formals
))))
3931 goto umwrongnumargs
;
3932 x
= SCM_CLOSURE_BODY (proc
);
3934 env
= SCM_EXTEND_ENV (formals
,
3938 env
= SCM_EXTEND_ENV (formals
,
3942 goto nontoplevel_begin
;
3944 case scm_tcs_struct
:
3945 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
3947 x
= SCM_ENTITY_PROCEDURE (proc
);
3949 arg1
= debug
.info
->a
.args
;
3951 arg1
= scm_list_1 (arg1
);
3955 else if (SCM_I_OPERATORP (proc
))
3959 proc
= (SCM_I_ENTITYP (proc
)
3960 ? SCM_ENTITY_PROCEDURE (proc
)
3961 : SCM_OPERATOR_PROCEDURE (proc
));
3963 debug
.info
->a
.args
= scm_cons (arg1
, debug
.info
->a
.args
);
3964 debug
.info
->a
.proc
= proc
;
3970 case scm_tc7_subr_2
:
3971 case scm_tc7_subr_0
:
3972 case scm_tc7_subr_3
:
3973 case scm_tc7_lsubr_2
:
3974 scm_wrong_num_args (proc
);
3980 arg2
= EVALCAR (x
, env
);
3982 scm_wrong_num_args (proc
);
3984 { /* have two or more arguments */
3986 debug
.info
->a
.args
= scm_list_2 (arg1
, arg2
);
3989 if (SCM_NULLP (x
)) {
3992 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
3993 switch (SCM_TYP7 (proc
))
3994 { /* have two arguments */
3995 case scm_tc7_subr_2
:
3996 case scm_tc7_subr_2o
:
3997 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4000 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4002 RETURN (SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
)));
4004 case scm_tc7_lsubr_2
:
4005 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
));
4006 case scm_tc7_rpsubr
:
4008 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
));
4010 if (!SCM_SMOB_APPLICABLE_P (proc
))
4012 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, arg2
));
4016 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4017 scm_cons (proc
, debug
.info
->a
.args
),
4020 RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc
),
4021 scm_cons2 (proc
, arg1
,
4028 case scm_tcs_struct
:
4029 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4031 x
= SCM_ENTITY_PROCEDURE (proc
);
4033 arg1
= debug
.info
->a
.args
;
4035 arg1
= scm_list_2 (arg1
, arg2
);
4039 else if (SCM_I_OPERATORP (proc
))
4043 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4044 ? SCM_ENTITY_PROCEDURE (proc
)
4045 : SCM_OPERATOR_PROCEDURE (proc
),
4046 scm_cons (proc
, debug
.info
->a
.args
),
4049 RETURN (SCM_APPLY (SCM_I_ENTITYP (proc
)
4050 ? SCM_ENTITY_PROCEDURE (proc
)
4051 : SCM_OPERATOR_PROCEDURE (proc
),
4052 scm_cons2 (proc
, arg1
,
4062 case scm_tc7_subr_0
:
4065 case scm_tc7_subr_1o
:
4066 case scm_tc7_subr_1
:
4067 case scm_tc7_subr_3
:
4068 scm_wrong_num_args (proc
);
4072 proc
= SCM_PROCEDURE (proc
);
4074 debug
.info
->a
.proc
= proc
;
4076 if (!SCM_CLOSUREP (proc
))
4079 case scm_tcs_closures
:
4082 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4083 if (SCM_NULLP (formals
)
4084 || (SCM_CONSP (formals
)
4085 && (SCM_NULLP (SCM_CDR (formals
))
4086 || (SCM_CONSP (SCM_CDR (formals
))
4087 && SCM_CONSP (SCM_CDDR (formals
))))))
4088 goto umwrongnumargs
;
4090 env
= SCM_EXTEND_ENV (formals
,
4094 env
= SCM_EXTEND_ENV (formals
,
4095 scm_list_2 (arg1
, arg2
),
4098 x
= SCM_CLOSURE_BODY (proc
);
4099 goto nontoplevel_begin
;
4104 scm_wrong_num_args (proc
);
4106 debug
.info
->a
.args
= scm_cons2 (arg1
, arg2
,
4107 deval_args (x
, env
, proc
,
4108 SCM_CDRLOC (SCM_CDR (debug
.info
->a
.args
))));
4112 SCM_ASRTGO (!SCM_IMP (proc
), badfun
);
4113 switch (SCM_TYP7 (proc
))
4114 { /* have 3 or more arguments */
4116 case scm_tc7_subr_3
:
4117 if (!SCM_NULLP (SCM_CDR (x
)))
4118 scm_wrong_num_args (proc
);
4120 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4121 SCM_CADDR (debug
.info
->a
.args
)));
4123 arg1
= SCM_SUBRF(proc
)(arg1
, arg2
);
4124 arg2
= SCM_CDDR (debug
.info
->a
.args
);
4127 arg1
= SCM_SUBRF(proc
)(arg1
, SCM_CAR (arg2
));
4128 arg2
= SCM_CDR (arg2
);
4130 while (SCM_NIMP (arg2
));
4132 case scm_tc7_rpsubr
:
4133 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4134 RETURN (SCM_BOOL_F
);
4135 arg1
= SCM_CDDR (debug
.info
->a
.args
);
4138 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, SCM_CAR (arg1
))))
4139 RETURN (SCM_BOOL_F
);
4140 arg2
= SCM_CAR (arg1
);
4141 arg1
= SCM_CDR (arg1
);
4143 while (SCM_NIMP (arg1
));
4144 RETURN (SCM_BOOL_T
);
4145 case scm_tc7_lsubr_2
:
4146 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
,
4147 SCM_CDDR (debug
.info
->a
.args
)));
4149 RETURN (SCM_SUBRF (proc
) (debug
.info
->a
.args
));
4151 if (!SCM_SMOB_APPLICABLE_P (proc
))
4153 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4154 SCM_CDDR (debug
.info
->a
.args
)));
4158 proc
= SCM_PROCEDURE (proc
);
4159 debug
.info
->a
.proc
= proc
;
4160 if (!SCM_CLOSUREP (proc
))
4163 case scm_tcs_closures
:
4165 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4166 if (SCM_NULLP (formals
)
4167 || (SCM_CONSP (formals
)
4168 && (SCM_NULLP (SCM_CDR (formals
))
4169 || (SCM_CONSP (SCM_CDR (formals
))
4170 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4171 goto umwrongnumargs
;
4172 SCM_SET_ARGSREADY (debug
);
4173 env
= SCM_EXTEND_ENV (formals
,
4176 x
= SCM_CLOSURE_BODY (proc
);
4177 goto nontoplevel_begin
;
4180 case scm_tc7_subr_3
:
4181 if (!SCM_NULLP (SCM_CDR (x
)))
4182 scm_wrong_num_args (proc
);
4184 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, EVALCAR (x
, env
)));
4186 arg1
= SCM_SUBRF (proc
) (arg1
, arg2
);
4189 arg1
= SCM_SUBRF(proc
)(arg1
, EVALCAR(x
, env
));
4192 while (!SCM_NULLP (x
));
4194 case scm_tc7_rpsubr
:
4195 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, arg2
)))
4196 RETURN (SCM_BOOL_F
);
4199 arg1
= EVALCAR (x
, env
);
4200 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg2
, arg1
)))
4201 RETURN (SCM_BOOL_F
);
4205 while (!SCM_NULLP (x
));
4206 RETURN (SCM_BOOL_T
);
4207 case scm_tc7_lsubr_2
:
4208 RETURN (SCM_SUBRF (proc
) (arg1
, arg2
, scm_eval_args (x
, env
, proc
)));
4210 RETURN (SCM_SUBRF (proc
) (scm_cons2 (arg1
,
4212 scm_eval_args (x
, env
, proc
))));
4214 if (!SCM_SMOB_APPLICABLE_P (proc
))
4216 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, arg2
,
4217 scm_eval_args (x
, env
, proc
)));
4221 proc
= SCM_PROCEDURE (proc
);
4222 if (!SCM_CLOSUREP (proc
))
4225 case scm_tcs_closures
:
4227 const SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4228 if (SCM_NULLP (formals
)
4229 || (SCM_CONSP (formals
)
4230 && (SCM_NULLP (SCM_CDR (formals
))
4231 || (SCM_CONSP (SCM_CDR (formals
))
4232 && scm_badargsp (SCM_CDDR (formals
), x
)))))
4233 goto umwrongnumargs
;
4234 env
= SCM_EXTEND_ENV (formals
,
4237 scm_eval_args (x
, env
, proc
)),
4239 x
= SCM_CLOSURE_BODY (proc
);
4240 goto nontoplevel_begin
;
4243 case scm_tcs_struct
:
4244 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4247 arg1
= debug
.info
->a
.args
;
4249 arg1
= scm_cons2 (arg1
, arg2
, scm_eval_args (x
, env
, proc
));
4251 x
= SCM_ENTITY_PROCEDURE (proc
);
4254 else if (SCM_I_OPERATORP (proc
))
4258 case scm_tc7_subr_2
:
4259 case scm_tc7_subr_1o
:
4260 case scm_tc7_subr_2o
:
4261 case scm_tc7_subr_0
:
4264 case scm_tc7_subr_1
:
4265 scm_wrong_num_args (proc
);
4273 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4274 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4276 SCM_CLEAR_TRACED_FRAME (debug
);
4277 if (SCM_CHEAPTRAPS_P
)
4278 arg1
= scm_make_debugobj (&debug
);
4282 SCM val
= scm_make_continuation (&first
);
4293 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4297 scm_last_debug_frame
= debug
.prev
;
4303 /* SECTION: This code is compiled once.
4310 /* Simple procedure calls
4314 scm_call_0 (SCM proc
)
4316 return scm_apply (proc
, SCM_EOL
, SCM_EOL
);
4320 scm_call_1 (SCM proc
, SCM arg1
)
4322 return scm_apply (proc
, arg1
, scm_listofnull
);
4326 scm_call_2 (SCM proc
, SCM arg1
, SCM arg2
)
4328 return scm_apply (proc
, arg1
, scm_cons (arg2
, scm_listofnull
));
4332 scm_call_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
)
4334 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
, scm_listofnull
));
4338 scm_call_4 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM arg4
)
4340 return scm_apply (proc
, arg1
, scm_cons2 (arg2
, arg3
,
4341 scm_cons (arg4
, scm_listofnull
)));
4344 /* Simple procedure applies
4348 scm_apply_0 (SCM proc
, SCM args
)
4350 return scm_apply (proc
, args
, SCM_EOL
);
4354 scm_apply_1 (SCM proc
, SCM arg1
, SCM args
)
4356 return scm_apply (proc
, scm_cons (arg1
, args
), SCM_EOL
);
4360 scm_apply_2 (SCM proc
, SCM arg1
, SCM arg2
, SCM args
)
4362 return scm_apply (proc
, scm_cons2 (arg1
, arg2
, args
), SCM_EOL
);
4366 scm_apply_3 (SCM proc
, SCM arg1
, SCM arg2
, SCM arg3
, SCM args
)
4368 return scm_apply (proc
, scm_cons (arg1
, scm_cons2 (arg2
, arg3
, args
)),
4372 /* This code processes the arguments to apply:
4374 (apply PROC ARG1 ... ARGS)
4376 Given a list (ARG1 ... ARGS), this function conses the ARG1
4377 ... arguments onto the front of ARGS, and returns the resulting
4378 list. Note that ARGS is a list; thus, the argument to this
4379 function is a list whose last element is a list.
4381 Apply calls this function, and applies PROC to the elements of the
4382 result. apply:nconc2last takes care of building the list of
4383 arguments, given (ARG1 ... ARGS).
4385 Rather than do new consing, apply:nconc2last destroys its argument.
4386 On that topic, this code came into my care with the following
4387 beautifully cryptic comment on that topic: "This will only screw
4388 you if you do (scm_apply scm_apply '( ... ))" If you know what
4389 they're referring to, send me a patch to this comment. */
4391 SCM_DEFINE (scm_nconc2last
, "apply:nconc2last", 1, 0, 0,
4393 "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
4394 "conses the @var{arg1} @dots{} arguments onto the front of\n"
4395 "@var{args}, and returns the resulting list. Note that\n"
4396 "@var{args} is a list; thus, the argument to this function is\n"
4397 "a list whose last element is a list.\n"
4398 "Note: Rather than do new consing, @code{apply:nconc2last}\n"
4399 "destroys its argument, so use with care.")
4400 #define FUNC_NAME s_scm_nconc2last
4403 SCM_VALIDATE_NONEMPTYLIST (1, lst
);
4405 while (!SCM_NULLP (SCM_CDR (*lloc
))) /* Perhaps should be
4406 SCM_NULL_OR_NIL_P, but not
4407 needed in 99.99% of cases,
4408 and it could seriously hurt
4409 performance. - Neil */
4410 lloc
= SCM_CDRLOC (*lloc
);
4411 SCM_ASSERT (scm_ilength (SCM_CAR (*lloc
)) >= 0, lst
, SCM_ARG1
, FUNC_NAME
);
4412 *lloc
= SCM_CAR (*lloc
);
4420 /* SECTION: When DEVAL is defined this code yields scm_dapply.
4421 * It is compiled twice.
4426 scm_apply (SCM proc
, SCM arg1
, SCM args
)
4432 scm_dapply (SCM proc
, SCM arg1
, SCM args
)
4437 /* Apply a function to a list of arguments.
4439 This function is exported to the Scheme level as taking two
4440 required arguments and a tail argument, as if it were:
4441 (lambda (proc arg1 . args) ...)
4442 Thus, if you just have a list of arguments to pass to a procedure,
4443 pass the list as ARG1, and '() for ARGS. If you have some fixed
4444 args, pass the first as ARG1, then cons any remaining fixed args
4445 onto the front of your argument list, and pass that as ARGS. */
4448 SCM_APPLY (SCM proc
, SCM arg1
, SCM args
)
4451 scm_t_debug_frame debug
;
4452 scm_t_debug_info debug_vect_body
;
4453 debug
.prev
= scm_last_debug_frame
;
4454 debug
.status
= SCM_APPLYFRAME
;
4455 debug
.vect
= &debug_vect_body
;
4456 debug
.vect
[0].a
.proc
= proc
;
4457 debug
.vect
[0].a
.args
= SCM_EOL
;
4458 scm_last_debug_frame
= &debug
;
4460 if (scm_debug_mode_p
)
4461 return scm_dapply (proc
, arg1
, args
);
4464 SCM_ASRTGO (SCM_NIMP (proc
), badproc
);
4466 /* If ARGS is the empty list, then we're calling apply with only two
4467 arguments --- ARG1 is the list of arguments for PROC. Whatever
4468 the case, futz with things so that ARG1 is the first argument to
4469 give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
4472 Setting the debug apply frame args this way is pretty messy.
4473 Perhaps we should store arg1 and args directly in the frame as
4474 received, and let scm_frame_arguments unpack them, because that's
4475 a relatively rare operation. This works for now; if the Guile
4476 developer archives are still around, see Mikael's post of
4478 if (SCM_NULLP (args
))
4480 if (SCM_NULLP (arg1
))
4482 arg1
= SCM_UNDEFINED
;
4484 debug
.vect
[0].a
.args
= SCM_EOL
;
4490 debug
.vect
[0].a
.args
= arg1
;
4492 args
= SCM_CDR (arg1
);
4493 arg1
= SCM_CAR (arg1
);
4498 args
= scm_nconc2last (args
);
4500 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4504 if (SCM_ENTER_FRAME_P
&& SCM_TRAPS_P
)
4507 if (SCM_CHEAPTRAPS_P
)
4508 tmp
= scm_make_debugobj (&debug
);
4513 tmp
= scm_make_continuation (&first
);
4518 scm_call_2 (SCM_ENTER_FRAME_HDLR
, scm_sym_enter_frame
, tmp
);
4525 switch (SCM_TYP7 (proc
))
4527 case scm_tc7_subr_2o
:
4528 args
= SCM_NULLP (args
) ? SCM_UNDEFINED
: SCM_CAR (args
);
4529 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4530 case scm_tc7_subr_2
:
4531 if (SCM_NULLP (args
) || !SCM_NULLP (SCM_CDR (args
)))
4532 scm_wrong_num_args (proc
);
4533 args
= SCM_CAR (args
);
4534 RETURN (SCM_SUBRF (proc
) (arg1
, args
));
4535 case scm_tc7_subr_0
:
4536 if (!SCM_UNBNDP (arg1
))
4537 scm_wrong_num_args (proc
);
4539 RETURN (SCM_SUBRF (proc
) ());
4540 case scm_tc7_subr_1
:
4541 if (SCM_UNBNDP (arg1
))
4542 scm_wrong_num_args (proc
);
4543 case scm_tc7_subr_1o
:
4544 if (!SCM_NULLP (args
))
4545 scm_wrong_num_args (proc
);
4547 RETURN (SCM_SUBRF (proc
) (arg1
));
4549 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4550 scm_wrong_num_args (proc
);
4551 if (SCM_INUMP (arg1
))
4553 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4555 else if (SCM_REALP (arg1
))
4557 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4559 else if (SCM_BIGP (arg1
))
4561 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4563 else if (SCM_FRACTIONP (arg1
))
4565 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4567 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4568 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4570 if (SCM_UNBNDP (arg1
) || !SCM_NULLP (args
))
4571 scm_wrong_num_args (proc
);
4573 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4576 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4577 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4578 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4583 case scm_tc7_subr_3
:
4584 if (SCM_NULLP (args
)
4585 || SCM_NULLP (SCM_CDR (args
))
4586 || !SCM_NULLP (SCM_CDDR (args
)))
4587 scm_wrong_num_args (proc
);
4589 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CADR (args
)));
4592 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
));
4594 RETURN (SCM_SUBRF (proc
) (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
)));
4596 case scm_tc7_lsubr_2
:
4597 if (!SCM_CONSP (args
))
4598 scm_wrong_num_args (proc
);
4600 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4602 if (SCM_NULLP (args
))
4603 RETURN (SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
));
4604 while (SCM_NIMP (args
))
4606 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4607 arg1
= SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
));
4608 args
= SCM_CDR (args
);
4611 case scm_tc7_rpsubr
:
4612 if (SCM_NULLP (args
))
4613 RETURN (SCM_BOOL_T
);
4614 while (SCM_NIMP (args
))
4616 SCM_ASSERT (SCM_CONSP (args
), args
, SCM_ARG2
, "apply");
4617 if (SCM_FALSEP (SCM_SUBRF (proc
) (arg1
, SCM_CAR (args
))))
4618 RETURN (SCM_BOOL_F
);
4619 arg1
= SCM_CAR (args
);
4620 args
= SCM_CDR (args
);
4622 RETURN (SCM_BOOL_T
);
4623 case scm_tcs_closures
:
4625 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4627 arg1
= (SCM_UNBNDP (arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4629 if (scm_badargsp (SCM_CLOSURE_FORMALS (proc
), arg1
))
4630 scm_wrong_num_args (proc
);
4632 /* Copy argument list */
4637 SCM tl
= args
= scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
);
4638 for (arg1
= SCM_CDR (arg1
); SCM_CONSP (arg1
); arg1
= SCM_CDR (arg1
))
4640 SCM_SETCDR (tl
, scm_cons (SCM_CAR (arg1
), SCM_UNSPECIFIED
));
4643 SCM_SETCDR (tl
, arg1
);
4646 args
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4649 proc
= SCM_CLOSURE_BODY (proc
);
4651 arg1
= SCM_CDR (proc
);
4652 while (!SCM_NULLP (arg1
))
4654 if (SCM_IMP (SCM_CAR (proc
)))
4656 if (SCM_ISYMP (SCM_CAR (proc
)))
4658 scm_rec_mutex_lock (&source_mutex
);
4659 /* check for race condition */
4660 if (SCM_ISYMP (SCM_CAR (proc
)))
4661 m_expand_body (proc
, args
);
4662 scm_rec_mutex_unlock (&source_mutex
);
4666 SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc
));
4669 (void) EVAL (SCM_CAR (proc
), args
);
4671 arg1
= SCM_CDR (proc
);
4673 RETURN (EVALCAR (proc
, args
));
4675 if (!SCM_SMOB_APPLICABLE_P (proc
))
4677 if (SCM_UNBNDP (arg1
))
4678 RETURN (SCM_SMOB_APPLY_0 (proc
));
4679 else if (SCM_NULLP (args
))
4680 RETURN (SCM_SMOB_APPLY_1 (proc
, arg1
));
4681 else if (SCM_NULLP (SCM_CDR (args
)))
4682 RETURN (SCM_SMOB_APPLY_2 (proc
, arg1
, SCM_CAR (args
)));
4684 RETURN (SCM_SMOB_APPLY_3 (proc
, arg1
, SCM_CAR (args
), SCM_CDR (args
)));
4687 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4689 proc
= SCM_CCLO_SUBR (proc
);
4690 debug
.vect
[0].a
.proc
= proc
;
4691 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4693 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4695 proc
= SCM_CCLO_SUBR (proc
);
4699 proc
= SCM_PROCEDURE (proc
);
4701 debug
.vect
[0].a
.proc
= proc
;
4704 case scm_tcs_struct
:
4705 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4708 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4710 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4712 RETURN (scm_apply_generic (proc
, args
));
4714 else if (SCM_I_OPERATORP (proc
))
4718 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: debug
.vect
[0].a
.args
);
4720 args
= (SCM_UNBNDP(arg1
) ? SCM_EOL
: scm_cons (arg1
, args
));
4723 proc
= (SCM_I_ENTITYP (proc
)
4724 ? SCM_ENTITY_PROCEDURE (proc
)
4725 : SCM_OPERATOR_PROCEDURE (proc
));
4727 debug
.vect
[0].a
.proc
= proc
;
4728 debug
.vect
[0].a
.args
= scm_cons (arg1
, args
);
4730 if (SCM_NIMP (proc
))
4739 scm_wrong_type_arg ("apply", SCM_ARG1
, proc
);
4743 if (scm_check_exit_p
&& SCM_TRAPS_P
)
4744 if (SCM_EXIT_FRAME_P
|| (SCM_TRACE_P
&& SCM_TRACED_FRAME_P (debug
)))
4746 SCM_CLEAR_TRACED_FRAME (debug
);
4747 if (SCM_CHEAPTRAPS_P
)
4748 arg1
= scm_make_debugobj (&debug
);
4752 SCM val
= scm_make_continuation (&first
);
4763 scm_call_3 (SCM_EXIT_FRAME_HDLR
, scm_sym_exit_frame
, arg1
, proc
);
4767 scm_last_debug_frame
= debug
.prev
;
4773 /* SECTION: The rest of this file is only read once.
4780 * Trampolines make it possible to move procedure application dispatch
4781 * outside inner loops. The motivation was clean implementation of
4782 * efficient replacements of R5RS primitives in SRFI-1.
4784 * The semantics is clear: scm_trampoline_N returns an optimized
4785 * version of scm_call_N (or NULL if the procedure isn't applicable
4788 * Applying the optimization to map and for-each increased efficiency
4789 * noticeably. For example, (map abs ls) is now 8 times faster than
4794 call_subr0_0 (SCM proc
)
4796 return SCM_SUBRF (proc
) ();
4800 call_subr1o_0 (SCM proc
)
4802 return SCM_SUBRF (proc
) (SCM_UNDEFINED
);
4806 call_lsubr_0 (SCM proc
)
4808 return SCM_SUBRF (proc
) (SCM_EOL
);
4812 scm_i_call_closure_0 (SCM proc
)
4814 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4817 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4822 scm_trampoline_0 (SCM proc
)
4824 scm_t_trampoline_0 trampoline
;
4829 switch (SCM_TYP7 (proc
))
4831 case scm_tc7_subr_0
:
4832 trampoline
= call_subr0_0
;
4834 case scm_tc7_subr_1o
:
4835 trampoline
= call_subr1o_0
;
4838 trampoline
= call_lsubr_0
;
4840 case scm_tcs_closures
:
4842 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4843 if (SCM_NULLP (formals
) || !SCM_CONSP (formals
))
4844 trampoline
= scm_i_call_closure_0
;
4849 case scm_tcs_struct
:
4850 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4851 trampoline
= scm_call_generic_0
;
4852 else if (SCM_I_OPERATORP (proc
))
4853 trampoline
= scm_call_0
;
4858 if (SCM_SMOB_APPLICABLE_P (proc
))
4859 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_0
;
4864 case scm_tc7_rpsubr
:
4867 trampoline
= scm_call_0
;
4870 return NULL
; /* not applicable on zero arguments */
4872 /* We only reach this point if a valid trampoline was determined. */
4874 /* If debugging is enabled, we want to see all calls to proc on the stack.
4875 * Thus, we replace the trampoline shortcut with scm_call_0. */
4876 if (scm_debug_mode_p
)
4883 call_subr1_1 (SCM proc
, SCM arg1
)
4885 return SCM_SUBRF (proc
) (arg1
);
4889 call_subr2o_1 (SCM proc
, SCM arg1
)
4891 return SCM_SUBRF (proc
) (arg1
, SCM_UNDEFINED
);
4895 call_lsubr_1 (SCM proc
, SCM arg1
)
4897 return SCM_SUBRF (proc
) (scm_list_1 (arg1
));
4901 call_dsubr_1 (SCM proc
, SCM arg1
)
4903 if (SCM_INUMP (arg1
))
4905 RETURN (scm_make_real (SCM_DSUBRF (proc
) ((double) SCM_INUM (arg1
))));
4907 else if (SCM_REALP (arg1
))
4909 RETURN (scm_make_real (SCM_DSUBRF (proc
) (SCM_REAL_VALUE (arg1
))));
4911 else if (SCM_BIGP (arg1
))
4913 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_big2dbl (arg1
))));
4915 else if (SCM_FRACTIONP (arg1
))
4917 RETURN (scm_make_real (SCM_DSUBRF (proc
) (scm_i_fraction2double (arg1
))));
4919 SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc
), arg1
,
4920 SCM_ARG1
, SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4924 call_cxr_1 (SCM proc
, SCM arg1
)
4926 unsigned char pattern
= (scm_t_bits
) SCM_SUBRF (proc
);
4929 SCM_ASSERT (SCM_CONSP (arg1
), arg1
, SCM_ARG1
,
4930 SCM_SYMBOL_CHARS (SCM_SNAME (proc
)));
4931 arg1
= (pattern
& 1) ? SCM_CAR (arg1
) : SCM_CDR (arg1
);
4938 call_closure_1 (SCM proc
, SCM arg1
)
4940 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
4943 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
4948 scm_trampoline_1 (SCM proc
)
4950 scm_t_trampoline_1 trampoline
;
4955 switch (SCM_TYP7 (proc
))
4957 case scm_tc7_subr_1
:
4958 case scm_tc7_subr_1o
:
4959 trampoline
= call_subr1_1
;
4961 case scm_tc7_subr_2o
:
4962 trampoline
= call_subr2o_1
;
4965 trampoline
= call_lsubr_1
;
4968 trampoline
= call_dsubr_1
;
4971 trampoline
= call_cxr_1
;
4973 case scm_tcs_closures
:
4975 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
4976 if (!SCM_NULLP (formals
)
4977 && (!SCM_CONSP (formals
) || !SCM_CONSP (SCM_CDR (formals
))))
4978 trampoline
= call_closure_1
;
4983 case scm_tcs_struct
:
4984 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
4985 trampoline
= scm_call_generic_1
;
4986 else if (SCM_I_OPERATORP (proc
))
4987 trampoline
= scm_call_1
;
4992 if (SCM_SMOB_APPLICABLE_P (proc
))
4993 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_1
;
4998 case scm_tc7_rpsubr
:
5001 trampoline
= scm_call_1
;
5004 return NULL
; /* not applicable on one arg */
5006 /* We only reach this point if a valid trampoline was determined. */
5008 /* If debugging is enabled, we want to see all calls to proc on the stack.
5009 * Thus, we replace the trampoline shortcut with scm_call_1. */
5010 if (scm_debug_mode_p
)
5017 call_subr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5019 return SCM_SUBRF (proc
) (arg1
, arg2
);
5023 call_lsubr2_2 (SCM proc
, SCM arg1
, SCM arg2
)
5025 return SCM_SUBRF (proc
) (arg1
, arg2
, SCM_EOL
);
5029 call_lsubr_2 (SCM proc
, SCM arg1
, SCM arg2
)
5031 return SCM_SUBRF (proc
) (scm_list_2 (arg1
, arg2
));
5035 call_closure_2 (SCM proc
, SCM arg1
, SCM arg2
)
5037 const SCM env
= SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc
),
5038 scm_list_2 (arg1
, arg2
),
5040 const SCM result
= scm_eval_body (SCM_CLOSURE_BODY (proc
), env
);
5045 scm_trampoline_2 (SCM proc
)
5047 scm_t_trampoline_2 trampoline
;
5052 switch (SCM_TYP7 (proc
))
5054 case scm_tc7_subr_2
:
5055 case scm_tc7_subr_2o
:
5056 case scm_tc7_rpsubr
:
5058 trampoline
= call_subr2_2
;
5060 case scm_tc7_lsubr_2
:
5061 trampoline
= call_lsubr2_2
;
5064 trampoline
= call_lsubr_2
;
5066 case scm_tcs_closures
:
5068 SCM formals
= SCM_CLOSURE_FORMALS (proc
);
5069 if (!SCM_NULLP (formals
)
5070 && (!SCM_CONSP (formals
)
5071 || (!SCM_NULLP (SCM_CDR (formals
))
5072 && (!SCM_CONSP (SCM_CDR (formals
))
5073 || !SCM_CONSP (SCM_CDDR (formals
))))))
5074 trampoline
= call_closure_2
;
5079 case scm_tcs_struct
:
5080 if (SCM_OBJ_CLASS_FLAGS (proc
) & SCM_CLASSF_PURE_GENERIC
)
5081 trampoline
= scm_call_generic_2
;
5082 else if (SCM_I_OPERATORP (proc
))
5083 trampoline
= scm_call_2
;
5088 if (SCM_SMOB_APPLICABLE_P (proc
))
5089 trampoline
= SCM_SMOB_DESCRIPTOR (proc
).apply_2
;
5095 trampoline
= scm_call_2
;
5098 return NULL
; /* not applicable on two args */
5100 /* We only reach this point if a valid trampoline was determined. */
5102 /* If debugging is enabled, we want to see all calls to proc on the stack.
5103 * Thus, we replace the trampoline shortcut with scm_call_2. */
5104 if (scm_debug_mode_p
)
5110 /* Typechecking for multi-argument MAP and FOR-EACH.
5112 Verify that each element of the vector ARGV, except for the first,
5113 is a proper list whose length is LEN. Attribute errors to WHO,
5114 and claim that the i'th element of ARGV is WHO's i+2'th argument. */
5116 check_map_args (SCM argv
,
5123 SCM
const *ve
= SCM_VELTS (argv
);
5126 for (i
= SCM_VECTOR_LENGTH (argv
) - 1; i
>= 1; i
--)
5128 long elt_len
= scm_ilength (ve
[i
]);
5133 scm_apply_generic (gf
, scm_cons (proc
, args
));
5135 scm_wrong_type_arg (who
, i
+ 2, ve
[i
]);
5139 scm_out_of_range_pos (who
, ve
[i
], SCM_MAKINUM (i
+ 2));
5142 scm_remember_upto_here_1 (argv
);
5146 SCM_GPROC (s_map
, "map", 2, 0, 1, scm_map
, g_map
);
5148 /* Note: Currently, scm_map applies PROC to the argument list(s)
5149 sequentially, starting with the first element(s). This is used in
5150 evalext.c where the Scheme procedure `map-in-order', which guarantees
5151 sequential behaviour, is implemented using scm_map. If the
5152 behaviour changes, we need to update `map-in-order'.
5156 scm_map (SCM proc
, SCM arg1
, SCM args
)
5157 #define FUNC_NAME s_map
5162 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5164 len
= scm_ilength (arg1
);
5165 SCM_GASSERTn (len
>= 0,
5166 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG2
, s_map
);
5167 SCM_VALIDATE_REST_ARGUMENT (args
);
5168 if (SCM_NULLP (args
))
5170 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5171 SCM_GASSERT2 (call
, g_map
, proc
, arg1
, SCM_ARG1
, s_map
);
5172 while (SCM_NIMP (arg1
))
5174 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
)));
5175 pres
= SCM_CDRLOC (*pres
);
5176 arg1
= SCM_CDR (arg1
);
5180 if (SCM_NULLP (SCM_CDR (args
)))
5182 SCM arg2
= SCM_CAR (args
);
5183 int len2
= scm_ilength (arg2
);
5184 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5186 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_map
);
5187 SCM_GASSERTn (len2
>= 0,
5188 g_map
, scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_map
);
5190 SCM_OUT_OF_RANGE (3, arg2
);
5191 while (SCM_NIMP (arg1
))
5193 *pres
= scm_list_1 (call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
)));
5194 pres
= SCM_CDRLOC (*pres
);
5195 arg1
= SCM_CDR (arg1
);
5196 arg2
= SCM_CDR (arg2
);
5200 arg1
= scm_cons (arg1
, args
);
5201 args
= scm_vector (arg1
);
5202 ve
= SCM_VELTS (args
);
5203 check_map_args (args
, len
, g_map
, proc
, arg1
, s_map
);
5207 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5209 if (SCM_IMP (ve
[i
]))
5211 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5212 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5214 *pres
= scm_list_1 (scm_apply (proc
, arg1
, SCM_EOL
));
5215 pres
= SCM_CDRLOC (*pres
);
5221 SCM_GPROC (s_for_each
, "for-each", 2, 0, 1, scm_for_each
, g_for_each
);
5224 scm_for_each (SCM proc
, SCM arg1
, SCM args
)
5225 #define FUNC_NAME s_for_each
5227 SCM
const *ve
= &args
; /* Keep args from being optimized away. */
5229 len
= scm_ilength (arg1
);
5230 SCM_GASSERTn (len
>= 0, g_for_each
, scm_cons2 (proc
, arg1
, args
),
5231 SCM_ARG2
, s_for_each
);
5232 SCM_VALIDATE_REST_ARGUMENT (args
);
5233 if (SCM_NULLP (args
))
5235 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
5236 SCM_GASSERT2 (call
, g_for_each
, proc
, arg1
, SCM_ARG1
, s_for_each
);
5237 while (SCM_NIMP (arg1
))
5239 call (proc
, SCM_CAR (arg1
));
5240 arg1
= SCM_CDR (arg1
);
5242 return SCM_UNSPECIFIED
;
5244 if (SCM_NULLP (SCM_CDR (args
)))
5246 SCM arg2
= SCM_CAR (args
);
5247 int len2
= scm_ilength (arg2
);
5248 scm_t_trampoline_2 call
= scm_trampoline_2 (proc
);
5249 SCM_GASSERTn (call
, g_for_each
,
5250 scm_cons2 (proc
, arg1
, args
), SCM_ARG1
, s_for_each
);
5251 SCM_GASSERTn (len2
>= 0, g_for_each
,
5252 scm_cons2 (proc
, arg1
, args
), SCM_ARG3
, s_for_each
);
5254 SCM_OUT_OF_RANGE (3, arg2
);
5255 while (SCM_NIMP (arg1
))
5257 call (proc
, SCM_CAR (arg1
), SCM_CAR (arg2
));
5258 arg1
= SCM_CDR (arg1
);
5259 arg2
= SCM_CDR (arg2
);
5261 return SCM_UNSPECIFIED
;
5263 arg1
= scm_cons (arg1
, args
);
5264 args
= scm_vector (arg1
);
5265 ve
= SCM_VELTS (args
);
5266 check_map_args (args
, len
, g_for_each
, proc
, arg1
, s_for_each
);
5270 for (i
= SCM_VECTOR_LENGTH (args
) - 1; i
>= 0; i
--)
5272 if (SCM_IMP (ve
[i
]))
5273 return SCM_UNSPECIFIED
;
5274 arg1
= scm_cons (SCM_CAR (ve
[i
]), arg1
);
5275 SCM_VECTOR_SET (args
, i
, SCM_CDR (ve
[i
]));
5277 scm_apply (proc
, arg1
, SCM_EOL
);
5284 scm_closure (SCM code
, SCM env
)
5287 SCM closcar
= scm_cons (code
, SCM_EOL
);
5288 z
= scm_cell (SCM_UNPACK (closcar
) + scm_tc3_closure
, (scm_t_bits
) env
);
5289 scm_remember_upto_here (closcar
);
5294 scm_t_bits scm_tc16_promise
;
5297 scm_makprom (SCM code
)
5299 SCM_RETURN_NEWSMOB2 (scm_tc16_promise
,
5301 scm_make_rec_mutex ());
5305 promise_free (SCM promise
)
5307 scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise
));
5312 promise_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
5314 int writingp
= SCM_WRITINGP (pstate
);
5315 scm_puts ("#<promise ", port
);
5316 SCM_SET_WRITINGP (pstate
, 1);
5317 scm_iprin1 (SCM_PROMISE_DATA (exp
), port
, pstate
);
5318 SCM_SET_WRITINGP (pstate
, writingp
);
5319 scm_putc ('>', port
);
5323 SCM_DEFINE (scm_force
, "force", 1, 0, 0,
5325 "If the promise @var{x} has not been computed yet, compute and\n"
5326 "return @var{x}, otherwise just return the previously computed\n"
5328 #define FUNC_NAME s_scm_force
5330 SCM_VALIDATE_SMOB (1, promise
, promise
);
5331 scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise
));
5332 if (!SCM_PROMISE_COMPUTED_P (promise
))
5334 SCM ans
= scm_call_0 (SCM_PROMISE_DATA (promise
));
5335 if (!SCM_PROMISE_COMPUTED_P (promise
))
5337 SCM_SET_PROMISE_DATA (promise
, ans
);
5338 SCM_SET_PROMISE_COMPUTED (promise
);
5341 scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise
));
5342 return SCM_PROMISE_DATA (promise
);
5347 SCM_DEFINE (scm_promise_p
, "promise?", 1, 0, 0,
5349 "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
5350 "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
5351 #define FUNC_NAME s_scm_promise_p
5353 return SCM_BOOL (SCM_TYP16_PREDICATE (scm_tc16_promise
, obj
));
5358 SCM_DEFINE (scm_cons_source
, "cons-source", 3, 0, 0,
5359 (SCM xorig
, SCM x
, SCM y
),
5360 "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
5361 "Any source properties associated with @var{xorig} are also associated\n"
5362 "with the new pair.")
5363 #define FUNC_NAME s_scm_cons_source
5366 z
= scm_cons (x
, y
);
5367 /* Copy source properties possibly associated with xorig. */
5368 p
= scm_whash_lookup (scm_source_whash
, xorig
);
5370 scm_whash_insert (scm_source_whash
, z
, p
);
5376 /* The function scm_copy_tree is used to copy an expression tree to allow the
5377 * memoizer to modify the expression during memoization. scm_copy_tree
5378 * creates deep copies of pairs and vectors, but not of any other data types,
5379 * since only pairs and vectors will be parsed by the memoizer.
5381 * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
5382 * pattern is used to detect cycles. In fact, the pattern is used in two
5383 * dimensions, vertical (indicated in the code by the variable names 'hare'
5384 * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
5385 * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
5388 * The vertical dimension corresponds to recursive calls to function
5389 * copy_tree: This happens when descending into vector elements, into cars of
5390 * lists and into the cdr of an improper list. In this dimension, the
5391 * tortoise follows the hare by using the processor stack: Every stack frame
5392 * will hold an instance of struct t_trace. These instances are connected in
5393 * a way that represents the trace of the hare, which thus can be followed by
5394 * the tortoise. The tortoise will always point to struct t_trace instances
5395 * relating to SCM objects that have already been copied. Thus, a cycle is
5396 * detected if the tortoise and the hare point to the same object,
5398 * The horizontal dimension is within one execution of copy_tree, when the
5399 * function cdr's along the pairs of a list. This is the standard
5400 * hare-and-tortoise implementation, found several times in guile. */
5403 struct t_trace
*trace
; // These pointers form a trace along the stack.
5404 SCM obj
; // The object handled at the respective stack frame.
5409 struct t_trace
*const hare
,
5410 struct t_trace
*tortoise
,
5411 unsigned int tortoise_delay
)
5413 if (!SCM_CONSP (hare
->obj
) && !SCM_VECTORP (hare
->obj
))
5419 /* Prepare the trace along the stack. */
5420 struct t_trace new_hare
;
5421 hare
->trace
= &new_hare
;
5423 /* The tortoise will make its step after the delay has elapsed. Note
5424 * that in contrast to the typical hare-and-tortoise pattern, the step
5425 * of the tortoise happens before the hare takes its steps. This is, in
5426 * principle, no problem, except for the start of the algorithm: Then,
5427 * it has to be made sure that the hare actually gets its advantage of
5429 if (tortoise_delay
== 0)
5432 tortoise
= tortoise
->trace
;
5433 ASSERT_SYNTAX (!SCM_EQ_P (hare
->obj
, tortoise
->obj
),
5434 s_bad_expression
, hare
->obj
);
5441 if (SCM_VECTORP (hare
->obj
))
5443 const unsigned long int length
= SCM_VECTOR_LENGTH (hare
->obj
);
5444 const SCM new_vector
= scm_c_make_vector (length
, SCM_UNSPECIFIED
);
5446 /* Each vector element is copied by recursing into copy_tree, having
5447 * the tortoise follow the hare into the depths of the stack. */
5448 unsigned long int i
;
5449 for (i
= 0; i
< length
; ++i
)
5452 new_hare
.obj
= SCM_VECTOR_REF (hare
->obj
, i
);
5453 new_element
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5454 SCM_VECTOR_SET (new_vector
, i
, new_element
);
5459 else // SCM_CONSP (hare->obj)
5464 SCM rabbit
= hare
->obj
;
5465 SCM turtle
= hare
->obj
;
5469 /* The first pair of the list is treated specially, in order to
5470 * preserve a potential source code position. */
5471 result
= tail
= scm_cons_source (rabbit
, SCM_EOL
, SCM_EOL
);
5472 new_hare
.obj
= SCM_CAR (rabbit
);
5473 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5474 SCM_SETCAR (tail
, copy
);
5476 /* The remaining pairs of the list are copied by, horizontally,
5477 * having the turtle follow the rabbit, and, vertically, having the
5478 * tortoise follow the hare into the depths of the stack. */
5479 rabbit
= SCM_CDR (rabbit
);
5480 while (SCM_CONSP (rabbit
))
5482 new_hare
.obj
= SCM_CAR (rabbit
);
5483 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5484 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5485 tail
= SCM_CDR (tail
);
5487 rabbit
= SCM_CDR (rabbit
);
5488 if (SCM_CONSP (rabbit
))
5490 new_hare
.obj
= SCM_CAR (rabbit
);
5491 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5492 SCM_SETCDR (tail
, scm_cons (copy
, SCM_UNDEFINED
));
5493 tail
= SCM_CDR (tail
);
5494 rabbit
= SCM_CDR (rabbit
);
5496 turtle
= SCM_CDR (turtle
);
5497 ASSERT_SYNTAX (!SCM_EQ_P (rabbit
, turtle
),
5498 s_bad_expression
, rabbit
);
5502 /* We have to recurse into copy_tree again for the last cdr, in
5503 * order to handle the situation that it holds a vector. */
5504 new_hare
.obj
= rabbit
;
5505 copy
= copy_tree (&new_hare
, tortoise
, tortoise_delay
);
5506 SCM_SETCDR (tail
, copy
);
5513 SCM_DEFINE (scm_copy_tree
, "copy-tree", 1, 0, 0,
5515 "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
5516 "the new data structure. @code{copy-tree} recurses down the\n"
5517 "contents of both pairs and vectors (since both cons cells and vector\n"
5518 "cells may point to arbitrary objects), and stops recursing when it hits\n"
5519 "any other object.")
5520 #define FUNC_NAME s_scm_copy_tree
5522 /* Prepare the trace along the stack. */
5523 struct t_trace trace
;
5526 /* In function copy_tree, if the tortoise makes its step, it will do this
5527 * before the hare has the chance to move. Thus, we have to make sure that
5528 * the very first step of the tortoise will not happen after the hare has
5529 * really made two steps. This is achieved by passing '2' as the initial
5530 * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
5531 * a bigger advantage may improve performance slightly. */
5532 return copy_tree (&trace
, &trace
, 2);
5537 /* We have three levels of EVAL here:
5539 - scm_i_eval (exp, env)
5541 evaluates EXP in environment ENV. ENV is a lexical environment
5542 structure as used by the actual tree code evaluator. When ENV is
5543 a top-level environment, then changes to the current module are
5544 tracked by updating ENV so that it continues to be in sync with
5547 - scm_primitive_eval (exp)
5549 evaluates EXP in the top-level environment as determined by the
5550 current module. This is done by constructing a suitable
5551 environment and calling scm_i_eval. Thus, changes to the
5552 top-level module are tracked normally.
5554 - scm_eval (exp, mod)
5556 evaluates EXP while MOD is the current module. This is done by
5557 setting the current module to MOD, invoking scm_primitive_eval on
5558 EXP, and then restoring the current module to the value it had
5559 previously. That is, while EXP is evaluated, changes to the
5560 current module are tracked, but these changes do not persist when
5563 For each level of evals, there are two variants, distinguished by a
5564 _x suffix: the ordinary variant does not modify EXP while the _x
5565 variant can destructively modify EXP into something completely
5566 unintelligible. A Scheme data structure passed as EXP to one of the
5567 _x variants should not ever be used again for anything. So when in
5568 doubt, use the ordinary variant.
5573 scm_i_eval_x (SCM exp
, SCM env
)
5575 if (SCM_SYMBOLP (exp
))
5576 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5578 return SCM_XEVAL (exp
, env
);
5582 scm_i_eval (SCM exp
, SCM env
)
5584 exp
= scm_copy_tree (exp
);
5585 if (SCM_SYMBOLP (exp
))
5586 return *scm_lookupcar (scm_cons (exp
, SCM_UNDEFINED
), env
, 1);
5588 return SCM_XEVAL (exp
, env
);
5592 scm_primitive_eval_x (SCM exp
)
5595 SCM transformer
= scm_current_module_transformer ();
5596 if (SCM_NIMP (transformer
))
5597 exp
= scm_call_1 (transformer
, exp
);
5598 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5599 return scm_i_eval_x (exp
, env
);
5602 SCM_DEFINE (scm_primitive_eval
, "primitive-eval", 1, 0, 0,
5604 "Evaluate @var{exp} in the top-level environment specified by\n"
5605 "the current module.")
5606 #define FUNC_NAME s_scm_primitive_eval
5609 SCM transformer
= scm_current_module_transformer ();
5610 if (SCM_NIMP (transformer
))
5611 exp
= scm_call_1 (transformer
, exp
);
5612 env
= scm_top_level_env (scm_current_module_lookup_closure ());
5613 return scm_i_eval (exp
, env
);
5618 /* Eval does not take the second arg optionally. This is intentional
5619 * in order to be R5RS compatible, and to prepare for the new module
5620 * system, where we would like to make the choice of evaluation
5621 * environment explicit. */
5624 change_environment (void *data
)
5626 SCM pair
= SCM_PACK (data
);
5627 SCM new_module
= SCM_CAR (pair
);
5628 SCM old_module
= scm_current_module ();
5629 SCM_SETCDR (pair
, old_module
);
5630 scm_set_current_module (new_module
);
5634 restore_environment (void *data
)
5636 SCM pair
= SCM_PACK (data
);
5637 SCM old_module
= SCM_CDR (pair
);
5638 SCM new_module
= scm_current_module ();
5639 SCM_SETCAR (pair
, new_module
);
5640 scm_set_current_module (old_module
);
5644 inner_eval_x (void *data
)
5646 return scm_primitive_eval_x (SCM_PACK(data
));
5650 scm_eval_x (SCM exp
, SCM module
)
5651 #define FUNC_NAME "eval!"
5653 SCM_VALIDATE_MODULE (2, module
);
5655 return scm_internal_dynamic_wind
5656 (change_environment
, inner_eval_x
, restore_environment
,
5657 (void *) SCM_UNPACK (exp
),
5658 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5663 inner_eval (void *data
)
5665 return scm_primitive_eval (SCM_PACK(data
));
5668 SCM_DEFINE (scm_eval
, "eval", 2, 0, 0,
5669 (SCM exp
, SCM module
),
5670 "Evaluate @var{exp}, a list representing a Scheme expression,\n"
5671 "in the top-level environment specified by @var{module}.\n"
5672 "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
5673 "@var{module} is made the current module. The current module\n"
5674 "is reset to its previous value when @var{eval} returns.")
5675 #define FUNC_NAME s_scm_eval
5677 SCM_VALIDATE_MODULE (2, module
);
5679 return scm_internal_dynamic_wind
5680 (change_environment
, inner_eval
, restore_environment
,
5681 (void *) SCM_UNPACK (exp
),
5682 (void *) SCM_UNPACK (scm_cons (module
, SCM_BOOL_F
)));
5687 /* At this point, deval and scm_dapply are generated.
5694 #if (SCM_ENABLE_DEPRECATED == 1)
5696 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5697 SCM
scm_ceval (SCM x
, SCM env
)
5700 return ceval (x
, env
);
5701 else if (SCM_SYMBOLP (x
))
5702 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5704 return SCM_XEVAL (x
, env
);
5707 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5708 SCM
scm_deval (SCM x
, SCM env
)
5711 return deval (x
, env
);
5712 else if (SCM_SYMBOLP (x
))
5713 return *scm_lookupcar (scm_cons (x
, SCM_UNDEFINED
), env
, 1);
5715 return SCM_XEVAL (x
, env
);
5719 dispatching_eval (SCM x
, SCM env
)
5721 if (scm_debug_mode_p
)
5722 return scm_deval (x
, env
);
5724 return scm_ceval (x
, env
);
5727 /* Deprecated in guile 1.7.0 on 2004-03-29. */
5728 SCM (*scm_ceval_ptr
) (SCM x
, SCM env
) = dispatching_eval
;
5736 scm_init_opts (scm_evaluator_traps
,
5737 scm_evaluator_trap_table
,
5738 SCM_N_EVALUATOR_TRAPS
);
5739 scm_init_opts (scm_eval_options_interface
,
5741 SCM_N_EVAL_OPTIONS
);
5743 scm_tc16_promise
= scm_make_smob_type ("promise", 0);
5744 scm_set_smob_mark (scm_tc16_promise
, scm_markcdr
);
5745 scm_set_smob_free (scm_tc16_promise
, promise_free
);
5746 scm_set_smob_print (scm_tc16_promise
, promise_print
);
5748 undefineds
= scm_list_1 (SCM_UNDEFINED
);
5749 SCM_SETCDR (undefineds
, undefineds
);
5750 scm_permanent_object (undefineds
);
5752 scm_listofnull
= scm_list_1 (SCM_EOL
);
5754 f_apply
= scm_c_define_subr ("apply", scm_tc7_lsubr_2
, scm_apply
);
5755 scm_permanent_object (f_apply
);
5757 #include "libguile/eval.x"
5759 scm_add_feature ("delay");